diff options
Diffstat (limited to 'src/endpoint.lisp')
| -rw-r--r-- | src/endpoint.lisp | 215 |
1 files changed, 7 insertions, 208 deletions
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.")) |