From 0402a9147f726124ed79a892ce69587b0d7f8c71 Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Mon, 7 Feb 2022 13:46:10 -0600 Subject: supporting responses --- lazybones-hunchentoot.lisp | 43 +++++++++++++++++++++++++++++++++++++++++++ lazybones.lisp | 44 ++++++++++++++++++++++++++++++++++++++++---- package.lisp | 29 ++++++++++++++++++++++------- 3 files changed, 105 insertions(+), 11 deletions(-) diff --git a/lazybones-hunchentoot.lisp b/lazybones-hunchentoot.lisp index 1e62b85..8f9b604 100644 --- a/lazybones-hunchentoot.lisp +++ b/lazybones-hunchentoot.lisp @@ -57,10 +57,15 @@ keyword or a string and VALUE is a string." HEADER-NAME can be a keyword or a string." (h:header-in header-name request)) +(defun request-cookie (name &optional (request *request*)) + "Returns the cookie with NAME sent with the REQUEST" + (h:cookie-in name request)) + (defun request-method (&optional (request *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")) @@ -108,6 +113,44 @@ the value of the Content-Type request header." collect (alexandria:make-keyword k) collect value)) +;;; HTTP RESPONSE ACCESSORS + +(defun response-code (&optional (response *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 *response*)) + (setf (h:return-code response) code)) + +(defun resonse-header (name &optional (response *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 *response*)) + (setf (h:header-out name response) value)) + +(defun response-cookie (name &optional (response *response*)) + "Access the cookie with NAME in the response object." + (h:cookie-out name response)) + +(defun (setf response-cookie) (value name &optional (response *response*)) + (a:if-let (extant-cookie (assoc name (h:cookies-out response) :test #'string=)) + (setf (cdr extant-cookie) value) + (cadar (setf (h:cookies-out response) + (cons (cons name value) (h:cookies-out response)))))) + +(defun http-respond (code content) + (setf (response-code) code + (response-header :content-type) (or (response-header :content-type content-type) + (when (pathnamep content) + (h:mime-type content)) + (default-content-type *app*) + (error "Content Type Not Set"))) + (if (pathnamep content) + (h:handle-static-file content) + content)) + + ;;; Hunchentoot Acceptor Subclass (defclass lazybones-acceptor (h:acceptor) diff --git a/lazybones.lisp b/lazybones.lisp index d19afd2..785afb0 100644 --- a/lazybones.lisp +++ b/lazybones.lisp @@ -45,6 +45,15 @@ 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.") + (app-error-response-contents + :accessor app-error-response-contents + :initform nil + :documentation "an alist of (CODE CONTENT)") + (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))) @@ -258,18 +267,18 @@ any way to do it, hence NIL is returned." (appname method route (&key (auth nil) - (endpoint-class 'lazybones::endpoint) + (endpoint-class 'lazybones:endpoint) (endpoint-initargs nil) - (app-class 'lazybones::app) + (app-class 'lazybones:app) (app-initargs nil)) &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 (and (symbolp endpoint-class) (subtypep endpoint-class 'lazybones::endpoint)) + (assert (and (symbolp endpoint-class) (subtypep endpoint-class 'lazybones:endpoint)) () "ENDPOINT-CLASS must be a literal symbol naming a subclass of LAZYBONES::ENDPOINT") - (assert (and (symbolp app-class) (subtypep app-class 'lazybones::app)) + (assert (and (symbolp app-class) (subtypep app-class 'lazybones:app)) () "APP-CLASS must be a literal symbol naming a subclass of LAZYBONES::APP") (assert (member method +http-methods+) () @@ -300,3 +309,30 @@ making a new one if not." ,@endpoint-initargs)))))) + +;;; utilities + +(defun set-response-headers (&rest headers) + "Sets response headers for *RESPONSE*. Handy for setting many headers at once. + +E.g. +(set-response-headers + :content-type \"text/html\" + :content-length (length html-bytes))" + (loop for (name value . more) on headers by #'cddr + do (setf (response-header name *response*) value))) + + +(defun http-ok (content) + "Content should be a string, a byte-vector, or a pathname to a local +file. CONTENT-TYPE should be a MIME type string." + (http-respond 200 content)) + +(defun http-err (code &optional content) + "*APP*, *RESPONSE* and *REQUEST* should all be defined here." + (http-respond + code + (or content (default-error-response code)))) + +(defun default-error-response (code &optional (app *app*)) + (cdr (assoc code (app-error-response-contents app)))) diff --git a/package.lisp b/package.lisp index 278fd5f..4c56fd2 100644 --- a/package.lisp +++ b/package.lisp @@ -2,9 +2,7 @@ (defpackage #:lazybones.backend (:export - #:*request* - #:*response* - #:*app* + ;; request functions #:request-url #:request-path #:request-host @@ -16,16 +14,33 @@ #:request-header #:request-method #:request-body + #:request-cookie + ;; resposne functions + #:response-header + #:response-code + #:response-cookie + #:http-respond + ;; lifecycle functions #:install-app + #:uninstall-app #:start-server - #:stop-server - )) + #:stop-server)) (defpackage #:lazybones (:use #:cl #:lazybones.backend) (:local-nicknames (#:a #:alexandria) (#:re #:cl-ppcre)) (:export - #:run-endpoint - #:find-endpoint)) + #:*request* + #:*response* + #:*app* + #:app + #:endpoint + #:http-ok + #:http-err + #:defendpoint + #:install-app + #:uninstall-app + #:start-server + #:stop-server)) -- cgit v1.2.3