From 19792479f89c763b6267399f3a66db6cbe8f10f3 Mon Sep 17 00:00:00 2001 From: colin Date: Sat, 4 May 2024 11:05:12 -0700 Subject: initial commit --- src/endpoint.lisp | 330 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/package.lisp | 8 ++ src/protocol.lisp | 144 ++++++++++++++++++++++++ src/server.lisp | 0 weekend.asd | 15 +++ 5 files changed, 497 insertions(+) create mode 100644 src/endpoint.lisp create mode 100644 src/package.lisp create mode 100644 src/protocol.lisp create mode 100644 src/server.lisp create mode 100644 weekend.asd 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 ) +" + 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 #)" + (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 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 " + :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") + )) -- cgit v1.2.3