From 887818ec9bcfcf288ed932a566ed6219f5b9f212 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 11 May 2024 12:05:54 -0700
Subject: Add: kitchensink example

---
 src/endpoint.lisp | 21 ++++++++++++---------
 src/package.lisp  | 18 +++++++++++++++++-
 src/protocol.lisp |  6 +++++-
 3 files changed, 34 insertions(+), 11 deletions(-)

(limited to 'src')

diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index 73aaa6f..9064c9f 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -93,8 +93,8 @@ keyword arguments to make-instance for CLASS."
    (content-type
     :reader content-type
     :initarg :content-type
-    :initform (error "CONTENT-TYPE required")
-    :type string
+    :initform nil
+    :type (or null string)
     :documentation
     "The content-type the handling of this request returns to the requesting client."))
   (:documentation "Metaclass for all request types."))
@@ -153,8 +153,8 @@ and application/x-www-form-urlencoded and stores them as an alist in
 the request's POST-PARAMETERS slot."
   (let ((header (or type (http:header-in* :content-type))))
     (when (stringp header) 
-      (loop for prefix in +hunchentoot-pre-decoded-content-types+
-              thereis (a:starts-with-subseq prefix header)))))
+      (loop :for prefix :in +hunchentoot-pre-decoded-content-types+
+            :thereis (a:starts-with-subseq prefix header)))))
 
 (defvar *mimetype-parsers*
   (make-hash-table :test #'equal))
@@ -234,15 +234,14 @@ extractors." part))))
 (defun check-endpoint-class (class)
   "Signals an error if any slot values are malformed. 
 
-Good for indicating that you've got a  bonkers class option syntax"
+Good for indicating that you've got a bonkers class option syntax"
   (assert (slot-boundp class 'route) (class) "ROUTE must be bound")
-  (with-slots
-        (route extractors method want-body-stream content-type)
+  (with-slots (route extractors method want-body-stream content-type)
       class
     (check-type route string "a regex STRING.")
     (check-type method http-method "an HTTP-METHOD keyword")
     (check-type want-body-stream boolean "a BOOLEAN")
-    (check-type content-type string "a STRING mimetype")
+    (check-type content-type (or null string) "a STRING mimetype")
     (loop
       :with initargs := (class-initargs class)
       :for ex :in extractors
@@ -367,7 +366,7 @@ the ;."
         (content-type
           (content-type class)))
     (lambda ()
-      (setf (http:content-type*) (concatenate 'string content-type "; charset=utf-8"))
+      (setf (http:content-type*) content-type)
       (handle (instantiate-endpoint class init-slots)))))
 
 (defun create-class-dispatcher (class)
@@ -408,6 +407,10 @@ the ;."
 ;;; TOOLS
 
 (defun route-to (class &rest kwargs)
+  "Build a route to the endpoint CLASS using keyword argument
+constructors KWARGS for that class.  CLASS must be either a symbol or
+a class instance, and the named class must (obviously) be a subclass
+of ENDPOINT."
   (funcall (route-builder (if (symbolp class) (find-class class) class)) kwargs))
 
 
diff --git a/src/package.lisp b/src/package.lisp
index a9ab69f..e8f56b3 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -2,17 +2,33 @@
 
 (defpackage #:weekend
   (:use #:cl #:flatbind)
+  (:import-from
+   #:hunchentoot
+   #:mime-type
+   #:handle-static-file
+   #:set-cookie)
   (:local-nicknames
    (#:http #:hunchentoot)
    (#:a #:alexandria-2)
    (#:mop #:closer-mop))
   (:export
    ;; HANDLER PROTOCOL
-   #:authenticate
+   #:authenticate                       
    #:authorize
    #:handle
    #:not-found
    #:slot-required
+   #:not-found
+   #:redirect
+   #:endpoint-redirect
+   #:route-to
+   #:get-cookie
+
+   ;; re-exports
+   #:mime-type
+   #:handle-static-file
+   #:set-cookie
+
 
    ;; METACLASS
    #:endpoint
diff --git a/src/protocol.lisp b/src/protocol.lisp
index d25aa22..300195f 100644
--- a/src/protocol.lisp
+++ b/src/protocol.lisp
@@ -153,8 +153,12 @@ AUTHORIZE while handling endpoint-class instance EP."
   "Redirect to URL."
   (http:redirect url :code http:+http-see-other+))
 
-(defun redirect-to (class &rest kwargs)
+(defun endpoint-redirect (class &rest kwargs)
   "Redirect to another endpoint. CLASS can be either a symbol or a
    class. KWARGS is a PLIST of keyword arguments supplied to the
    CLASS' route builder function."
   (redirect (apply #'route-to class kwargs)))
+
+(defun get-cookie (name)
+  "Returns the cookie with name NAME the actively"
+  (http:cookie-in name))
-- 
cgit v1.2.3