From 887818ec9bcfcf288ed932a566ed6219f5b9f212 Mon Sep 17 00:00:00 2001 From: colin Date: Sat, 11 May 2024 12:05:54 -0700 Subject: Add: kitchensink example --- examples/dice-roller.lisp | 2 +- examples/kitchensink.lisp | 87 +++++++++++++++++++++++++++++++++++++++++++++++ src/endpoint.lisp | 21 +++++++----- src/package.lisp | 18 +++++++++- src/protocol.lisp | 6 +++- 5 files changed, 122 insertions(+), 12 deletions(-) create mode 100644 examples/kitchensink.lisp 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)) + " + + + + +") + +(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 "") + (format t "

hello ~a

" (wknd:get-cookie "name")) + (princ ""))) + +(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)) -- cgit v1.2.3