(in-package #:weekend) ;;; HELPER TYPES (deftype http-method () '(member :get :post :put :patch :delete :head)) (defun list-of-strings-p (xs) (and (listp xs) (every #'stringp xs))) (deftype list-of-strings () '(satisfies list-of-strings-p)) ;;; HELPER FUNCTIONS (defun merge-plists (source target) "Merge two plists SOURCE and TARGET. Return a plist with all elements of SOURCE, plus any from target. When conflcts, source wins." (let ((result (copy-seq source))) (loop :for (k v . _more) :on target :by #'cddr :unless (getf result k) :do (setf (getf result k) v)) result)) (defun class-initargs (class) "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 :initial-value nil)) (defun class-slot-names (class) (mapcar #'closer-mop:slot-definition-name (closer-mop:class-slots (find-class class)))) ;;; ENDPOINT METACLASS (defclass endpoint (standard-class) ((route :reader route :initarg :raw-route :type string :documentation "A regex string used for matching routes to dispatch this endpoint. This :RAW-ROUTE or the :ROUTE-PARTS kwarg must be supplied.") (route-parts :accessor route-parts :initarg :route-parts :type list-of-strings :documentation "A list of strings that, if present, are used to construct the ROUTE to this endpoint. It is an error to supply both a :ROUTE and a :ROUTE-PARTS. An example: if the ROUTE-PARTS is a b c d then ROUTE will be ^a/b/c/d$") (extractors :reader route-extractors :initarg :extractors :initform nil :documentation "Extract and process matchines from the ROUTE regex. It is provided as a list of extractor specs. Each spec should be the INITARG of one of the instance class's slots, or a pair 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 :initform (error "Must supply a request method.") :type http-method) (dispatch-function :accessor dispatch-function :type function :documentation "Function in HUNCHENTOOT:*DISPATCH-TABLE*. (Re)defined whenever an instance of this class is defined.") (want-body-stream :reader want-body-stream :initarg :want-stream :initform nil :type boolean :documentation "If T, a stream is passed to the body parser instead of a string.") (content-type :reader content-type :initarg :content-type :initform nil :type (or null string) :documentation "The content-type the handling of this request returns to the requesting client.")) (:documentation "Metaclass for all request types.")) (defmethod mop:validate-superclass ((sub endpoint) (sup standard-class)) t) ;;; ENDPOINT CLASS REGISTRY (defvar *endpoint-registry* (make-hash-table :test #'eq) "Instances of ENDPOINT register themselves to this table. Keys are symbol class names and values are (METHOD . ROUTE-PATTERN) pairs. The values are provided mostly in the interests of programmer friendlieness - you might want to quickly get a view of which endpoints are dispatching on which routes and methods.") (defun register-endpoint-class (class) (let ((name (class-name class))) (setf (gethash name *endpoint-registry*) (cons (request-method class) (route class))))) (defun print-route-documentation (class &key (stream *standard-output*)) (let* ((class (if (symbolp class) (find-class class) class)) (extractors (route-extractors class)) (*standard-output* stream)) (flet ((extractor-arg (extractor) (if (symbolp extractor) extractor (first extractor)))) (loop :repeat 80 :do (princ "_")) (terpri) (terpri) (format stream "~a ~a ~:[~;→~] ~a~%" (request-method class) (route class) (content-type class) (or (content-type class) "")) (let ((*print-case* :downcase)) (loop :for slotdef :in (mop:class-slots class) :for initarg := (first (mop:slot-definition-initargs slotdef)) :for route-pos := (position initarg extractors :key #'extractor-arg) :when initarg :do (format stream "~10@a : ~10a ~a~a~%" initarg (or (mop:slot-definition-type slotdef) t) (or (documentation slotdef t) "") (if route-pos (format nil "(~:r in route)" (1+ route-pos)) "")))) (a:when-let (doc (documentation class t)) (terpri) (princ doc))))) (defun print-all-route-documentation (&key (stream *standard-output*)) (loop :for class :being :the :hash-keys :of *endpoint-registry* :do (print-route-documentation class :stream stream) (terpri stream))) ;;; BODY PARSER REGISTRATION (defparameter +hunchentoot-pre-decoded-content-types+ '("multipart/form-data" "application/x-www-form-urlencoded")) (defun pre-parsed-body-p (&optional type) "Hunchentoot pre-parses bodies with Content-type multipart/form-data and application/x-www-form-urlencoded and stores them as an alist in the request's POST-PARAMETERS slot." (let ((header (or type (http:header-in* :content-type)))) (when (stringp header) (loop :for prefix :in +hunchentoot-pre-decoded-content-types+ :thereis (a:starts-with-subseq prefix header))))) (defvar *mimetype-parsers* (make-hash-table :test #'equal)) (defun lookup-body-parser (typestring &key errorp) (let ((type (first (serapeum:split-sequence #\; typestring)))) (multiple-value-bind (parser extant) (gethash type *mimetype-parsers*) (when errorp (unless extant (error "Body parser not found for mimetype ~s Try registering a parser with (REGISTER-BODY-PARSER ~s )" type type))) parser))) (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)) ;;; INSTANCE CLASS INITIALIZATION LOGIC (defun route-matching-regex (parts) "Joins route part strings into a route-matching regular expression." (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 matching regex." (cond ((slot-boundp class 'route-parts) (setf (slot-value class 'route) (route-matching-regex (route-parts class)))) (t (error ":ROUTE-PARTS must be supplied to the defintion of class ~a" (class-name class))))) (defun route-builder-parts (class) "Given a list whose route is /a/b/(y)/c/(z)/(w) with extractors for slots :Y, :Z, and :W, returns a list '(\"a\" \"b\" :Y \"c\" :Z \"/\" :W)" (assert (slot-boundp class 'route)) (loop :with build-parts := nil :with extractors := (copy-seq (route-extractors class)) :for part :in (ppcre:parse-string (route class)) :do (cond ((or (stringp part) (characterp 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 (~s) must be surrounded by parens. There must be exactly as many patterns as there are extractors." part))) :finally (return (nreverse build-parts)))) (defun construct-route-builder (class) (assert (slot-boundp class 'route)) (let ((build-parts (route-builder-parts class))) (setf (route-builder class) (lambda (kwargs) (format nil "~{~a~}" (loop :for part :in build-parts :when (keywordp part) :do (assert (getf kwargs part) (kwargs) "path to ~s needs ~s" (class-name class) part) :and :collect (getf kwargs part) :else :collect part)))))) (defun check-endpoint-class (class) "Signals an error if any slot values are malformed. Good for indicating that you've got a bonkers class option syntax" (assert (slot-boundp class 'route) (class) "ROUTE must be bound") (with-slots (route extractors method want-body-stream content-type) class (check-type route string "a regex STRING.") (check-type method http-method "an HTTP-METHOD keyword") (check-type want-body-stream boolean "a BOOLEAN") (check-type content-type (or null string) "a STRING mimetype") (loop :with initargs := (class-initargs class) :for ex :in extractors :when (symbolp ex) :do (assert (member ex initargs :test #'eq) (class) "Extractor ~s is not a valid initarg for ~a" ex (class-name class)) :else :do (assert (do> :when (listp ex) :when (= 2 (length ex)) (arg parser) :match= ex :when (member arg initargs :test #'eq) (and (symbolp parser) (fboundp parser))) (class) "Extactor ~s is not a valid extractor" ex)))) (defun process-extractors (class) "If extractors are set on CLASS, extract regex group matches. Return a PLIST whose keys are the extractor spec's keywords and values are the match string transformed by the extractor spec's parser. E.g. If ROUTE is ^/foo/([0-9]+)/([a-zA-Z0-9_]+)/(.+)$ And ROUTE-EXTRACTORS is ((:id #'parse-int) :name (:thingy #'parse-thingy)) And the HUNCHENTOOT:SCRIPT-NAME* is /foo/33/coolbeans/niftydifty Then process-extractors returns (:id 33 :name \"coolbeans\" :thingy #)" (do> extractors :when= (route-extractors class) path := (http:script-name*) route := (route class) (_i1 _i2 starts ends) := (ppcre:scan route path) (declare (ignore _i1 _i2)) (loop :for start :across starts :for end :across ends :for extractor :in extractors :for strval := (subseq path start end) :when (symbolp extractor) :collect extractor :and :collect strval :else :collect (first extractor) :and :collect (funcall (second extractor) strval)))) (defun extract-initargs (args alist &key (test #'string-equal)) ;; return a plist consisting of just those keys found in args who ;; have values in alist. If key is in args but not in alist, then ;; key will not be in the returned plist. (loop :for arg :in args :for pair := (assoc arg alist :test test) :when pair :collect arg :and :collect (cdr pair))) (defparameter +hunchentoot-methods-with-body+ '(:post :put :patch)) (defun body-expected-p (&optional (method (http:request-method*))) (member method +hunchentoot-methods-with-body+ :test #'eq)) (defun extract-mimetype (str) "Expects a string that looks like text/plain;encoding=utf8 where everything after the ; is optional. Returns just the mimetype before the ;." (a:if-let (pos (position #\; str)) (subseq str 0 pos) str)) (defun collect-body (class) "The body of the current request as an ALIST. If necessary, the body will be parsed using CLASS's BODY-PARSER." (when (body-expected-p) (or (and (pre-parsed-body-p) (http:post-parameters*)) (do> mimetype := (extract-mimetype (http:header-in* :content-type)) parser :when= (lookup-body-parser mimetype) post-data :when= (http:raw-post-data :external-format :utf8 :want-stream (want-body-stream class)) (handler-case (funcall parser post-data) (error (e) (protocol-error 'bad-body-error class :wrapped e :note "Error during the parsing of the body."))))))) (defun apply-slot-value-mappers (class initargs) (loop :for (arg value) :on initargs :by #'cddr :collect arg :collect (slot-value-mapper class arg value))) (defun instantiate-endpoint (class args) "This attempts to instantiate CLASS, filling slots found in ARGS by searching for their values in the hunchentoot:*request*. Potential initarg values are found with the following priority: 1. in path extractors 2. in query parameters 3. in the request body." (debug-print :collecting-initargs) (let* ((extracted-args (process-extractors class)) (params-args (extract-initargs args (http:get-parameters*))) (body-args (extract-initargs args (collect-body class))) (collected-args (apply-slot-value-mappers class (reduce #'merge-plists (list extracted-args params-args body-args))))) (debug-print :using-initargs collected-args) (apply #'make-instance class collected-args))) (defun build-handler (class) "Create a hunchentoot dispatch function that instantiates and handles a request for the supplied class. The returned handler is a thunk that sets the reply content type, authenticates, authoriizes, and handles the request, returning raw data to the client. " (let ((init-slots (class-initargs class)) (content-type (content-type class))) (lambda () (with-debug-extent () (debug-print (http:request-method*) (http:request-uri*) :dispatched-on (class-name class)) (check-request-compliance class) (setf (http:content-type*) content-type) (handle (instantiate-endpoint class init-slots)))))) (defun create-class-dispatcher (class) "Creates a function that dispatches a handler function if a request matches CLASS's ROUTE and METHOD slots." (let ((scanner (ppcre:create-scanner (route class))) (method (request-method class)) (handler (build-handler class))) (lambda (request) (and (string-equal method (http:request-method request)) (ppcre:scan scanner (http:script-name request)) handler)))) (defun update-dispatch-function (class) "If CLASS has a cached dispatch function, removes it from hunchentoot's *DISPATCH-TABLE* before building a new one " (when (slot-boundp class 'dispatch-function) (setf http:*dispatch-table* (delete (dispatch-function class) http:*dispatch-table*))) (setf (dispatch-function class) (create-class-dispatcher class)) (push (dispatch-function class) http:*dispatch-table*)) (defun endpoint-class-post-processing (class) (mop:ensure-finalized class) (resolve-route-spec class) (construct-route-builder class) (check-endpoint-class class) (update-dispatch-function class) (register-endpoint-class class)) (defmethod initialize-instance :after ((class endpoint) &key) (endpoint-class-post-processing class)) (defmethod reinitialize-instance :after ((class endpoint) &key) (endpoint-class-post-processing class)) ;;; TOOLS (defun route-to (class &rest kwargs) "Build a route to the endpoint CLASS using keyword argument constructors KWARGS for that class. CLASS must be either a symbol or a class instance, and the named class must (obviously) be a subclass of ENDPOINT." (funcall (route-builder (if (symbolp class) (find-class class) class)) kwargs))