initial commit

5 files changed, 497 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))
+
+
+
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..c60d03b
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,8 @@
+;;;; package.lisp
+
+(defpackage #:weekend
+  (:use #:cl #:flatbind)
+  (:local-nicknames
+   (#:http #:hunchentoot)
+   (#:a #:alexandria-2)
+   (#:mop #:closer-mop)))
diff --git a/src/protocol.lisp b/src/protocol.lisp
new file mode 100644
index 0000000..19a4791
--- /dev/null
+++ b/src/protocol.lisp
@@ -0,0 +1,144 @@
+(in-package #:weekend)
+
+;;; CONDITIONS
+
+(defvar *debugging* nil
+  "If T, the debugger will be evoked.")
+
+(define-condition protocol-error (error)
+  ((raw-request
+    :reader raw-request
+    :initarg :raw-request
+    :documentation "The server backend's request object, if available")
+   (class
+    :reader endpoint-class
+    :initarg :class
+    :documentation "The class registered to handle the raw-request.")
+   (note
+    :reader note
+    :initform nil
+    :initarg :note
+    :type (or null string))
+   (status-code
+    :reader status-code
+    :initform nil
+    :initarg :status-code
+    :type (or nil (integer 100 599))))
+  (:documentation "Conditions signalled during the request handling protocol."))
+
+(define-condition cannot-authenticate (protocol-error) ()
+  (:default-initargs :status-code 401)
+  (:documentation "Signalled when a endpoint's AUTHENTICATE method returns NIL,
+indicating that the user's identity is required but cannot be determined."))
+
+(define-condition not-authorized (protocol-error) ()
+  (:default-initargs :status-code 403)
+  (:documentation "Signalled when an endpoint's AUTHORIZE method returns NIL, indiating
+that the request has insufficient permissions to evoke the endpoint handler. "))
+
+(define-condition bad-body-error (protocol-error)
+  ((wrapped
+    :reader wrapped
+    :initarg :error
+    :documentation "A root error that may have caused this error to be signalled."))
+  (:default-initargs :status-code 400)
+  (:documentation "Signalled when the body of a request cannot be deserialized."))
+
+(define-condition slot-required (protocol-error)
+  ((mising-slot
+    :reader missing-slot
+    :initarg :slot))
+  (:default-initargs :status-code 400)
+  (:documentation "Signalled whenever a required slot is missing from a endpoint
+   instance object."))
+
+(define-condition not-found (protocol-error)
+  (:default-initargs :status-code 404))
+
+(defgeneric protocol-error-result (err)
+  (:documentation "The content and mimetype to returned to the client having encountered
+    an error.")
+  (:method ((err protocol-error)) (values nil nil)))
+
+(defun abort-on-error (err)
+  "Assign a return code based on the type of error encountered and
+   immediately reply."
+  (setf (http:return-code*) (status-code err))
+  (multiple-value-bind (content type) (protocol-error-result err) 
+    (cond ((and content type)
+           (setf (http:content-type*) type)
+           (http:abort-request-handler content))
+          (t
+           (http:abort-request-handler)))))
+
+(defvar *debugging* nil
+  "If T, conditions signalled during request handling will invoke the
+  debugger.")
+
+(defmethod http:acceptor-dispatch-request :around ((acceptor http:acceptor) request)
+  (handler-case (call-next-method)
+
+    (protocol-error (err)
+      (if *debugging*
+          (invoke-debugger err)
+          (abort-on-error err)))
+
+    (error (err)
+      (if *debugging*
+          (invoke-debugger err)
+          (http:abort-request-handler)))))
+
+(defun protocol-error (error-class req &rest kwargs)
+  (apply #'error
+         error-class
+         :raw-request http:*request*
+         :class (class-of req)
+         kwargs))
+
+(defun not-found (req)
+  (protocol-error 'not-found req))
+
+;;; HANDLER PROTOCOL
+
+(defgeneric authenticate (endpoint)
+  (:documentation "Returns a boolean. Any protected endpoint should implement
+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))
+
+(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))
+
+(defgeneric handle (endpoint)
+  (:documentation "The beef of the endpoint handling protocol.
+
+
+                           _(__)_        V
+                          '-e e -'__,--.__)
+                           (o_o)        ) 
+                              \. /___.  |
+                              ||| _)/_)/
+                             //_(/_(/_( 
+
+By the time this has been called, both AUTHENTICATE and AUTHORIZE have
+been called. This method can be defined with the assumption that any
+work done by AUTHORIZE and AUTHENTICATE has been accomplished
+successfully.
+
+This method should return data to be sent back to the client and
+MUST be implemented for every endpoint class.")
+  (:method :before ((endpoint t))
+    ;; The default before method checks that the endpoint is
+    ;; authenticated, authorized, default, each of these is T.
+    (unless (authenticate endpoint)
+      (protocol-error 'cannot-authenticate endpoint))
+    (unless (authorize endpoint)
+      (protocol-error 'not-authorized endpoint))))
+
+
+
+
diff --git a/src/server.lisp b/src/server.lisp
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/src/server.lisp
diff --git a/weekend.asd b/weekend.asd
new file mode 100644
index 0000000..6e7f833
--- /dev/null
+++ b/weekend.asd
@@ -0,0 +1,15 @@
+;;;; weekend.asd
+
+(asdf:defsystem #:weekend
+  :description "A Metaclass and Protocol for Defining Webservers."
+  :author "colin <colin@cicadas.surf>"
+  :license  "AGPLv3.0"
+  :version "0.0.1"
+  :depends-on (#:hunchentoot #:closer-mop #:alexandria #:flatbind)
+  :pathname "src/"
+  :serial t
+  :components ((:file "package")
+               (:file "protocol")
+               (:file "endpoint")
+ ;              (:file "server")
+               ))