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-documentation.lisp | 111 -------- lazybones-hunchentoot.asd | 10 - lazybones-hunchentoot.lisp | 326 ----------------------- lazybones.asd | 54 +++- lazybones.lisp | 573 ---------------------------------------- macros.lisp | 49 ---- package.lisp | 90 ------- src/backend/hunchentoot.lisp | 323 ++++++++++++++++++++++ src/client/dexador.lisp | 205 ++++++++++++++ src/client/parenscript.lisp | 3 + src/documentation/markdown.lisp | 116 ++++++++ src/lazybones.lisp | 573 ++++++++++++++++++++++++++++++++++++++++ src/macros.lisp | 49 ++++ src/package.lisp | 90 +++++++ 14 files changed, 1407 insertions(+), 1165 deletions(-) delete mode 100644 lazybones-documentation.lisp delete mode 100644 lazybones-hunchentoot.asd delete mode 100644 lazybones-hunchentoot.lisp delete mode 100644 lazybones.lisp delete mode 100644 macros.lisp delete mode 100644 package.lisp create mode 100644 src/backend/hunchentoot.lisp create mode 100644 src/client/dexador.lisp create mode 100644 src/client/parenscript.lisp create mode 100644 src/documentation/markdown.lisp create mode 100644 src/lazybones.lisp create mode 100644 src/macros.lisp create mode 100644 src/package.lisp diff --git a/lazybones-documentation.lisp b/lazybones-documentation.lisp deleted file mode 100644 index 9e837d0..0000000 --- a/lazybones-documentation.lisp +++ /dev/null @@ -1,111 +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-documentation.lisp -- documenting APP instances - -(in-package :lazybones) - -(defun sorted-endpoints (endpoints) - (sort (copy-seq endpoints) #'string< :key #'endpoint-route)) - -(defun generate-app-documentation (app) - "For now, generates a single Markdown 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* - "

~a

" - 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/lazybones-hunchentoot.asd b/lazybones-hunchentoot.asd deleted file mode 100644 index 56ae2c0..0000000 --- a/lazybones-hunchentoot.asd +++ /dev/null @@ -1,10 +0,0 @@ -;;;; lazybones-hunchentoot.asd - -(asdf:defsystem #:lazybones-hunchentoot - :description "hunchentoot backend for lazybones" - :author "Colin Okay " - :license "AGPLv3" - :version "0.2.1" - :serial t - :depends-on (#:hunchentoot #:lazybones) - :components ((:file "lazybones-hunchentoot"))) diff --git a/lazybones-hunchentoot.lisp b/lazybones-hunchentoot.lisp deleted file mode 100644 index 2b3bf1e..0000000 --- a/lazybones-hunchentoot.lisp +++ /dev/null @@ -1,326 +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-hunchentoot.lisp -- hunchentoot backend for lazybones - -(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/lazybones.asd b/lazybones.asd index bd56d95..cb74b04 100644 --- a/lazybones.asd +++ b/lazybones.asd @@ -1,19 +1,61 @@ ;;;; lazybones.asd (asdf:defsystem #:lazybones - :description "http route handling" - :author "Colin Okay " + :description "Multi-backend HTTP Framework with automatic client and documentation generation. " + :author "Colin " :license "AGPLv3" - :version "0.10.1" + :version "1.0.0" + :pathname "src/" :serial t :depends-on (#:alexandria + #:closer-mop + #:trivial-documentation #:str #:cl-ppcre - #:trivial-documentation #:jonathan #:lisp-namespace) :components ((:file "package") (:file "macros") - (:file "lazybones") - (:file "lazybones-documentation"))) + (:file "lazybones"))) + +(asdf:defsystem #:lazybones/documentation + :description "Generate documentation for a lazybones app's endpoints." + :author "Colin " + :license "AGPLv3" + :depends-on (#:lazybones) + :pathname "src/documentation/" + :serial t + :components ((:file "markdown"))) + +(asdf:defsystem #:lazybones/backend/hunchentoot + :description "hunchentoot backend for lazybones" + :author "Colin " + :license "AGPLv3" + :version "1.0.0" + :depends-on (#:hunchentoot #:lazybones) + :pathname "src/backend/" + :serial t + :components ((:file "hunchentoot"))) + + +(asdf:defsystem #:lazybones/client/parenscript + :description "Generate a JS module for API requests to a lazybones APP." + :author "Colin " + :license "AGPLv3" + :version "1.0.0" + :depends-on (#:parenscript #:lazybones) + :pathname "src/client/" + :serial t + :components ((:file "parenscript"))) + +(asdf:defsystem #:lazybones/client/dexador + :description "Generates a lisp source file for API requests to a lazybones APP using Dexador." + :author "Colin " + :license "AGPLv3" + :version "1.0.0" + :depends-on (#:dexador #:lazybones) + :pathname "src/client/" + :serial t + :components ((:file "dexador"))) + 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))) diff --git a/macros.lisp b/macros.lisp deleted file mode 100644 index 46ac4da..0000000 --- a/macros.lisp +++ /dev/null @@ -1,49 +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 . - - -;;;; 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/package.lisp b/package.lisp deleted file mode 100644 index 4ed5cdf..0000000 --- a/package.lisp +++ /dev/null @@ -1,90 +0,0 @@ -;;;; 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)) - 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 . + +(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 . + + +(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 . + + +;;;; 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* + "

~a

" + 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 . + + +;;;; 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 . + + +;;;; 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)) + -- cgit v1.2.3