diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/backend/hunchentoot.lisp | 323 | ||||
| -rw-r--r-- | src/client/dexador.lisp | 205 | ||||
| -rw-r--r-- | src/client/parenscript.lisp | 3 | ||||
| -rw-r--r-- | src/documentation/markdown.lisp | 116 | ||||
| -rw-r--r-- | src/lazybones.lisp | 573 | ||||
| -rw-r--r-- | src/macros.lisp | 49 | ||||
| -rw-r--r-- | src/package.lisp | 90 |
7 files changed, 1359 insertions, 0 deletions
diff --git a/src/backend/hunchentoot.lisp b/src/backend/hunchentoot.lisp new file mode 100644 index 0000000..acb15cb --- /dev/null +++ b/src/backend/hunchentoot.lisp @@ -0,0 +1,323 @@ +;; 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/>. + +(defpackage #:lazybones-backend.hunchentoot + (:use #:cl #:lazybones-backend) + (:local-nicknames (#:h #:hunchentoot) + (#:lzb #:lazybones) + (#:a #:alexandria))) + +(in-package :lazybones-backend.hunchentoot) + +;;; Hunchentoot Acceptor Subclass + +(defvar %server% nil + "unexported defvar holding the lazybones-acceptor instance.") + +(defclass lazybones-acceptor (h:acceptor) + ((installed-apps + :accessor acceptor-apps + :initform nil + :documentation "Instances of LAZYBONES:APP installed to this + acceptor. APPs are, among other things, collections of ENDPOINT + instances. The acceptor instance uses them to dispatch handlers + on requests.") + (canned-responses + :accessor canned-responses + :initarg :canned-responses + :initform nil + :documentation "an alist of (CODE CONTENT-FUNCTION CONTENT-TYPE)") + (domain + :accessor domain + :initarg :domain + :initform nil + :documentation "A specific domain to associate with this server + for the purposes of cookie handling. NIL by default, which is + fine.")) + (:default-initargs + :address "127.0.0.1")) + +(defvar %request-body-cache% nil + "Internal use. Dynamically bound per request. Caches the request + body after the first call to REQUEST-BODY so that subsequent calls + return the same thing, even if they've already been read off the + stream.") + +(defmethod h:acceptor-dispatch-request ((%server% lazybones-acceptor) request) + (let* ((%request-body-cache% nil) + (route + (request-path request)) + (apps + (remove-if-not (lambda (app) (a:starts-with-subseq (lzb::app-prefix app) route)) + (acceptor-apps %server%)))) + (handler-case + (loop for app in apps + for (endpoint . args) = (lzb::find-endpoint app request) + when endpoint + return (lzb::run-endpoint endpoint args request h:*reply* app) + ;; if no endpoint was found, call next method. + finally (let ((lzb:*request* request) + (lzb:*response* h:*reply*)) + (lzb:http-err 404))) + (lzb::http-error (http-error) + (let ((lzb:*request* request) + (lzb:*response* h:*reply*)) + (with-slots (lzb::code lzb::content) http-error + (http-respond lzb::content lzb::code)))) + (error (e) + (declare (ignorable e)) + (let ((lzb:*request* request) + (lzb:*response* h:*reply*)) + (if lzb:*debugging* + (invoke-debugger e) + (http-respond nil 500))))))) + +;;; SERVER FUNCTIONS + +(defun create-server (&key (port 8888) (address "127.0.0.1") (domain "localhost")) + "Creates an opaque server on port PORT, and returns it. Servers are +backend specific, but each may be passed in to INSTALL-APP, +UNINSTALL-APP, START-SERVER, and STOP-SERVER." + (let ((server (make-instance 'lazybones-acceptor + :port port + :address address + :domain domain))) + (set-canned-response server 404 "Not Found" "text/plain") + (set-canned-response server 500 "Server Error" "text/plain") + server)) + +(defun start-server (server) + (h:start server)) + +(defun stop-server (server) + (h:stop server)) + +(defun install-app (server app) + "Installs a LAZYBONES:APP instance to SERVER, first checking that +the app exists. If app is already installed, does nothing." + (a:if-let (app (and app (if (symbolp app) (lzb:app app) app))) + (pushnew app (acceptor-apps server) :key 'lzb::app-name) + (error () "No app to install."))) + +(defun uninstall-app (server app) + (setf (acceptor-apps server) + (delete (if (symbolp app) (lzb:app app) app) (acceptor-apps server)))) + +(defun canned-response (server code) + "If a canned response is installed to the server for the HTTP +response code CODE, return it as a list (RESPONSE-SOURCE CONTENT-TYPE). + +RESPONSE-SOURCE is either a function designator for a function taking +zero arguments that is expected to return data that matches the +CONTENT-TYPE. Such a function can always make use of *REQUEST*. + +RESPONSE-SOURCE can also be a pathname to a file to serve." + (cdr (assoc code (canned-responses server)))) + +(defun set-canned-response (server code content-source content-type) + "Set a new canned response for the code CODE." + (push (list code content-source content-type) (canned-responses server))) + +(defun server-domain (&optional (server %server%)) + (domain server)) + +;;; HTTP REQUEST FUNCTIONS + +(defun request-path (&optional (request lzb:*request* )) + "Returns the PATH part of the REQUEST URL. + +See Also: https://en.wikipedia.org/wiki/URL#Syntax." + (h:script-name request)) + +(defun request-host (&optional (request lzb:*request*)) + "Returns the HOST part of the REQUEST URL. + +See Also: https://en.wikipedia.org/wiki/URL#Syntax" + (h:host request)) + +(defun request-url (&optional (request lzb:*request*)) + "Returns the full url of REQUST" + (h:request-uri* request)) + +(defun request-port (&optional (request lzb:*request*)) + "The port associated with REQUEST." + (h:local-port* request)) + +(defun request-query-string (&optional (request lzb:*request*)) + "Returns the full query string of the URL associated with REQUEST + +See Also: https://en.wikipedia.org/wiki/URL#Syntax" + (h:query-string request)) + +(defun request-parameter (name &optional (request lzb:*request*)) + "Returns the the value of the query parameter named NAME, or NIL + if there there is none." + (h:get-parameter name request)) + +(defun request-parameters (&optional (request lzb:*request*)) + "Returns an alist of parameters associated with REQUEST. Each +member of the list looks like (NAME . VALUE) where both are strings." + (h:get-parameters request)) + +(defun request-headers (&optional (request lzb:*request*)) + "Returns an alist of headers associated with REQUEST. Each member of +the list looks like (HEADER-NAME . VALUE) where HEADER-NAME is a +keyword or a string and VALUE is a string." + (h:headers-in request)) + +(defun request-header (header-name &optional (request lzb:*request*)) + "Returns the string value of the REQUEST header named HEADER-NAME. +HEADER-NAME can be a keyword or a string." + (h:header-in header-name request)) + +(defun request-cookie (name &optional (request lzb:*request*)) + "Returns the cookie with NAME sent with the REQUEST" + (h:cookie-in name request)) + +(defun request-method (&optional (request lzb:*request*)) + "Returns a keyword representing the http method of the request." + (h:request-method request)) + + +(defparameter +hunchentoot-pre-decoded-content-types+ + '("multipart/form-data" "application/x-www-form-urlencoded")) + +(defun pre-decoded-body-p (request) + (let ((header (request-header :content-type request))) + (when (stringp header) + (loop for prefix in +hunchentoot-pre-decoded-content-types+ + thereis (a:starts-with-subseq prefix header))))) + +(defparameter +hunchentoot-methods-with-body+ + '(:post :put :patch)) + +(defun request-body (&key (request lzb:*request*) (want-stream-p nil)) + "Returns the decoded request body. The value returned depends upon +the value of the Content-Type request header. + +If WANT-STREAM-P is non-null, then an attempt is made to return a +stream from which the body content can be read. This may be impossible +if the Content-Type of the request is one of multipart/form-data or +application/x-www-form-urlencoded. + +If the body's Content-Type is application/json, multipart/form-data, +or application/x-www-form-urlencoded then a property-list +representation of the body is returned. + +Otherwise a bytevector of the body is returned. + +Work to unpack the body is performed once per request. Calling this" + (if %request-body-cache% %request-body-cache% + (setf %request-body-cache% + (when (member (request-method request) +hunchentoot-methods-with-body+) + (let ((pre-decoded-body-p + (pre-decoded-body-p request)) + (content-type + (request-header :content-type request))) + (cond + ;; try to get a stream on request + (want-stream-p + ;; can't do it if the body is already decoded - return nil so + ;; that request-body can be called again + (unless pre-decoded-body-p + (h:raw-post-data :request request :want-stream t))) + + (pre-decoded-body-p + (format-as-lazybones-document + (h:post-parameters request))) + + ((string-equal "application/json" content-type) + (jonathan:parse + (h:raw-post-data :request request :external-format :utf8) + :as :plist + :keywords-to-read *allowed-keywords*)) + + (t + ;; default case is to return a bytevector + (h:raw-post-data :request request :force-binary t)))))))) + +(defun format-as-lazybones-document (post-parameters) + "internal function. Formats all the post parmaeters (see docstring + on hunchentoot:post-parameters) into a plist with keyword keys, as + is the convention for lazybones." + (loop for (k . value) in post-parameters + collect (alexandria:make-keyword k) + collect value)) + +;;; HTTP RESPONSE FUNCTIONS + +(defun response-code (&optional (response lzb:*response*)) + "Access the return code of the resposne. Return code should be an integer." + (h:return-code response)) + +(defun (setf response-code) (code &optional (response lzb:*response*)) + (setf (h:return-code response) code)) + +(defun response-header (name &optional (response lzb:*response*)) + "Access the response header that has NAME, which can be a keyword (recommended) or a string." + (h:header-out name response)) + +(defun (setf response-header) (value name &optional (response lzb:*response*)) + (setf (h:header-out name response) value)) + +(defun response-cookie (name &optional (response lzb:*response*)) + "Access the cookie with NAME in the response object." + (h:cookie-out name response)) + +(defun set-response-cookie + (name value + &key expires max-age path domain secure http-only (response lzb:*response*)) + "Sets the response cookie" + (apply 'h:set-cookie name + :value value + :reply response + (nconc (when expires (list :expires expires)) + (when max-age (list :max-age max-age)) + (when path (list :path path)) + (cond + (domain (list :domain domain)) + ((server-domain) (list :domain (server-domain)))) + (when secure (list :secure secure)) + (when http-only (list :http-only http-only))))) + +(defun http-respond (content) + "Final step preparing response before backend does the rest. For +Hunchentoot set a few headers. If content is a pathname, pass off to +HUNCHENTOOT:HANDLE-STATIC-FILE, otherwise just return the content." + + ;; When http-err is called, the content is likely to be null. If + ;; that is the case, look for the default content for the error + ;; code, and set content and content-type appropriately + (a:when-let (data + (and (null content) + (canned-response %server% (response-code)))) + (destructuring-bind (source content-type) data + (setf (response-header :content-type) content-type + content (if (or (functionp source) (symbolp source)) + (funcall source) + source)))) + + ;; set the response code and header. + (setf + (response-header :content-type) (or (response-header :content-type) + (when (pathnamep content) + (h:mime-type content)) + (when lzb:*app* + (lzb::default-content-type lzb:*app*)) + "text/plain")) + (if (pathnamep content) + (h:handle-static-file content) + content)) + diff --git a/src/client/dexador.lisp b/src/client/dexador.lisp new file mode 100644 index 0000000..2503b5e --- /dev/null +++ b/src/client/dexador.lisp @@ -0,0 +1,205 @@ +;;;; lazybones-client.lisp -- macro to generate a set of http request functions given an APP instance + +;; Copyright (C) 2022 Colin Okay + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + + +(defpackage #:lazybones/client.dexador + (:use #:cl) + (:local-nicknames (#:a #:alexandria-2)) + (:export #:generate)) + +(in-package :lazybones/client.dexador) + + + +(defun endpoint-defun-name (ep) + "Returns the string name of a defun for making requests to +endpoint EP." + (with-output-to-string (*standard-output*) + (princ (string-downcase (symbol-name (lazybones::endpoint-method ep)))) + (princ "-") + (loop for (term . more) on (lazybones::endpoint-dispatch-pattern ep) + when (and (stringp term) (plusp (length term))) + do (princ (string-downcase term)) + when (listp term) + do (princ (string-downcase (car term))) + when (and more (plusp (length term))) + do (princ "/")))) + +(defun endpoint-defun-route-var-names (ep) + "Returns a list of strings representing the names of route variables +extracted from endpoint EP, to be used as variable names in the defun +for making requests to that endpoint." + (lazybones::endpoint-route-vars ep)) + +(defun endpoint-defun-query-var-names (ep) + "Returns a list of strings representing the names of query parameter +variables extraced from the endpoint EP, to be used as variable names +in the defun for making request to that endpoint." + (mapcar (a:compose #'symbol-name #'first) + (lazybones::endpoint-params ep))) + + +(defun endpoint-accepts-body-p (ep) + (member (lazybones::endpoint-method ep) '(:post :put :patch)) ) + +(defun endpoint-defun-lambda-list (ep) + "Returns a string representation of the lambda list of the defun +for making requests to endpoint EP." + (format + nil + "(~{~a ~} %host &key ~:[~;%content-type %body ~] %headers %cookies)" + (append + (endpoint-defun-route-var-names ep) + (endpoint-defun-query-var-names ep)) + (endpoint-accepts-body-p ep))) + + +(defun endpoint-defun-dexador-uri-route-format-string (ep) + "Returns a string representing a format string, intended to be + embedded into the body of a defun for making requests to the + endpoint Ep. It is designed to be passed to FORMAT, where route + variables are substituted into the string." + (str:join "/" + (mapcar (lambda (x) (if (listp x) "~a" x)) + (lazybones::endpoint-dispatch-pattern ep)))) + +(defun endpoint-defun-dexador-uri-route-query-format-string (ep) + "Returns a string representing a format string, intended to be + embedded into the body of a defun for making requests to the + endpoint EP. It is desienged to be passed to FORMAT, where query + paramters are substituted into the string, if they exist." + (with-output-to-string (*standard-output*) + (loop + for first = t then nil + for varname in (endpoint-defun-query-var-names ep) + do + (princ "~@[") + (unless first (princ #\&)) + (princ (string-upcase varname)) + (princ "=~a~]")))) + +(defun endpoint-defun-dexador-request-uri (app ep) + "Returns a string representation of code that generates a URI for + passing to the dexador request function within the body of the defun + for making requests to the endpoint EP of the application APP." + (concatenate + 'string + "(format nil " + "\"" + "~a" + (lazybones::app-prefix app) + (endpoint-defun-dexador-uri-route-format-string ep) + "?" + (endpoint-defun-dexador-uri-route-query-format-string ep) + "\" " + "%host " + (str:join " " (endpoint-defun-route-var-names ep)) + " " + (str:join " " (endpoint-defun-query-var-names ep)) + ")")) + +(defun endpoint-defun-body (app ep) + "Returns a string representation of the function body of a defun + for making requests to the endpoint EP in the app APP." + (format + nil + " (dexador:~a~% ~a~%~{ ~a~^~%~})" + (string-downcase (symbol-name (lazybones::endpoint-method ep))) + (endpoint-defun-dexador-request-uri app ep) + (append + (if (endpoint-accepts-body-p ep) + (list ":content %body" + ":cookie-jar %cookies" + ":headers (if %content-type (cons (cons \"Content-Type\" %content-type) %headers) %headers)") + (list ":cookie-jar %cookies" + ":headers %headers"))))) + +(defun generate-defun-for-endpoint (app ep) + "Returns a string representation of a defun form for a function that +makes a request to the endpoint EP." + (format nil + "(defun ~a~% ~a~% ~s~%~a)" + (endpoint-defun-name ep) + (endpoint-defun-lambda-list ep) + (lazybones::endpoint-documentation ep) + (endpoint-defun-body app ep))) + + +(defun all-function-names (app) + (mapcar 'endpoint-defun-name (lazybones::app-endpoints app))) + +(defun app-client-package-name (app) + (format nil "~a-CLIENT" (lazybones::app-name app))) + + +(defun generate-defsystem-for-client-of-app (app) + (with-output-to-string (*standard-output*) + (princ "(asdf:defsystem #:") (princ (app-client-package-name app)) + (terpri) + (princ " :depends-on (#:dexador)") + (terpri) + (princ " :components ((:file ") + (princ #\") + (princ (string-downcase (app-client-package-name app))) + (princ #\") + (princ ")))"))) + + +(defun generate-defpackage-for-client-of-app (app) + (with-output-to-string (out) + (format + out + " +;;;; DO NOT EDIT! THIS FILE HAS BEEN GENERATED BY LAZYBONES-CLIENT + +(defpackage #:~a + (:use :cl) + (:export ~%~{ #:~a~^~%~}))" + (app-client-package-name app) + (all-function-names app)) + (terpri out) + (format out "(in-package :~a)" (app-client-package-name app)) + (terpri out))) + +(defun client-asd-file-name (app) + (format nil "~a.asd" (string-downcase (app-client-package-name app)))) + +(defun client-lisp-file-name (app) + (format nil "~a.lisp" (string-downcase (app-client-package-name app)))) + +(defun generate-client-functions-for-app (app) + (loop for ep in (lazybones::app-endpoints app) + collect (generate-defun-for-endpoint app ep))) + +(defun generate (directory app) + "Generate " + (assert (uiop:directory-exists-p directory)) + + (alexandria:write-string-into-file + (generate-defsystem-for-client-of-app app) + (merge-pathnames (client-asd-file-name app) directory)) + + (alexandria:write-string-into-file + (with-output-to-string (*standard-output*) + (princ (generate-defpackage-for-client-of-app app)) + (princ #\newline) (princ #\newline) + (princ #\newline) (princ #\newline) + (dolist (defun-string (generate-client-functions-for-app app)) + (princ defun-string) + (princ #\newline) (princ #\newline))) + (merge-pathnames (client-lisp-file-name app) directory)) + :ok) diff --git a/src/client/parenscript.lisp b/src/client/parenscript.lisp new file mode 100644 index 0000000..75afbd7 --- /dev/null +++ b/src/client/parenscript.lisp @@ -0,0 +1,3 @@ +(defpackage #:lazybones/client.parenscript + (:use #:cl) + (:export #:generate)) diff --git a/src/documentation/markdown.lisp b/src/documentation/markdown.lisp new file mode 100644 index 0000000..5f2b883 --- /dev/null +++ b/src/documentation/markdown.lisp @@ -0,0 +1,116 @@ +;; 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/>. + + +;;;; markdown.lisp -- documenting APP instances + +(defpackage #:lazybones/documentation.markdown + (:use #:cl) + (:export #:generate)) + +(in-package :lazybones/documentation.markdown) + +(defun sorted-endpoints (endpoints) + (sort (copy-seq endpoints) #'string< :key #'endpoint-route)) + +(defun generate (app) + "For now, returns a single Markdown formatted string that documents +each endpoint in APP." + (symbol-macrolet ((newline (progn (princ #\newline)(princ #\newline)))) + (with-slots + (title + version + endpoints + (default-authorizer authorizer) + default-content-type + description + definitions) + app + (with-output-to-string (*standard-output*) + (princ "# ") (princ title) (princ " - ") (princ "v") (princ version) + newline + (princ description) + newline + (princ "## Endpoints") + (dolist (ep (sorted-endpoints endpoints)) + (with-slots (method content-type route authorizer params endpoint-documentation) ep + newline + (princ "### ") (princ method) (princ " ") (princ (make-route-presentable route)) + (terpri) + (princ "*") + (princ (if content-type content-type default-content-type )) + (princ "*") + (when authorizer + newline + (princ "Authorization Required: ") + newline + (cond ((function-or-function-name-p authorizer) + (princ (ensure-blockquote (documentation authorizer 'function)))) + ((function-or-function-name-p default-authorizer) + (princ (ensure-blockquote (documentation default-authorizer 'function))))) + newline) + (a:when-let (vars (endpoint-route-vars ep)) + newline + (princ "Route Variables: ") newline + (dolist (var vars) + (princ "- ") (princ var) + (a:when-let (val-parser (route-var-value-parser ep var)) + (princ ": ") (princ (strip-newlines (documentation val-parser 'function)))) + (princ #\newline))) + (when params + newline + (princ "Documented Query Parameters: ") newline + (loop for (var parser) in params + do (princ "- ") (princ (string-downcase (symbol-name var))) + (princ ": ") (princ (strip-newlines (documentation parser 'function))) + (princ #\newline))) + newline + (princ endpoint-documentation))) + newline + (when (plusp (hash-table-count definitions)) + (princ "## Definitions") newline + (loop for name being the hash-key of definitions + for (node-id . text) being the hash-value of definitions + do (format *standard-output* + "<h3 id='~a'>~a</h3>" + node-id name) + (princ #\newline) (princ #\newline) + (princ text) + (princ #\newline) (princ #\newline))))))) + +(defun ensure-blockquote (string) + (concatenate 'string "> " + (str:replace-all + '(#\newline) + " +> " + string))) + +(defun strip-newlines (string) + (str:replace-all '(#\newline) "" string)) + +(defun function-or-function-name-p (thing) + (or (functionp thing) + (and (symbolp thing) (fboundp thing)))) + +(defun endpoint-route-vars (ep) + "return a list of route variables for endpoint EP" + (mapcar 'first (remove-if-not #'consp (endpoint-dispatch-pattern ep)))) + +(defun route-var-value-parser (ep var) + (second (assoc var (remove-if-not #'consp (endpoint-dispatch-pattern ep))))) + +(defun make-route-presentable (routestring) + (ppcre:regex-replace-all " [a-z0-9A-Z\-]+:" routestring ":")) 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))) diff --git a/src/macros.lisp b/src/macros.lisp new file mode 100644 index 0000000..0d941b6 --- /dev/null +++ b/src/macros.lisp @@ -0,0 +1,49 @@ +;; 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/>. + + +;;;; macros.lisp --- utility macros + + +(in-package :lazybones) + +(defmacro let-parameters ((&rest names) &body body) + "NAMES is a list of symbols. Binds the names to the value of the +request parameters whose keys compare string-equal to the symbol-name +of each NAME, or NIL if there is no such parameter." + (let ((params (gensym))) + `(let ((,params (lazybones:request-parameters))) + (let ,(loop for name in names + for string-name = (symbol-name name) + collect `(,name (cdr (assoc ,string-name ,params :test #'string-equal)))) + (declare (ignorable ,@names)) + ,@body)))) + +(defmacro map-parameters ((&rest params) &body body) + "PARAMS is a list of pairs (NAME PARSER). MAP-PARAMETERS behaves +exactly like LET-PARAMETERS except that the values boudn to NAMEs are +first mapped with the PARSER function." + (assert (loop for (name parser) in params + always (and (symbolp name) + (or (symbolp parser) (functionp parser)))) + () + "Malformed PARAMS in MAP-PARAMETERS macro") + + (let ((names (mapcar #'car params))) + `(let-parameters ,names + (let ,(loop for name in names + collect `(,name (when ,name (funcall ',(second (assoc name params)) ,name)))) + ,@body)))) + diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..04cc5bf --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,90 @@ +;;;; package.lisp + +;; any backend must implement functions for these +;; use the hunchentoot backend as a reference +(defpackage #:lazybones-backend + (:export + ;; request functions + #:request-url + #:request-path + #:request-host + #:request-port + #:request-query-string + #:request-parameter + #:request-parameters + #:request-headers + #:request-header + #:request-method + #:request-body + #:request-cookie + ;; resposne functions + #:response-header + #:response-code + #:set-response-cookie + #:response-cookie + #:http-respond + ;; server functions + #:install-app + #:uninstall-app + #:create-server + #:server-domain + #:start-server + #:stop-server + #:canned-response + #:set-canned-response + ;; special variables + #:*allowed-keywords* + )) + +;; the symbols exported here are available for end users to use in the +;; building of their apps +(defpackage #:lazybones + (:use #:cl #:lazybones-backend) + (:local-nicknames (#:a #:alexandria) + (#:re #:cl-ppcre)) + (:export + #:*app* + #:*request* + #:*response* + #:*debugging* + #:*allowed-keywords* + #:http-error + #:generate-app-documentation + #:provision-app + #:app + #:canned-response + #:set-canned-response + #:create-server + #:defendpoint + #:defendpoint* + #:endpoint + #:let-parameters + #:map-parameters + #:http-err + #:http-respond + #:install-app + #:request-body + #:request-cookie + #:request-header + #:request-headers + #:request-host + #:request-method + #:request-parameter + #:request-parameters + #:request-path + #:request-port + #:request-query-string + #:request-url + #:response-code + #:set-response-cookie + #:response-cookie + #:response-header + #:start-server + #:stop-server + #:uninstall-app + #:set-definition + #:drop-definition + #:add-class-to-definitions + #:ext->mimetype + #:dictionary)) + |