path: root/src/endpoint.lisp

(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 <yourparser>)"
                 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 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. 

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 #<a thingy I guess>)"
  (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."
  (let ((extracted-args
          (process-extractors class))
        (params-args
          (extract-initargs args (http:get-parameters*)))
        (body-args
          (extract-initargs args (collect-body class)))) 
    (apply #'make-instance class
           (apply-slot-value-mappers
            class
            (reduce #'merge-plists
                    (list extracted-args params-args body-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 ()
      (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))