1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
(in-package #:weekend)
;;; CONDITIONS
(defvar *debugging* nil
"If T, the debugger will be evoked.")
(define-condition protocol-error (error)
((raw-request
:reader raw-request
:initform nil
:initarg :raw-request
:documentation "The server backend's request object, if available")
(class
:reader endpoint-class
:initform nil
:initarg :class
:documentation "The class registered to handle the raw-request.")
(note
:reader note
:initform nil
:initarg :note
:type (or null string))
(status-code
:reader status-code
:initform nil
:initarg :status-code
:type (or nil (integer 100 599))))
(:documentation "Conditions signalled during the request handling protocol."))
(defmethod status-code ((err error)) 500)
(define-condition cannot-authenticate (protocol-error) ()
(:default-initargs :status-code 401)
(:documentation "Signalled when a endpoint's AUTHENTICATE method returns NIL,
indicating that the user's identity is required but cannot be determined."))
(define-condition not-authorized (protocol-error) ()
(:default-initargs :status-code 403)
(:documentation "Signalled when an endpoint's AUTHORIZE method returns NIL, indiating
that the request has insufficient permissions to evoke the endpoint handler. "))
(define-condition bad-body-error (protocol-error)
((wrapped
:reader wrapped
:initarg :error
:initform nil
:documentation "A root error that may have caused this error to be signalled."))
(:default-initargs :status-code 400)
(:documentation "Signalled when the body of a request cannot be deserialized, for any reason.."))
(define-condition slot-required (protocol-error)
((mising-slot
:reader missing-slot
:initform nil
:initarg :slot))
(:default-initargs :status-code 400)
(:documentation "Signalled whenever a required slot is missing from a endpoint
instance object.")
(:report (lambda (c s)
(format s "HTTP ERROR ~a, SLOT-REQUIRED: ~a in ~a"
(status-code c)
(missing-slot c)
(endpoint-class c)))))
(define-condition not-found (protocol-error) ()
(:default-initargs :status-code 404))
(defgeneric protocol-error-result (err)
(:documentation
"The content and mimetype to returned to the client having encountered
an error.")
(:method ((err error)) (values nil nil)))
(defun abort-on-error (err)
"Assign a return code based on the type of error encountered and
immediately reply."
(setf (http:return-code*) (status-code err))
(multiple-value-bind (content type) (protocol-error-result err)
(cond ((and content type)
(setf (http:content-type*) type)
(http:abort-request-handler content))
(t
(http:abort-request-handler)))))
(defmethod http:acceptor-dispatch-request :around ((acceptor http:acceptor) request)
(handler-case (call-next-method)
(error (err)
(if *debugging*
(invoke-debugger err)
(abort-on-error err)))))
(defun protocol-error (error-class ep &rest kwargs)
(apply #'error
error-class
:raw-request (and (boundp 'http:*request*) http:*request*)
:class ep
kwargs))
(defun slot-required (ep slot)
"Signals a SLOT-REQUIRED condition"
(protocol-error 'slot-required ep :slot slot))
;;; HANDLER PROTOCOL
(defgeneric check-request-compliance (endpoint-instance-class)
(:documentation "This function is called before instances the endpoint class are
created; This occurrs before the HTTP request's body has been
read. All request headers are available for inspection.
This is meant to enforce higher-level or server-wide policies, such as
on the size of request bodies.")
(:method ((epclass symbol))
(check-request-compliance (find-class epclass)))
(:method ((epclass t))))
(defgeneric slot-value-mapper (endpoint-class initarg slot-value)
(:documentation "Values arrive from clients in all manner of ways: in a JSON body, in
query arguments, as form body posts. Weekend allows users to register
body parsers, which transform post bodies according to the request's
mimetype. However, sometimes this isn't good enough.
A value may require additional alteration before it fills an endpoint
slot.
SLOT-VALUE-MAPPER is specialized on endpoints, initarg names, and slot
value types to parse or transform values to be what they out to be for
a slot's declared type.
ENDPOINT-CLASS values MUST BE AN ENDPOINT CLASS.
INITARG values MUST BE A KEYWORD.")
(:method :around (endpoint (initarg t) value)
(assert (keywordp initarg) (initarg) "Initarg is not a keyword ~a"
initarg)
(call-next-method))
(:method (endpoint initarg value)
value))
(defgeneric authenticate (endpoint)
(:documentation "Returns a boolean. Any protected endpoint should implement
this. Called before handling, should be used to supply
user-identifying data to the endpoint instance that might be needed by
the handle function.")
(:method ((ep t)) t))
(defgeneric authorize (endpoint)
(:documentation "Returns a boolean. Any endpoint requiring special ownership
permissions should implement this. Called before handling and after
authenticate.")
(:method ((ep t)) t))
(defgeneric handle (endpoint)
(:documentation "The beef of the endpoint handling protocol.
_(__)_ V
'-e e -'__,--.__)
(o_o) )
\. /___. |
||| _)/_)/
//_(/_(/_(
By the time this has been called, both AUTHENTICATE and AUTHORIZE have
been called. This method can be defined with the assumption that any
work done by AUTHORIZE and AUTHENTICATE has been accomplished
successfully.
This method should return data to be sent back to the client and
MUST be implemented for every endpoint class.")
(:method :before ((endpoint t))
;; The default before method checks that the endpoint is
;; authenticated, authorized, default, each of these is T.
(unless (authenticate endpoint)
(protocol-error 'cannot-authenticate endpoint))
(unless (authorize endpoint)
(protocol-error 'not-authorized endpoint))))
;;; HANDLER TOOLS
(defun not-found (ep)
"Signals a NOT-FOUND condition. Usually called within HANDLE or
AUTHORIZE while handling endpoint-class instance EP."
(protocol-error 'not-found ep))
(defun redirect (url)
"Redirect to URL."
(http:redirect url :code http:+http-see-other+))
(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))
(defun get-header (name)
"Returns the string value of the header named NAME, which can be a
string or keyword."
(http:header-in* name))
(define-condition request-error (error)
((content :reader error-content :initarg :content :initform "Bad Request")
(mimetype :reader error-content-mimetype :initarg :mimetype :initform "text/plain")
(code :reader status-code :initarg :code :initform 400)))
(defmethod protocol-error-result ((err request-error))
(values (error-content err) (error-content-mimetype err)))
(defun err (&key (code 400) (content "Bad Request") (mimetype "text/plain"))
"Signal an error and abort request."
(error 'request-error :code code :content content :mimetype mimetype))
(defun set-response-type (mimetype)
"Set the Content-Type header of the response."
(setf (http:content-type*) mimetype))
|
