path: root/src/lazybones.lisp

;; Copyright (C) 2022  colin@cicadas.surf

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


;;;; lazybones.lisp

(in-package #:lazybones)

;;; DYNAMIC VARIABLES

(defvar *request* nil
  "Dynamic Variable holding the current request object. Dynamically
  bound and available to each handler.  The exact object bound to
  *request* varies according to the current backend.")

(defvar *response* nil
  "Dynamic variable holding the current response object. Dynamically
  bound and available to each handler. The exact object bound
  *response* varies according to the current backend. ")

(defvar *app* nil
  "Dynamic variable holding the an APP instance. Dynamically bound by
  RUN-ENDPOINT so that it is available if needed in request handlers.")

(defvar *allowed-keywords* nil
  "Dynamic variable. Can be bound by handler functions to control which
keywords are read in while parsing request bodies. Should be used
when keyword bombing is a concern.")

(defvar *debugging* nil)

;;; HTTP-ERROR CONDITION

(define-condition http-error (condition)
  ((code :initarg :code)
   (content :initarg :content)))


;;; APP NAMESPACE

(lisp-namespace:define-namespace lazybones)

;;; LAZYBONES CLASSES

(defun default-app-name ()
  (intern (package-name *package*) *package*))

(defclass app ()
  ((name
    :reader app-name
    :initarg :name
    :initform (error "Appname is required")
    :type symbol)
   (title
    :accessor app-title
    :initarg :title
    :initform ""
    :type string
    :documentation "A string title")
   (description
    :accessor app-description
    :initarg :description
    :initform ""
    :type string
    :documentation "A string describing the app")
   (version
    :accessor app-version
    :initarg :vsn :initarg :version
    :initform "0.0.1"
    :type string)
   (prefix
    :accessor app-prefix
    :initarg :prefix
    :initform ""
    :documentation "Effectively prepended to all endpoints for the
    purposes of request handling.  E.g. \"/api\" is a good prefix." )
   (definitions
    :accessor app-definitions
    :initform (make-hash-table :test 'equal)
    :documentation "Definitions are used in the generation of
    documentation. They can be linked to from docstrings of
    endpoints. Used to provide additional documentation for, e.g.,
    JSON object specifications for post bodies or return types.")
   (authorizer
    :accessor request-authorizer
    :initarg :auth
    :initform nil
    :documentation "A function of zero arguments that uses the request
    API functions in LAZYBONES.BACKEND to determine whether or not the
    current request is authorized. This is the default authorizer, and
    is evoked when an ENDPOINT's AUTH slot is T. Endpoints may
    override this behavor by supplying a function in place of T. A
    value of NIL means that there is no default authorizer.")
   (default-content-type
    :accessor default-content-type
    :initarg :content-type
    :initform "text/html"
    :documentation "Default content type sent back to clients.")
   (endpoints
    :accessor app-endpoints
    :initform nil)
   (dict
    :accessor app-dict
    :initform (make-hash-table :test 'equal)
    :documentation "A hash table for storing arbitrary informatrion on this application.")))

(defun expand-provision-app-option (app option value)
  (list 'setf 
        (ecase option
          ((:desc :description)  `(lazybones::app-description ,app))
          (:prefix `(lazybones::app-prefix ,app))
          (:title `(lazybones::app-title ,app))
          (:version `(lazybones::app-version ,app))
          (:content-type `(lazybones::default-content-type ,app))
          ((:auth :authorizer) `(lazybones::request-authorizer ,app)))
        value))

(defmacro provision-app ((&optional name) &body body)
  (assert (evenp (length body)) () "Odd number of forms in PROVISION-APP BODY.")
  (let* ((the-app
           (gensym))
         (provisioning
          (loop for (k v . more) on body by #'cddr
                collect (expand-provision-app-option the-app k v))))
    `(let ((,the-app
             (if (null ',name)
                 (or (app) (make-instance 'app :name (default-app-name)))
                 (or (app ',name) (make-instance 'app :name ',name)))))
       ,@provisioning)))

(defmethod initialize-instance :before ((app app) &key name &allow-other-keys)
  (when  (app name)
    (error "an app named ~s already exists" name)))

(defmethod initialize-instance :after ((app app) &key)
  (setf (symbol-lazybones (app-name app)) app))

(defun app (&optional name)
  "Get the APP instance named by the symbol NAME. If NAME is not
supplied, get the default app. Every package has at most one default
app, named with the package name.  If no app can be found, return NIL"
  (symbol-lazybones (or name (default-app-name)) nil))

(defun dictionary (key &optional name)
  "Get value from the application dict"
  (gethash key (app-dict (app name))))

(defun (setf dictionary) (new key &optional name)
  "Set a value in the application dict."
  (setf (gethash key (app-dict (app name))) new))

(defclass endpoint ()
  ((method
    :reader endpoint-method
    :initarg :method
    :initform :get)
   (route
    :reader endpoint-route
    :initarg :route
    :initform (error "endpoint route required"))
   (params
    :reader endpoint-params
    :initarg :params
    :initform nil
    :documentation "A list of (SYMBOL-NAME FUNCTION-SYMBOL),
    documenting the query parameters this endpoint expects. Used for
    generating both documentation and client functions.")
   (content-type
    :reader endpoint-content-type
    :initarg :content-type
    :initform nil)
   (authorizer
    :reader request-authorizer
    :initarg :auth
    :initform nil
    :documentation "A function of zero arguments used to authorize the
    request currently bound to *REQUEST*. Returns non-nil if
    authorized, and NIL if not.")
   (dispatch-pattern
    :reader endpoint-dispatch-pattern
    :initarg :pattern)

   (body-variables
    :reader endpoint-body-variables
    :initarg :body-variables
    :initform nil
    :documentation "A list of fields that should appear in the body of a
     request that has a body. Completely optional, but used to build 
     client functions.")

   (handler-function
    :reader endpoint-request-handler
    :initarg :function)
   (endpoint-documentation
    :reader endpoint-documentation
    :initarg :doc
    :initform "")))

(defun routekey-term-match-p (pattern-term routekey-term)
  "Internal helper function. Returns T if both arguments are strings
and they compare with STRING-EQUAL.  Otherwise, PATTERN-TERM is
assumed to be a route variable representation, in which case T is
returned, indicating that the variable should bind to anything."
  (if (stringp pattern-term)
      (string-equal pattern-term routekey-term)
      t))

(defun matches-routekey-p (pattern key)
  "PATTERN is a list, each member of which is a string or a variable
representation. PATTERN will have been generated by
PARSE-ROUTE-STRING-TEMPLATE.

If there are no variables in PATTERN, MATCHES-ROUTEKEY-P returns T
or NIL.

If there are variables in the pattern, MATCHES-ROUTEKEY-P returns a
list of values, in the case of success, or NIL in the case of failure."
  (when  (= (length pattern) (length key))
    (loop for pterm in pattern
          for rterm in key
          for matchp = (routekey-term-match-p pterm rterm)
          unless matchp
            return nil
          when (listp pterm)           ; looks like (var) or (var value-parser)
            collect (if (second pterm)
                        (funcall (second pterm) rterm)  ; parse value from rterm if we can
                        rterm)                          ; otherwise use rterm string
              into arguments
          finally (return (or arguments t)))))

(defun strip-app-prefix (app path)
  (multiple-value-bind (success suffix) (a:starts-with-subseq (app-prefix app) path :return-suffix t)
    (unless success (error "~a is not prefixed by ~a" path (app-prefix app)))
    suffix))

(defun find-endpoint (app &optional (request *request*))
  (find-endpoint-matching-key
   app
   (request-method request)
   (url-path->request-routekey (strip-app-prefix app (request-path request)))))

(defun method-match-for-dispatch-p (req-method ep-method)
  "Either the arguments compare EQ or the first is :HEAD and the second is :GET."
  (or (eq req-method ep-method)
      (and (eq :head req-method) (eq :get ep-method))))

(defun find-endpoint-matching-key (app method key)
  "Returns a list. NIL represents failure to find match.

Otherwise the result is (ENDPOINT . ARGS) where ENDPOINT is an
endpoint instanceq and ARGS is a list of arguments to pass to
ENDPOINT's handler function."
  (loop for endpoint in (app-endpoints app)
        for match =  (and (method-match-for-dispatch-p method (endpoint-method endpoint))
                          (matches-routekey-p (endpoint-dispatch-pattern endpoint) key))
        when match 
          return (cons endpoint (when (listp match) match))))


(defun patterns-match-p (p1 p2)
  (and (eql (length p1) (length p2))
       (every 'routekey-term-match-p p1 p2)))

(defun find-endpoint-matching-pattern (app method pattern)
  (loop for ep in (app-endpoints app)
        when (and (eql method (endpoint-method ep))
                  (patterns-match-p pattern (endpoint-dispatch-pattern ep)))
          return ep))

(defun unregister-endpoint (app method dispatch-pattern)
  (a:when-let (extant-ep (find-endpoint-matching-pattern app method dispatch-pattern))
    (setf (app-endpoints app) (delete extant-ep (app-endpoints app)))))

(defun register-endpoint (app ep)
  (unregister-endpoint app (endpoint-method ep) (endpoint-dispatch-pattern ep))
  (push ep (app-endpoints app)))

(defparameter +http-methods+
  (list :get :head :put :post :delete :patch))

(defun url-path->request-routekey (path)
  "A routekey is used to match urls to endpoints that handle them."
  (str:split #\/ path))

(defun parse-route-string-template (template)
  "Routes are of the form 

/foo/bar/:variable:/blah 

/foo/bar/:var parse-integer:/blah

On success returns things like:

(\"foo\" \"bar\" (VARIABLE) \"blah\")  
(\"foo\" \"bar\" (VAR PARSE-INTEGER) \"blah\")

Returns NIL on failure"
  (cond ((equal "" template) nil)
        (t
         (when (search "//" template)
           (warn "The proposed route ~s contains a double forward-slash (//), is this intended?"
                 template))
         (unless (eql #\/ (elt template 0))
           (error "The proposed route ~s does not begin with a forward-slash, is this intended?"
                 template))
         (loop for field in (str:split #\/ template)
               for var? = (parse-route-variable-string field)
               when var?
                 collect var?
               else
                 collect (string-downcase field)))))

(defun parse-route-variable-string (string)
  "A route variable string looks like :foo: or :foo bar:

In the case of a successful parse, a list of one or two symbols is
returned. These symbosl are created using read-from-string, which
allows for these symbols' packages to be specified if desired.

Returns NIL on failure."
  (when (and (a:starts-with-subseq ":" string)
             (a:ends-with-subseq  ":" string))
    (destructuring-bind
        (var-name . decoder?)
        (re:split " +"
                  (string-trim " "
                               (subseq string 1 (- (length string) 1))))
      (if decoder?
          (list (string-upcase var-name) (read-from-string (first decoder?)))
          (list (string-upcase var-name))))))

(defun endpoint-route-variables (endpoint)
  (route-variables (endpoint-dispatch-pattern endpoint)))

(defun route-variables (pattern)
  (loop for term in pattern
        when (listp term)
          collect (first term)))


(defun run-endpoint (endpoint args request response app)
  "Bind dynamic variables *request* *response* and *app* before
applying HANDLER-FUNCTION slot of ENDPOINT to the ARGS list."
  (let ((*request* request)
        (*response* response)
        (*app* app))
    (setf (response-code) 200)
     (if (request-authorized-p endpoint) 
        (http-respond (apply (endpoint-request-handler endpoint) args))
        (http-err 403))))

(defun request-authorized-p (endpoint)
  "Attempts to authorize an endpoint.

If the endpoint's request-authorizer is NIL, then the endpoint doesn't
require authorization, and T is returned.

If the endpoint's request-authorizer is a function, call it.

If the endpoint's request-authorizer is T, then the app's default
authorizer is used.

Hence, if the endpoint authorizer is T and the app doesn't have an
authorizer, then, the endpoint wants to be authorized but there isn't
any way to do it, hence NIL is returned."
  (a:if-let (auth (request-authorizer endpoint))
    (if (or (functionp auth)
            (and (symbolp auth) (fboundp auth)))
        (funcall auth)
        (when (request-authorizer *app*) ; perhaps this should be an if, and  
          (funcall (request-authorizer *app*))))
    t))

;;; ENDPOINT DEFINITION

(eval-when (:compile-toplevel :load-toplevel  :execute)
  (defun endpoint-function-name-helper (method route)
    (string-upcase
     (format nil "~a-~{~a~^-~}"
             (symbol-name method)
             (mapcar
              (lambda (x) (if (stringp x) x (car x)))
              (cdr (parse-route-string-template route)))))))

(defmacro defendpoint
    (appname method route
     query-params
     (&key
        (auth nil)
        (body-vars nil)
        content-type)
     &body body)
  "Defines and installs an ENDPOINT instance to the APP instance
indicated by APPNAME, first checking an APP called APPNAME exits,
making a new one if not."
  (assert (member method +http-methods+) ()
          "~a is not a valid http method keyword"
          method)
  (a:with-gensyms (the-app auth-method)
    (let* ((dispatch-pattern 
             (parse-route-string-template route))
           (endpoint-name
             (intern (endpoint-function-name-helper method route)))
           (lambda-list
             (mapcar 'intern (route-variables  dispatch-pattern)))
           (documentation
             (when (stringp (first body)) (first body)))
           (body-without-docstring
             (if (stringp (first body)) (rest body) body))
           (real-body
             (if body-vars
                 `((let-body ,body-vars ,@body-without-docstring))
                 body-without-docstring)))

      (when query-params
        (setf real-body
              `((map-parameters ,query-params ,@real-body))))

      `(let* ((,the-app
                (or (app ',appname) (make-instance 'lazybones:app :name ',appname)))
              (,auth-method
                ,auth))

         (defun ,endpoint-name ,lambda-list
           (declare (ignorable ,@lambda-list))
           (setf (lazybones:response-header :content-type)
                 (or ,content-type (lazybones::default-content-type ,the-app)))
           ,@real-body)

         (register-endpoint
          ,the-app
          (make-instance 'lazybones:endpoint
           :method ,method 
           :route ,route
           :params ',query-params
           :content-type ,content-type
           :pattern ',dispatch-pattern
           :doc ,documentation
           :auth ,auth-method
           :body-variables ',body-vars
           :function ',endpoint-name))))))

(defmacro defendpoint* (method route params options &rest body)
  "Like DEFENDPOINT but uses the current package name as the app name."
  `(defendpoint ,(default-app-name) ,method ,route ,params ,options ,@body))

;;; ENDPOINT HANDLING UTILITIES

(defun http-err (code &optional content)
  "Singals an HTTP-ERROR with code and content."
  (signal 'http-error :content content :code code))

(defun http-redirect (location)
  "Set the lazybones response header and response code for redirecting to LOCATION.
This procedure will error if lazybones:*response* is not currently bound."
  (setf (response-header :location) location
	(response-code) "303"))



;;; MANAGING DEFINITIONS

(defun set-definition (name item-id definition-text &optional (app (lazybones:app)))
  "Name is a string"
  (setf (gethash name (app-definitions app)) (cons item-id definition-text)))

(defun drop-definition (name &optional (app (lazybones:app)))
  "Remove definition keyed by LINK-TARGET from APP."
  (remhash name (app-definitions app)))

(defun names-equal-p (s1 s2)
  (or (equalp s1 s2)
      (and (symbolp s1) (equalp (symbol-name s1) s2))
      (and (symbolp s2) (equalp s1 (symbol-name s2)))
      (and (symbolp s1) (symbolp s2)
           (string-equal (symbol-name s1) (symbol-name s2)))))

(defun getplist (indicator plist &key (test 'names-equal-p ) key)
  (let ((indicator (if key (funcall key indicator) indicator))) 
    (loop for (k0 v . more) on plist by #'cddr
          for k = (if key (funcall key k0) k0)
          when (funcall test indicator k)
            return (values v t)
          finally (return (values nil least-negative-long-float )))))

(defun class-docs (class-name)
  (closer-mop:ensure-finalized (find-class class-name))
  (loop for plist in (trivial-documentation:symbol-definitions class-name)
        when (eql :class (getf plist :kind))
          return (list (getf plist :documentation)
                       (getf plist :slots))))

(defun add-class-to-definitions (app class-name &rest slot-names)
  "Generates a definition entry from class and slot documentation
CLASS-NAME should be a symbol, and SLOT-NAMES symbols."
  (destructuring-bind (documentation slots) (class-docs class-name)
    (set-definition (string-downcase (symbol-name class-name))
                    (string-downcase (format nil "#~a" class-name))
                    (with-output-to-string (*standard-output*)
                      (princ documentation) 
                      (princ #\newline) (princ #\newline)
                      (princ "**Slots:**") (princ #\newline)
                      (dolist (sn slot-names)
                        (a:when-let (slot-doc (getplist sn slots))
                          (princ "- ") (princ sn) (princ ": ")
                          (princ slot-doc)
                          (princ #\newline)))
                      (princ #\newline))
                    app)))

(defparameter +extension->mimetype+
  '(("aac" "audio/aac")
    ("abw" "application/x-abiword")
    ("arc" "application/x-freearc")
    ("avif" "image/avif")
    ("avi" "video/x-msvideo")
    ("azw" "application/vnd.amazon.ebook")
    ("bin" "application/octet-stream")
    ("bmp" "image/bmp")
    ("bz" "application/x-bzip")
    ("bz2" "application/x-bzip2")
    ("cda" "application/x-cdf")
    ("csh" "application/x-csh")
    ("css" "text/css")
    ("csv" "text/csv")
    ("doc" "application/msword")
    ("docx" "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
    ("eot" "application/vnd.ms-fontobject")
    ("epub" "application/epub+zip")
    ("gz" "application/gzip")
    ("gif" "image/gif")
    ("htm" "text/html")
    ("ico" "image/vnd.microsoft.icon")
    ("ics" "text/calendar")
    ("jar" "application/java-archive")
    ("jpeg" "image/jpeg")
    ("js" "text/javascript")
    ("json" "application/json")
    ("jsonld" "application/ld+json")
    ("mid" "audio/x-midi")
    ("mjs" "text/javascript")
    ("mp3" "audio/mpeg")
    ("mp4" "video/mp4")
    ("mpeg" "video/mpeg")
    ("mpkg" "application/vnd.apple.installer+xml")
    ("odp" "application/vnd.oasis.opendocument.presentation")
    ("ods" "application/vnd.oasis.opendocument.spreadsheet")
    ("odt" "application/vnd.oasis.opendocument.text")
    ("oga" "audio/ogg")
    ("ogv" "video/ogg")
    ("ogx" "application/ogg")
    ("opus" "audio/opus")
    ("otf" "font/otf")
    ("png" "image/png")
    ("pdf" "application/pdf")
    ("php" "application/x-httpd-php")
    ("ppt" "application/vnd.ms-powerpoint")
    ("pptx" "application/vnd.openxmlformats-officedocument.presentationml.presentation")
    ("rar" "application/vnd.rar")
    ("rtf" "application/rtf")
    ("sh" "application/x-sh")
    ("svg" "image/svg+xml")
    ("tar" "application/x-tar")
    ("tif" "image/tiff")
    ("ts" "video/mp2t")
    ("ttf" "font/ttf")
    ("txt" "text/plain")
    ("vsd" "application/vnd.visio")
    ("wav" "audio/wav")
    ("weba" "audio/webm")
    ("webm" "video/webm")
    ("webp" "image/webp")
    ("woff" "font/woff")
    ("woff2" "font/woff2")
    ("xhtml" "application/xhtml+xml")
    ("xls" "application/vnd.ms-excel")
    ("xlsx" "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
    ("xml" "application/xml")
    ("xul" "application/vnd.mozilla.xul+xml")
    ("zip" "application/zip")
    ("3gp" "audio/3gpp")
    ("3g2" "audio/3gpp2")
    ("7z" "application/x-7z-compressed")))


(defun ext->mimetype (ext)
  (second (assoc ext +extension->mimetype+ :test #'string-equal)))