supporting responses

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