From c201a822f264041a1b9169824c0f9acbfae9cf6e Mon Sep 17 00:00:00 2001 From: colin Date: Sat, 18 Nov 2023 15:25:51 -0800 Subject: version 1.0 --- lazybones.lisp | 573 --------------------------------------------------------- 1 file changed, 573 deletions(-) delete mode 100644 lazybones.lisp (limited to 'lazybones.lisp') diff --git a/lazybones.lisp b/lazybones.lisp deleted file mode 100644 index e9adc03..0000000 --- a/lazybones.lisp +++ /dev/null @@ -1,573 +0,0 @@ -;; Copyright (C) 2022 Colin Okay - -;; 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 . - - -;;;; 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))) -- cgit v1.2.3