aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/endpoint.lisp330
-rw-r--r--src/package.lisp8
-rw-r--r--src/protocol.lisp144
-rw-r--r--src/server.lisp0
-rw-r--r--weekend.asd15
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")
+ ))