;; 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 . ;;;; 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) (body-variables :reader endpoint-body-variables :initarg :body-variables :initform nil :documentation "A list of fields that should appear in the body of a request that has a body. Completely optional, but used to build client functions.") (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 endpoint-route-variables (endpoint) (route-variables (endpoint-dispatch-pattern endpoint))) (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) (body-vars 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 body-vars `((let-body ,body-vars ,@body-without-docstring)) body-without-docstring))) (when query-params (setf real-body `((map-parameters ,query-params ,@real-body)))) `(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 :body-variables ',body-vars :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)) (defun http-redirect (location) "Set the lazybones response header and response code for redirecting to LOCATION. This procedure will error if lazybones:*response* is not currently bound." (setf (response-header :location) location (response-code) "303")) ;;; 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)))