Add: kitchensink example

author: colin <colin@cicadas.surf> 2024-05-11 12:05:54 -0700
committer: colin <colin@cicadas.surf> 2024-05-11 12:05:54 -0700
commit: 887818ec9bcfcf288ed932a566ed6219f5b9f212 (patch)
tree: 5d6797c148d09a3f919eda86a5b7fe87c7bfb86c
parent: 0ed31297b4ed67ac86f683b4806acbfab73190ec (diff)
5 files changed, 122 insertions, 12 deletions
diff --git a/examples/dice-roller.lisp b/examples/dice-roller.lisp
index 3cd6ac3..d87faf4 100644
--- a/examples/dice-roller.lisp
+++ b/examples/dice-roller.lisp
@@ -27,7 +27,7 @@
   (:extractors (:rolls parse-integer) (:sides parse-integer))
   (:content-type . "text/plain"))
 
-(defmethod handle ((req roller))
+(defmethod wknd::handle ((req roller))
   (with-slots (rolls sides) req
     (format nil "~ad~a ... rolled a ~a"
             rolls sides
diff --git a/examples/kitchensink.lisp b/examples/kitchensink.lisp
new file mode 100644
index 0000000..788334d
--- /dev/null
+++ b/examples/kitchensink.lisp
@@ -0,0 +1,87 @@
+(defpackage #:kitchensink
+  (:use #:cl)
+  (:local-nicknames
+   (#:wknd #:weekend)))
+
+(in-package #:kitchensink)
+
+(defparameter +fname+ "([^/]+)"
+  "Match any ole character except /")
+
+(defclass file ()
+  ((name
+    :reader name
+    :initarg :name
+    :initform (wknd::slot-required 'file 'name)))
+  (:documentation "Servies files in the weekend/examples dir.")
+  (:metaclass wknd::endpoint)
+  (:method . :get)
+  (:route-parts "file" +fname+)
+  (:extractors :name))
+
+(defun file-in-examples-dir (name)
+  (merge-pathnames
+   name
+   (asdf:system-relative-pathname 'weekend "examples/")))
+
+(defmethod wknd::handle ((req file))
+  (let ((file (file-in-examples-dir (name req))))
+    (unless (uiop:file-exists-p file)
+      (wknd::not-found req))
+    (wknd:handle-static-file
+     file
+     (or (wknd:mime-type file) "text/plain"))))
+
+(defvar *identified-persons* nil)
+
+(defclass identify-form ()
+  ()
+  (:documentation "Page to serve an identify form")
+  (:metaclass wknd::endpoint)
+  (:method . :get)
+  (:route-parts "identify")
+  (:content-type . "text/html"))
+
+(defmethod wknd::handle ((req identify-form))
+  "<html>
+<head></head>
+<body>
+<form method='POST' action='/identify'>
+<input name='name' placeholder='name'/>
+</form>
+</body>
+</html>")
+
+(defclass hello ()
+  ()
+  (:documentation "A Page that just says hello.")
+  (:metaclass wknd:endpoint)
+  (:method . :get)
+  (:route-parts "hello")
+  (:content-type . "text/html"))
+
+(defmethod wknd:authenticate ((req hello))
+  (or (plusp (length (wknd:get-cookie "name")))
+      (wknd:endpoint-redirect 'identify-form)))
+
+(defmethod wknd::handle ((req hello))
+  (with-output-to-string (*standard-output*)
+    (princ "<html><head></head><body>")
+    (format t "<p>hello ~a</p>" (wknd:get-cookie "name"))
+    (princ "</body></html>")))
+
+(defclass identify ()
+  ((name :reader name :initarg :name :type string))
+  (:metaclass wknd::endpoint)
+  (:method . :post)
+  (:route-parts "identify"))
+
+(defmethod wknd::handle ((req identify))
+  (wknd:set-cookie "name" :value (name req))
+  (wknd:endpoint-redirect 'hello))
+
+(defvar *server* (make-instance 'hunchentoot:easy-acceptor
+                   :port 8888))
+
+(hunchentoot:start *server*)
+
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))
author	colin <colin@cicadas.surf>	2024-05-11 12:05:54 -0700
committer	colin <colin@cicadas.surf>	2024-05-11 12:05:54 -0700
commit	887818ec9bcfcf288ed932a566ed6219f5b9f212 (patch)
tree	5d6797c148d09a3f919eda86a5b7fe87c7bfb86c
parent	0ed31297b4ed67ac86f683b4806acbfab73190ec (diff)