diff options
Diffstat (limited to 'src/lazybones.lisp')
| -rw-r--r-- | src/lazybones.lisp | 573 |
1 files changed, 573 insertions, 0 deletions
diff --git a/src/lazybones.lisp b/src/lazybones.lisp new file mode 100644 index 0000000..97c7d40 --- /dev/null +++ b/src/lazybones.lisp @@ -0,0 +1,573 @@ +;; Copyright (C) 2022 colin@cicadas.surf + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU Affero General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU Affero General Public License for more details. + +;; You should have received a copy of the GNU Affero General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + + +;;;; lazybones.lisp + +(in-package #:lazybones) + +;;; DYNAMIC VARIABLES + +(defvar *request* nil + "Dynamic Variable holding the current request object. Dynamically + bound and available to each handler. The exact object bound to + *request* varies according to the current backend.") + +(defvar *response* nil + "Dynamic variable holding the current response object. Dynamically + bound and available to each handler. The exact object bound + *response* varies according to the current backend. ") + +(defvar *app* nil + "Dynamic variable holding the an APP instance. Dynamically bound by + RUN-ENDPOINT so that it is available if needed in request handlers.") + +(defvar *allowed-keywords* nil + "Dynamic variable. Can be bound by handler functions to control which +keywords are read in while parsing request bodies. Should be used +when keyword bombing is a concern.") + +(defvar *debugging* nil) + +;;; HTTP-ERROR CONDITION + +(define-condition http-error (condition) + ((code :initarg :code) + (content :initarg :content))) + + +;;; APP NAMESPACE + +(lisp-namespace:define-namespace lazybones) + +;;; LAZYBONES CLASSES + +(defun default-app-name () + (intern (package-name *package*) *package*)) + +(defclass app () + ((name + :reader app-name + :initarg :name + :initform (error "Appname is required") + :type symbol) + (title + :accessor app-title + :initarg :title + :initform "" + :type string + :documentation "A string title") + (description + :accessor app-description + :initarg :description + :initform "" + :type string + :documentation "A string describing the app") + (version + :accessor app-version + :initarg :vsn :initarg :version + :initform "0.0.1" + :type string) + (prefix + :accessor app-prefix + :initarg :prefix + :initform "" + :documentation "Effectively prepended to all endpoints for the + purposes of request handling. E.g. \"/api\" is a good prefix." ) + (definitions + :accessor app-definitions + :initform (make-hash-table :test 'equal) + :documentation "Definitions are used in the generation of + documentation. They can be linked to from docstrings of + endpoints. Used to provide additional documentation for, e.g., + JSON object specifications for post bodies or return types.") + (authorizer + :accessor request-authorizer + :initarg :auth + :initform nil + :documentation "A function of zero arguments that uses the request + API functions in LAZYBONES.BACKEND to determine whether or not the + current request is authorized. This is the default authorizer, and + is evoked when an ENDPOINT's AUTH slot is T. Endpoints may + override this behavor by supplying a function in place of T. A + value of NIL means that there is no default authorizer.") + (default-content-type + :accessor default-content-type + :initarg :content-type + :initform "text/html" + :documentation "Default content type sent back to clients.") + (endpoints + :accessor app-endpoints + :initform nil) + (dict + :accessor app-dict + :initform (make-hash-table :test 'equal) + :documentation "A hash table for storing arbitrary informatrion on this application."))) + +(defun expand-provision-app-option (app option value) + (list 'setf + (ecase option + ((:desc :description) `(lazybones::app-description ,app)) + (:prefix `(lazybones::app-prefix ,app)) + (:title `(lazybones::app-title ,app)) + (:version `(lazybones::app-version ,app)) + (:content-type `(lazybones::default-content-type ,app)) + ((:auth :authorizer) `(lazybones::request-authorizer ,app))) + value)) + +(defmacro provision-app ((&optional name) &body body) + (assert (evenp (length body)) () "Odd number of forms in PROVISION-APP BODY.") + (let* ((the-app + (gensym)) + (provisioning + (loop for (k v . more) on body by #'cddr + collect (expand-provision-app-option the-app k v)))) + `(let ((,the-app + (if (null ',name) + (or (app) (make-instance 'app :name (default-app-name))) + (or (app ',name) (make-instance 'app :name ',name))))) + ,@provisioning))) + +(defmethod initialize-instance :before ((app app) &key name &allow-other-keys) + (when (app name) + (error "an app named ~s already exists" name))) + +(defmethod initialize-instance :after ((app app) &key) + (setf (symbol-lazybones (app-name app)) app)) + +(defun app (&optional name) + "Get the APP instance named by the symbol NAME. If NAME is not +supplied, get the default app. Every package has at most one default +app, named with the package name. If no app can be found, return NIL" + (symbol-lazybones (or name (default-app-name)) nil)) + +(defun dictionary (key &optional name) + "Get value from the application dict" + (gethash key (app-dict (app name)))) + +(defun (setf dictionary) (new key &optional name) + "Set a value in the application dict." + (setf (gethash key (app-dict (app name))) new)) + +(defclass endpoint () + ((method + :reader endpoint-method + :initarg :method + :initform :get) + (route + :reader endpoint-route + :initarg :route + :initform (error "endpoint route required")) + (params + :reader endpoint-params + :initarg :params + :initform nil + :documentation "A list of (SYMBOL-NAME FUNCTION-SYMBOL), + documenting the query parameters this endpoint expects. Used for + generating both documentation and client functions.") + (content-type + :reader endpoint-content-type + :initarg :content-type + :initform nil) + (authorizer + :reader request-authorizer + :initarg :auth + :initform nil + :documentation "A function of zero arguments used to authorize the + request currently bound to *REQUEST*. Returns non-nil if + authorized, and NIL if not.") + (dispatch-pattern + :reader endpoint-dispatch-pattern + :initarg :pattern) + (handler-function + :reader endpoint-request-handler + :initarg :function) + (endpoint-documentation + :reader endpoint-documentation + :initarg :doc + :initform ""))) + +(defun routekey-term-match-p (pattern-term routekey-term) + "Internal helper function. Returns T if both arguments are strings +and they compare with STRING-EQUAL. Otherwise, PATTERN-TERM is +assumed to be a route variable representation, in which case T is +returned, indicating that the variable should bind to anything." + (if (stringp pattern-term) + (string-equal pattern-term routekey-term) + t)) + +(defun matches-routekey-p (pattern key) + "PATTERN is a list, each member of which is a string or a variable +representation. PATTERN will have been generated by +PARSE-ROUTE-STRING-TEMPLATE. + +If there are no variables in PATTERN, MATCHES-ROUTEKEY-P returns T +or NIL. + +If there are variables in the pattern, MATCHES-ROUTEKEY-P returns a +list of values, in the case of success, or NIL in the case of failure." + (when (= (length pattern) (length key)) + (loop for pterm in pattern + for rterm in key + for matchp = (routekey-term-match-p pterm rterm) + unless matchp + return nil + when (listp pterm) ; looks like (var) or (var value-parser) + collect (if (second pterm) + (funcall (second pterm) rterm) ; parse value from rterm if we can + rterm) ; otherwise use rterm string + into arguments + finally (return (or arguments t))))) + +(defun strip-app-prefix (app path) + (multiple-value-bind (success suffix) (a:starts-with-subseq (app-prefix app) path :return-suffix t) + (unless success (error "~a is not prefixed by ~a" path (app-prefix app))) + suffix)) + +(defun find-endpoint (app &optional (request *request*)) + (find-endpoint-matching-key + app + (request-method request) + (url-path->request-routekey (strip-app-prefix app (request-path request))))) + +(defun method-match-for-dispatch-p (req-method ep-method) + "Either the arguments compare EQ or the first is :HEAD and the second is :GET." + (or (eq req-method ep-method) + (and (eq :head req-method) (eq :get ep-method)))) + +(defun find-endpoint-matching-key (app method key) + "Returns a list. NIL represents failure to find match. + +Otherwise the result is (ENDPOINT . ARGS) where ENDPOINT is an +endpoint instanceq and ARGS is a list of arguments to pass to +ENDPOINT's handler function." + (loop for endpoint in (app-endpoints app) + for match = (and (method-match-for-dispatch-p method (endpoint-method endpoint)) + (matches-routekey-p (endpoint-dispatch-pattern endpoint) key)) + when match + return (cons endpoint (when (listp match) match)))) + + +(defun patterns-match-p (p1 p2) + (and (eql (length p1) (length p2)) + (every 'routekey-term-match-p p1 p2))) + +(defun find-endpoint-matching-pattern (app method pattern) + (loop for ep in (app-endpoints app) + when (and (eql method (endpoint-method ep)) + (patterns-match-p pattern (endpoint-dispatch-pattern ep))) + return ep)) + +(defun unregister-endpoint (app method dispatch-pattern) + (a:when-let (extant-ep (find-endpoint-matching-pattern app method dispatch-pattern)) + (setf (app-endpoints app) (delete extant-ep (app-endpoints app))))) + +(defun register-endpoint (app ep) + (unregister-endpoint app (endpoint-method ep) (endpoint-dispatch-pattern ep)) + (push ep (app-endpoints app))) + +(defparameter +http-methods+ + (list :get :head :put :post :delete :patch)) + +(defun url-path->request-routekey (path) + "A routekey is used to match urls to endpoints that handle them." + (str:split #\/ path)) + +(defun parse-route-string-template (template) + "Routes are of the form + +/foo/bar/:variable:/blah + +/foo/bar/:var parse-integer:/blah + +On success returns things like: + +(\"foo\" \"bar\" (VARIABLE) \"blah\") +(\"foo\" \"bar\" (VAR PARSE-INTEGER) \"blah\") + +Returns NIL on failure" + (cond ((equal "" template) nil) + (t + (when (search "//" template) + (warn "The proposed route ~s contains a double forward-slash (//), is this intended?" + template)) + (unless (eql #\/ (elt template 0)) + (error "The proposed route ~s does not begin with a forward-slash, is this intended?" + template)) + (loop for field in (str:split #\/ template) + for var? = (parse-route-variable-string field) + when var? + collect var? + else + collect (string-downcase field))))) + +(defun parse-route-variable-string (string) + "A route variable string looks like :foo: or :foo bar: + +In the case of a successful parse, a list of one or two symbols is +returned. These symbosl are created using read-from-string, which +allows for these symbols' packages to be specified if desired. + +Returns NIL on failure." + (when (and (a:starts-with-subseq ":" string) + (a:ends-with-subseq ":" string)) + (destructuring-bind + (var-name . decoder?) + (re:split " +" + (string-trim " " + (subseq string 1 (- (length string) 1)))) + (if decoder? + (list (string-upcase var-name) (read-from-string (first decoder?))) + (list (string-upcase var-name)))))) + +(defun route-variables (pattern) + (loop for term in pattern + when (listp term) + collect (first term))) + + +(defun run-endpoint (endpoint args request response app) + "Bind dynamic variables *request* *response* and *app* before +applying HANDLER-FUNCTION slot of ENDPOINT to the ARGS list." + (let ((*request* request) + (*response* response) + (*app* app)) + (setf (response-code) 200) + (if (request-authorized-p endpoint) + (http-respond (apply (endpoint-request-handler endpoint) args)) + (http-err 403)))) + +(defun request-authorized-p (endpoint) + "Attempts to authorize an endpoint. + +If the endpoint's request-authorizer is NIL, then the endpoint doesn't +require authorization, and T is returned. + +If the endpoint's request-authorizer is a function, call it. + +If the endpoint's request-authorizer is T, then the app's default +authorizer is used. + +Hence, if the endpoint authorizer is T and the app doesn't have an +authorizer, then, the endpoint wants to be authorized but there isn't +any way to do it, hence NIL is returned." + (a:if-let (auth (request-authorizer endpoint)) + (if (or (functionp auth) + (and (symbolp auth) (fboundp auth))) + (funcall auth) + (when (request-authorizer *app*) ; perhaps this should be an if, and + (funcall (request-authorizer *app*)))) + t)) + +;;; ENDPOINT DEFINITION + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun endpoint-function-name-helper (method route) + (string-upcase + (format nil "~a-~{~a~^-~}" + (symbol-name method) + (mapcar + (lambda (x) (if (stringp x) x (car x))) + (cdr (parse-route-string-template route))))))) + +(defmacro defendpoint + (appname method route + query-params + (&key + (auth nil) + content-type) + &body body) + "Defines and installs an ENDPOINT instance to the APP instance +indicated by APPNAME, first checking an APP called APPNAME exits, +making a new one if not." + (assert (member method +http-methods+) () + "~a is not a valid http method keyword" + method) + (a:with-gensyms (the-app auth-method) + (let* ((dispatch-pattern + (parse-route-string-template route)) + (endpoint-name + (intern (endpoint-function-name-helper method route))) + (lambda-list + (mapcar 'intern (route-variables dispatch-pattern))) + (documentation + (when (stringp (first body)) (first body))) + (body-without-docstring + (if (stringp (first body)) (rest body) body)) + (real-body + (if query-params + `((lazybones:map-parameters ,query-params ,@body-without-docstring)) + body-without-docstring))) + `(let* ((,the-app + (or (app ',appname) (make-instance 'lazybones:app :name ',appname))) + (,auth-method + ,auth)) + (defun ,endpoint-name ,lambda-list + (declare (ignorable ,@lambda-list)) + (setf (lazybones:response-header :content-type) + (or ,content-type (lazybones::default-content-type ,the-app))) + ,@real-body) + + (register-endpoint + ,the-app + (make-instance + 'lazybones:endpoint + :method ,method + :route ,route + :params ',query-params + :content-type ,content-type + :pattern ',dispatch-pattern + :doc ,documentation + :auth ,auth-method + :function ',endpoint-name)))))) + +(defmacro defendpoint* (method route params options &rest body) + "Like DEFENDPOINT but uses the current package name as the app name." + `(defendpoint ,(default-app-name) ,method ,route ,params ,options ,@body)) + +;;; ENDPOINT HANDLING UTILITIES + +(defun http-err (code &optional content) + "Singals an HTTP-ERROR with code and content." + (signal 'http-error :content content :code code)) + + +;;; MANAGING DEFINITIONS + +(defun set-definition (name item-id definition-text &optional (app (lazybones:app))) + "Name is a string" + (setf (gethash name (app-definitions app)) (cons item-id definition-text))) + +(defun drop-definition (name &optional (app (lazybones:app))) + "Remove definition keyed by LINK-TARGET from APP." + (remhash name (app-definitions app))) + +(defun names-equal-p (s1 s2) + (or (equalp s1 s2) + (and (symbolp s1) (equalp (symbol-name s1) s2)) + (and (symbolp s2) (equalp s1 (symbol-name s2))) + (and (symbolp s1) (symbolp s2) + (string-equal (symbol-name s1) (symbol-name s2))))) + +(defun getplist (indicator plist &key (test 'names-equal-p ) key) + (let ((indicator (if key (funcall key indicator) indicator))) + (loop for (k0 v . more) on plist by #'cddr + for k = (if key (funcall key k0) k0) + when (funcall test indicator k) + return (values v t) + finally (return (values nil least-negative-long-float ))))) + +(defun class-docs (class-name) + (closer-mop:ensure-finalized (find-class class-name)) + (loop for plist in (trivial-documentation:symbol-definitions class-name) + when (eql :class (getf plist :kind)) + return (list (getf plist :documentation) + (getf plist :slots)))) + +(defun add-class-to-definitions (app class-name &rest slot-names) + "Generates a definition entry from class and slot documentation +CLASS-NAME should be a symbol, and SLOT-NAMES symbols." + (destructuring-bind (documentation slots) (class-docs class-name) + (set-definition (string-downcase (symbol-name class-name)) + (string-downcase (format nil "#~a" class-name)) + (with-output-to-string (*standard-output*) + (princ documentation) + (princ #\newline) (princ #\newline) + (princ "**Slots:**") (princ #\newline) + (dolist (sn slot-names) + (a:when-let (slot-doc (getplist sn slots)) + (princ "- ") (princ sn) (princ ": ") + (princ slot-doc) + (princ #\newline))) + (princ #\newline)) + app))) + +(defparameter +extension->mimetype+ + '(("aac" "audio/aac") + ("abw" "application/x-abiword") + ("arc" "application/x-freearc") + ("avif" "image/avif") + ("avi" "video/x-msvideo") + ("azw" "application/vnd.amazon.ebook") + ("bin" "application/octet-stream") + ("bmp" "image/bmp") + ("bz" "application/x-bzip") + ("bz2" "application/x-bzip2") + ("cda" "application/x-cdf") + ("csh" "application/x-csh") + ("css" "text/css") + ("csv" "text/csv") + ("doc" "application/msword") + ("docx" "application/vnd.openxmlformats-officedocument.wordprocessingml.document") + ("eot" "application/vnd.ms-fontobject") + ("epub" "application/epub+zip") + ("gz" "application/gzip") + ("gif" "image/gif") + ("htm" "text/html") + ("ico" "image/vnd.microsoft.icon") + ("ics" "text/calendar") + ("jar" "application/java-archive") + ("jpeg" "image/jpeg") + ("js" "text/javascript") + ("json" "application/json") + ("jsonld" "application/ld+json") + ("mid" "audio/x-midi") + ("mjs" "text/javascript") + ("mp3" "audio/mpeg") + ("mp4" "video/mp4") + ("mpeg" "video/mpeg") + ("mpkg" "application/vnd.apple.installer+xml") + ("odp" "application/vnd.oasis.opendocument.presentation") + ("ods" "application/vnd.oasis.opendocument.spreadsheet") + ("odt" "application/vnd.oasis.opendocument.text") + ("oga" "audio/ogg") + ("ogv" "video/ogg") + ("ogx" "application/ogg") + ("opus" "audio/opus") + ("otf" "font/otf") + ("png" "image/png") + ("pdf" "application/pdf") + ("php" "application/x-httpd-php") + ("ppt" "application/vnd.ms-powerpoint") + ("pptx" "application/vnd.openxmlformats-officedocument.presentationml.presentation") + ("rar" "application/vnd.rar") + ("rtf" "application/rtf") + ("sh" "application/x-sh") + ("svg" "image/svg+xml") + ("tar" "application/x-tar") + ("tif" "image/tiff") + ("ts" "video/mp2t") + ("ttf" "font/ttf") + ("txt" "text/plain") + ("vsd" "application/vnd.visio") + ("wav" "audio/wav") + ("weba" "audio/webm") + ("webm" "video/webm") + ("webp" "image/webp") + ("woff" "font/woff") + ("woff2" "font/woff2") + ("xhtml" "application/xhtml+xml") + ("xls" "application/vnd.ms-excel") + ("xlsx" "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") + ("xml" "application/xml") + ("xul" "application/vnd.mozilla.xul+xml") + ("zip" "application/zip") + ("3gp" "audio/3gpp") + ("3g2" "audio/3gpp2") + ("7z" "application/x-7z-compressed"))) + + +(defun ext->mimetype (ext) + (second (assoc ext +extension->mimetype+ :test #'string-equal))) |