diff options
Diffstat (limited to 'src/endpoint.lisp')
| -rw-r--r-- | src/endpoint.lisp | 277 |
1 files changed, 268 insertions, 9 deletions
diff --git a/src/endpoint.lisp b/src/endpoint.lisp index 9ec1937..c0b89da 100644 --- a/src/endpoint.lisp +++ b/src/endpoint.lisp @@ -27,7 +27,13 @@ "Return the list of all INITARG symbols that can be supplied as keyword arguments to make-instance for CLASS." (reduce #'append (mop:class-slots class) - :key #'mop:slot-definition-initargs)) + :key #'mop:slot-definition-initargs + :initial-value nil)) + +(defun class-slot-names (class) + (mapcar + #'closer-mop:slot-definition-name + (closer-mop:class-slots (find-class class)))) ;;; ENDPOINT METACLASS @@ -60,6 +66,12 @@ keyword arguments to make-instance for CLASS." consisting in an INITARG and a function to parse a regex group match. There should be the same number of extractors as there are regex groups in ROUTE.") + (route-builder + :accessor route-builder + :type function + :documentation + "A function that generates a route to this endpoint. It is constructed + from the route and stored here.") (method :reader request-method :initarg :method @@ -118,6 +130,13 @@ the request's POST-PARAMETERS slot." (gethash type *mimetype-parsers*)) (defun register-body-parser (type function) + "TYPE should be a string naming a mimetype. FUNCTION should be a +designator for a function that accepts a string and returns an +association list keyed by strings." + (when (pre-parsed-body-p type) + (warn "You are registering a body parser for ~s but it will be ignored + because Hunchentoot pre-parses request bodies of that + type." type)) (setf (gethash type *mimetype-parsers*) function)) (define-condition unregistered-body-type (warning) @@ -147,18 +166,47 @@ Check your spelling or call "If CLASS has a route spec, then it is transfomred into a route matching regex." (cond - ((and (slot-boundp class 'route) (not (slot-boundp class 'route-parts))) - ;; we don't want to set anything, but it can't hurt to check the value - (unless (stringp (route class)) - (error "Route should be a string representing a valid regular expression."))) - ((and (not (slot-boundp class 'route)) (slot-boundp class 'route-parts)) + ((slot-boundp class 'route-parts) (setf (slot-value class 'route) (route-matching-regex (route-parts class)))) (t (error - "Exactly one of :RAW-ROUTE or :ROUTE-PARTS must be supplied to the defintion of class ~a" + ":ROUTE-PARTS must be supplied to the defintion of class ~a" (class-name class))))) +(defun construct-route-builder (class) + (assert (slot-boundp class 'route)) + (let ((build-parts nil)) + (loop + :with extractors := (copy-seq (route-extractors class)) + :for part :in (ppcre:parse-string (route class)) + :do (cond + ((stringp part) + (push part build-parts)) + ((symbolp part) nil) + ((and (listp part) + (eq :register (first part)) + extractors) + (let ((ex (pop extractors))) + (push (if (listp ex) (first ex) ex) + build-parts))) + (t + (error "Cannot build route-builder. + +Non-literal, non-line-boundary regex patterns must be surrounded by +parens. There must be exactly as many patterns as there are +extractors.")))) + (setf build-parts (nreverse build-parts)) + (setf (route-builder class) + (lambda (kwargs) + (apply #'concatenate 'string + (loop :for part :in build-parts + :when (keywordp part) + :do (assert (getf kwargs part) () "path needs ~s" part) + :and :collect (getf kwargs part) + :else + :collect part)))))) + (defun check-endpoint-class (class) "Signals an error if any slot values are malformed. @@ -317,14 +365,225 @@ Good for indicating that you've got a bonkers class option syntax" (defmethod initialize-instance :after ((class endpoint) &key) (mop:ensure-finalized class) (resolve-route-spec class) + (construct-route-builder class) (check-endpoint-class class) (update-dispatch-function class)) (defmethod reinitialize-instance :after ((class endpoint) &key) (mop:ensure-finalized class) (resolve-route-spec class) + (construct-route-builder class) (check-endpoint-class class) (update-dispatch-function class)) - - +;;; TOOLS + +(defun route-to (class &rest kwargs) + (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.")) |