diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/endpoint.lisp | 277 | ||||
| -rw-r--r-- | src/package.lisp | 14 | ||||
| -rw-r--r-- | src/protocol.lisp | 30 | ||||
| -rw-r--r-- | src/server.lisp | 0 |
4 files changed, 304 insertions, 17 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.")) diff --git a/src/package.lisp b/src/package.lisp index c60d03b..a9ab69f 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -5,4 +5,16 @@ (:local-nicknames (#:http #:hunchentoot) (#:a #:alexandria-2) - (#:mop #:closer-mop))) + (#:mop #:closer-mop)) + (:export + ;; HANDLER PROTOCOL + #:authenticate + #:authorize + #:handle + #:not-found + #:slot-required + + ;; METACLASS + #:endpoint + #:register-body-parser)) + diff --git a/src/protocol.lisp b/src/protocol.lisp index 19a4791..d25aa22 100644 --- a/src/protocol.lisp +++ b/src/protocol.lisp @@ -52,7 +52,7 @@ that the request has insufficient permissions to evoke the endpoint handler. ")) (:documentation "Signalled whenever a required slot is missing from a endpoint instance object.")) -(define-condition not-found (protocol-error) +(define-condition not-found (protocol-error) () (:default-initargs :status-code 404)) (defgeneric protocol-error-result (err) @@ -88,15 +88,18 @@ that the request has insufficient permissions to evoke the endpoint handler. ")) (invoke-debugger err) (http:abort-request-handler))))) -(defun protocol-error (error-class req &rest kwargs) +(defun protocol-error (error-class ep &rest kwargs) (apply #'error error-class :raw-request http:*request* - :class (class-of req) + :class (class-of ep) kwargs)) -(defun not-found (req) - (protocol-error 'not-found req)) + +(defun slot-required (ep slot) + "Signals a SLOT-REQUIRED condition" + (protocol-error 'slot-required ep :missing-slot slot)) + ;;; HANDLER PROTOCOL @@ -105,13 +108,13 @@ that the request has insufficient permissions to evoke the endpoint handler. ")) this. Called before handling, should be used to supply user-identifying data to the endpoint instance that might be needed by the handle function.") - (:method ((req t)) t)) + (:method ((ep t)) t)) (defgeneric authorize (endpoint) (:documentation "Returns a boolean. Any endpoint requiring special ownership permissions should implement this. Called before handling and after authenticate.") - (:method ((req t)) t)) + (:method ((ep t)) t)) (defgeneric handle (endpoint) (:documentation "The beef of the endpoint handling protocol. @@ -139,6 +142,19 @@ MUST be implemented for every endpoint class.") (unless (authorize endpoint) (protocol-error 'not-authorized endpoint)))) +;;; HANDLER TOOLS +(defun not-found (ep) + "Signals a NOT-FOUND condition. Usually called within HANDLE or +AUTHORIZE while handling endpoint-class instance EP." + (protocol-error 'not-found ep)) +(defun redirect (url) + "Redirect to URL." + (http:redirect url :code http:+http-see-other+)) +(defun redirect-to (class &rest kwargs) + "Redirect to another endpoint. CLASS can be either a symbol or a + class. KWARGS is a PLIST of keyword arguments supplied to the + CLASS' route builder function." + (redirect (apply #'route-to class kwargs))) diff --git a/src/server.lisp b/src/server.lisp deleted file mode 100644 index e69de29..0000000 --- a/src/server.lisp +++ /dev/null |