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.")
   (body-type
    :reader body-type
    :initarg :body-type
    :initform nil
    :type (or null string)
    :documentation "The mimetype of the body for requests that have them.")
   (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 "application/json"
    :type 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)


;;; 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 (type)
  (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)
  ((type :initarg :mimetype :type string)
   (class :initarg :class :type symbol))
  (:report
   (lambda (c s)
     (with-slots (type class) c
       (format s
               " 
Class ~a was defined with body type ~a, but no parser has been
registered for that body type.

Check your spelling or call
    (REGEISTER-BODY-PARSER ~s  <your function>)
"
               class type type)))))


;;; INSTANCE CLASS INITIALIZATION LOGIC

(defun route-matching-regex (parts)
  "Joins route part strings into a route-matching regular expression."
  (format nil "^/~{~a~^/~}$" parts))

(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 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. 

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 body-type  want-body-stream content-type)
      class
    (check-type route string "a regex STRING.")
    (check-type method http-method "an HTTP-METHOD keyword")
    (when body-type
      (unless (or (pre-parsed-body-p body-type)
                  (lookup-body-parser body-type))
        (warn 'unregistered-body-type :type body-type :class (class-name class))))
    (check-type want-body-stream boolean "a BOOLEAN")
    (check-type content-type 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 ()
  (member (http:request-method*) +hunchentoot-methods-with-body+))

(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>
          parser :when= (lookup-body-parser (body-type class))
          post-data :when= (http:raw-post-data
                            :external-format :utf8
                            :want-stream (want-body-stream class))
          (funcall parser post-data)))))


(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
           (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 ()
      (setf (http:content-type*) (concatenate 'string content-type "; charset=utf-8"))
      (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*))


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