aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/endpoint.lisp21
-rw-r--r--src/package.lisp18
-rw-r--r--src/protocol.lisp6
3 files changed, 34 insertions, 11 deletions
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))