1 files changed, 330 insertions, 0 deletions
diff --git a/src/endpoint.lisp b/src/endpoint.lisp
new file mode 100644
index 0000000..9ec1937
--- /dev/null
+++ b/src/endpoint.lisp
@@ -0,0 +1,330 @@
+(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))
+
+;;; 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.")
+   (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)
+  (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
+    ((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))
+     (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"
+      (class-name class)))))
+
+(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)
+  (check-endpoint-class class)
+  (update-dispatch-function class))
+
+(defmethod reinitialize-instance :after ((class endpoint) &key)
+  (mop:ensure-finalized class)
+  (resolve-route-spec class)
+  (check-endpoint-class class)
+  (update-dispatch-function class))
+
+
+