diff options
| -rw-r--r-- | examples/dice-roller.lisp | 39 | ||||
| -rw-r--r-- | src/defendpoint.lisp | 205 | ||||
| -rw-r--r-- | src/endpoint.lisp | 215 |
3 files changed, 251 insertions, 208 deletions
diff --git a/examples/dice-roller.lisp b/examples/dice-roller.lisp new file mode 100644 index 0000000..403ed55 --- /dev/null +++ b/examples/dice-roller.lisp @@ -0,0 +1,39 @@ +(defpackage #:dice-roller + (:use #:cl) + (:import-from #:weekend #:endpoint #:handle)) + +(in-package #:dice-roller) + +(defconstant +digits+ "([0-9]+)") + +(defclass roller () + ((rolls + :reader rolls + :initarg :rolls + :type integer + :documentation "The number of rolls") + (sides + :reader sides + :initarg :sides + :type integer + :documentation "The number of sides")) + (:documentation "") + (:metaclass endpoint) + (:method . :get) + (:route-parts "roll" +digits+ "d" +digits+) + (:extractors (:rolls parse-integer) (:sides parse-integer)) + (:content-type . "text/plain")) + +(defmethod handle ((req roller)) + (with-slots (rolls sides) req + (format nil "~ad~a ... rolled a ~a" + rolls sides + (loop :repeat rolls :sum (1+ (random sides)))))) + +(defvar *server* (make-instance 'hunchentoot:easy-acceptor + :port 8080)) + +(hunchentoot:start *server*) + +;; now visit http://localhost:8080/roll/10/d/4 + diff --git a/src/defendpoint.lisp b/src/defendpoint.lisp new file mode 100644 index 0000000..2e87874 --- /dev/null +++ b/src/defendpoint.lisp @@ -0,0 +1,205 @@ +;;; DEFENDPOINT + +(defun path-part-p (part) + "Returns T if PART is a a valid route path part. + +PART is either + STRING + (KEYWORD STRING) + (KEYWORD STRING FUNCTION-NAME)" + (or (stringp part) + (and (listp part) + (or (and (= 2 (length part)) + (do> + (key str) :match= part + :when (keywordp key) + :when (stringp str))) + (and (= 3 (length part)) + (do> + (key str parser) :match= part + :when (keywordp key) + :when (string str) + :when (symbolp parser) + (fboundp parser))))))) + +(defun parameter-spec-p (spec) + "Returns T if SPEC is a valid parameter spec for a DEFENDPOINT form. + +(NAME TYPE &OPTIONAL DOC)" + (and (listp spec) + (symbolp (first spec)) + (symbolp (second spec)) + (or (not (third spec)) + (stringp (third spec))))) + +(defun property-spec-p (spec) + "Returns T if SPEC is a valid property spec for a DEFENDPOINT form. + +(NAME TYPE &KEY DEFAULT DOC)" + (and (listp spec) + (symbolp (first spec)) + (symbolp (second spec)))) + +(defun params-to-slotdefs (specs) + (loop :for (name type . doc) :in specs + :collect `(,name + :accessor ,name + :initarg ,(a:make-keyword name) + :type ,type + :documentation ,(or (first doc) "")))) + +(defun props-to-slotdefs (specs) + (loop :for (name type . kwargs) :in specs + :collect `(,name + :accessor ,name + :initform ,(getf kwargs :default) + :type (or null ,type) + :documentation ,(or (getf kwargs :doc "") + (getf kwargs :documentation ""))))) + +(defun expand-endpoint-class + (name method pathspec handle return + &key + supers + parameters + properties + metaclass + var + documentation + authenticate + authorize) + (setf var (or var (gensym "REQ-"))) + (setf metaclass (or metaclass 'endpoint)) + (let* ((slot-defs + (nconc (params-to-slotdefs parameters) + (props-to-slotdefs properties))) + (all-slots + (nconc (mapcar #'first slot-defs) + (reduce #'union supers :key #'class-slot-names :initial-value nil))) + (route-parts + (loop :for part :in pathspec + :when (stringp part) + :collect part + :else + :collect (second part))) + (extractors + (loop :for part :in pathspec + :when (listp part) + :collect (if (third part) + (list (first part) (third part)) + (first part)))) + (class-options + (nconc + (list (list :metaclass metaclass)) + (list (cons :method method)) + (list (list* :route-parts route-parts)) + (list (cons :content-type return)) + (when extractors + (list (list* :extractors extractors))) + (when documentation + (list (list :documentation documentation)))))) + `(progn + (defclass ,name ,supers + ,slot-defs + ,@class-options) + + (defmethod handle ((,var ,name)) + (with-slots ,all-slots ,var + ,handle)) + + ,@(when authenticate + (list + `(defmethod authenticate ((,var ,name)) + (with-slots ,all-slots ,var + ,authenticate)))) + + ,@(when authorize + (list + `(defmethod authorize ((,var ,name)) + (with-slots ,all-slots ,var + ,authorize))))))) + +(argot:deflanguage defendpoint () + (<class> + :match (:seq (:@ name (:item)) + (:@ supers (:? <supers>)) + (:@ method <method>) + (:@ pathspec <pathspec>) + (:@ return <return>) + (:@ params (:? <parameters>)) + (:@ props (:? <properties>)) + (:@ options (:* <option>)) + (:@ handle <handle>) + (:eof)) + :then (apply #'expand-endpoint-class + name + method + pathspec + handle + return + :supers supers + :parameters params + :properties props + options)) + (<supers> + :match (:seq (:= :extends) (:+ <classname>)) + :then second) + (<classname> + :match (:item) + :if find-class) + (<method> + :match (:or= :get :post :put :patch :head :delete)) + (<pathspec> + :match (:seq (:or= :to :from :at) (:+ <pathpart>)) + :then second) + (<pathpart> + :match (:item) + :if path-part-p + :note "REGEX or (KWD REGEX &optional PARSER)") + (<parameters> + :match (:seq (:= :parameters) (:+ <param>)) + :then second) + (<param> + :match (:item) + :if parameter-spec-p + :note "(NAME TYPE &optional DOCSTRING)") + (<properties> + :match (:seq (:= :properties) (:+ <prop>)) + :then second) + (<prop> + :match (:item) + :if property-spec-p + :note "(NAME TYPE &key DEFAULT DOCSTRING)") + (<option> + :match (:or <doc> <metaclass> <var> + <authenticate> <authorize>)) + (<return> + :match (:seq (:= :returns) (:@ mimetype (:item))) + :if (stringp mimetype) + :then second + :note "The mimetype returned from this endpoint.") + (<doc> + :match (:seq (:= :documentation) (:@ doc (:item))) + :if (stringp doc) + :then (list :documentation doc) + :note "STRING") + (<metaclass> + :match (:seq (:= :custom) <classname>) + :if (mop:subclassp (second <metaclass>) 'endpoint) + :then (list :metaclass (second <metaclass>)) + :note "SYMBOL naming a subclass of ENDPOINT") + (<var> + :match (:seq (:= :var) (:item)) + :if (symbolp (second <var>)) + :then (list :var (second <var>)) + :note "SYMBOL bound to the instance during the handler protocol.") + (<authenticate> + :match (:seq (:= :authenticate) (:item)) + :note "Body form of authenticate method.") + (<authorize> + :match (:seq (:= :authorize) (:item)) + :note "Body form of authorize method.") + (<handle> + :match (:seq (:= :handle) (:item)) + :then second + :note "Body form of handle method.")) diff --git a/src/endpoint.lisp b/src/endpoint.lisp index c0b89da..a0d8f1d 100644 --- a/src/endpoint.lisp +++ b/src/endpoint.lisp @@ -160,7 +160,11 @@ Check your spelling or call (defun route-matching-regex (parts) "Joins route part strings into a route-matching regular expression." - (format nil "^/~{~a~^/~}$" parts)) + (format nil "^/~{~a~^/~}$" (loop :for part :in parts + :if (symbolp part) + :collect (symbol-value part) + :else + :collect part))) (defun resolve-route-spec (class) "If CLASS has a route spec, then it is transfomred into a route @@ -193,9 +197,9 @@ matching regex." (t (error "Cannot build route-builder. -Non-literal, non-line-boundary regex patterns must be surrounded by +Non-literal, non-line-boundary regex patterns (~s) must be surrounded by parens. There must be exactly as many patterns as there are -extractors.")))) +extractors." part)))) (setf build-parts (nreverse build-parts)) (setf (route-builder class) (lambda (kwargs) @@ -382,208 +386,3 @@ Good for indicating that you've got a bonkers class option syntax" (funcall (route-builder (if (symbolp class) (find-class class) class)) kwargs)) -;;; DEFENDPOINT - -(defun path-part-p (part) - "Returns T if PART is a a valid route path part. - -PART is either - STRING - (KEYWORD STRING) - (KEYWORD STRING FUNCTION-NAME)" - (or (stringp part) - (and (listp part) - (or (and (= 2 (length part)) - (do> - (key str) :match= part - :when (keywordp key) - :when (stringp str))) - (and (= 3 (length part)) - (do> - (key str parser) :match= part - :when (keywordp key) - :when (string str) - :when (symbolp parser) - (assert (fboundp parser) (parser) - "No parser bound to ~s for route initarg ~s" - parser key))))))) - -(defun parameter-spec-p (spec) - "Returns T if SPEC is a valid parameter spec for a DEFENDPOINT form. - -(NAME TYPE &OPTIONAL DOC)" - (and (listp spec) - (symbolp (first spec)) - (symbolp (second spec)) - (or (not (third spec)) - (stringp (third spec))))) - -(defun property-spec-p (spec) - "Returns T if SPEC is a valid property spec for a DEFENDPOINT form. - -(NAME TYPE &KEY DEFAULT DOC)" - (and (listp spec) - (symbolp (first spec)) - (symbolp (second spec)))) - -(defun params-to-slotdefs (specs) - (loop :for (name type . doc) :in specs - :collect `(,name - :accessor ,name - :initarg ,(a:make-keyword name) - :type ,type - :documentation ,(or (first doc) "")))) - -(defun props-to-slotdefs (specs) - (loop :for (name type . kwargs) :in specs - :collect `(,name - :accessor ,name - :initform ,(getf kwargs :default) - :type (or null ,type) - :documentation ,(or (getf kwargs :doc "") - (getf kwargs :documentation ""))))) - -(defun expand-endpoint-class - (name method pathspec handle - &key - supers - parameters - properties - metaclass - var - doc - authenticate - authorize) - (setf var (or var (gensym "REQ-"))) - (setf metaclass (or metaclass 'endpoint)) - (let* ((slot-defs - (nconc (params-to-slotdefs parameters) - (props-to-slotdefs properties))) - (all-slots - (nconc (mapcar #'first slot-defs) - (reduce #'union supers :key #'class-slot-names :initial-value nil))) - (route-parts - (loop :for part :in pathspec - :when (stringp part) - :collect part - :else - :collect (second part))) - (extractors - (loop :for part :in pathspec - :when (listp part) - :collect (if (third part) - (list (first part) (third part)) - (first part)))) - (class-options - (nconc - (list (list :metaclass metaclass)) - (list (cons :method method)) - (list (list* :route-parts route-parts)) - (when extractors - (list (list* :extractors extractors))) - (when doc - (list (list :documentation doc)))))) - `(progn - (defclass ,name ,supers - ,slot-defs - ,@class-options) - - (defmethod handle ((,var ,name)) - (with-slots ,all-slots ,var - ,handle)) - - ,@(when authenticate - (list - `(defmethod authenticate ((,var ,name)) - (with-slots ,all-slots ,var - ,authenticate)))) - - ,@(when authorize - (list - `(defmethod authorize ((,var ,name)) - (with-slots ,all-slots ,var - ,authorize))))))) - -(argot:deflanguage defendpoint () - (<class> - :match (:seq (:@ name (:item)) - (:@ supers (:? <supers>)) - (:@ method <method>) - (:@ pathspec <pathspec>) - (:@ params (:? <parameters>)) - (:@ props (:? <properties>)) - (:@ metaclass (:? <metaclass>)) - (:@ doc (:? <doc>)) - (:@ var (:? <var>)) - (:@ authenticate (:? <authenticate>)) - (:@ authorize (:? <authorize>)) - (:@ handle <handle>) - (:eof)) - :then (expand-endpoint-class - name - method - pathspec - handle - :supers supers - :parameters params - :properties props - :metaclass metaclass - :var var - :authenticate authenticate - :authorize authorize)) - (<supers> - :match (:seq (:= :extends) (:+ <classname>)) - :then second) - (<classname> - :match (:item) - :if find-class) - (<method> - :match (:or= :get :post :put :patch :head :delete)) - (<pathspec> - :match (:seq (:or= :to :from :at) (:+ <pathpart>)) - :then second) - (<pathpart> - :match (:item) - :if path-part-p - :note "REGEX or (KWD REGEX &optional PARSER)") - (<parameters> - :match (:seq (:= :parameters) (:+ <param>)) - :then second) - (<param> - :match (:item) - :if parameter-spec-p - :note "(NAME TYPE &optional DOCSTRING)") - (<properties> - :match (:seq (:= :properties) (:+ <prop>)) - :then second) - (<prop> - :match (:item) - :if property-spec-p - :note "(NAME TYPE &key DEFAULT DOCSTRING)") - (<doc> - :match (:seq (:or= :doc :documentation) (:@ doc (:item))) - :if (stringp doc) - :then second - :note "STRING") - (<metaclass> - :match (:seq (:= :custom) <classname>) - :if (mop:subclassp (second <metaclass>) 'endpoint) - :then second - :note "SYMBOL naming a subclass of ENDPOINT") - (<var> - :match (:seq (:= :var) (:item)) - :if (symbolp (second <var>)) - :then second - :note "SYMBOL bound to the instance during the handler protocol.") - (<authenticate> - :match (:seq (:= :authenticate) (:item)) - :then second - :note "Body form of authenticate method.") - (<authorize> - :match (:seq (:= :authorize) (:item)) - :then second - :note "Body form of authorize method.") - (<handle> - :match (:seq (:= :handle) (:item)) - :then second - :note "Body form of handle method.")) |