;;;; 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.") ;;; 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) (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))) (defun expand-provision-app-option (app option value) (list 'setf (ecase option ((:desc :description) `(lazybones::app-description ,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)) (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 find-endpoint (app &optional (request *request*)) (find-endpoint-matching-key app (request-method request) (request-routekey 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 request-routekey (request) (url-path->request-routekey (request-path request))) (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)) (when (a:ends-with #\/ template) (warn "The proposed route ~s ends with a forward-slash (/), is this intended?" template)) (unless (eql #\/ (elt template 0)) (warn "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)) (if (request-authorized-p endpoint) (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 (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)) (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)) (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 (lambda ,lambda-list (setf (lazybones:response-header :content-type) (or ,content-type (lazybones::default-content-type ,the-app))) ,@real-body))))))) (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)))