version 1.0

1 files changed, 0 insertions, 573 deletions

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 <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)))