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
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
|
(in-package araneida)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *url-methods-seen* nil
"This holds a list of what url methods have been seen - so the defurlmethod macro knows
when/if to declare a companion function. Used at macrotime"))
(defvar *url-methods* nil
"Holds a list of (method-name type required-parameters key-parameters lambda) for each urlmethod.
Used at runtime to figure out which method to use, and stores the method itself.
Type is either :tainted or :untainted, and determines whether the values are tainted before being
handed over to the urlmethod.")
(defun method-method-name (x)
(first x))
(defun method-type (x)
(second x))
(defun method-function-parameters (x)
(third x))
(defun method-required-parameters (x)
(fourth x))
(defun method-key-parameters (x)
(fifth x))
(defun method-all-parameters (x)
(sixth x))
(defun method-lambda (x)
(seventh x))
;;;;;;;;;;;; Conditions
(define-condition urlmethod-error (serious-condition)
())
(define-condition urlmethod-compile-error (urlmethod-error)
())
(define-condition no-urlmethod (urlmethod-error)
((method-name :initarg :method-name :reader no-urlmethod-method-name)
(parameters :initarg :parameters :reader no-urlmethod-parameters))
(:report (lambda (condition stream)
(format stream "No urlmethod matched (~A ~@[~A~])"
(no-urlmethod-method-name condition)
(no-urlmethod-parameters condition))))
(:documentation "At compile time we can't tell whether or not a urlmethod call
will have a match. If the call satisfies no method constraints, this is signaled."))
(define-condition too-many-urlmethods-matched (urlmethod-error)
((matched-methods :initarg :matched-methods :reader too-many-urlmethods-matched-matched-methods)
(method-name :initarg :method-name :reader too-many-urlmethods-matched-method-name)
(parameters :initarg :parameters :reader too-many-urlmethods-matched-parameters))
(:report (lambda (condition stream)
(format stream "More than one urlmethod matched the call (~A ~@[~A~]). Methods matched: ~A"
(too-many-urlmethods-matched-method-name condition)
(too-many-urlmethods-matched-parameters condition)
(too-many-urlmethods-matched-matched-methods condition))))
(:documentation "If precendence does not yield one method from the methods which have satisfied constraints,
this is signaled."))
(define-condition urlmethod-unknown-keyword (urlmethod-compile-error)
((unknown :initarg :unknown :reader urlmethod-unknown-keyword-unknown)
(lambda-list :initarg :lambda-list :reader urlmethod-unknown-keyword-lambda-list))
(:report (lambda (condition stream)
(format stream "Unknown keyword ~A ~@[in lambda list ~A~]"
(urlmethod-unknown-keyword-unknown condition)
(urlmethod-unknown-keyword-lambda-list condition))))
(:documentation "Signaled when defurlparameter contains an unknown keyword"))
(define-condition urlmethod-function-parameter-mismatch (urlmethod-compile-error)
((other-methods-info :initarg :other-methods-info :reader urlmethod-function-parameter-mismatch-other-methods-info)
(parameters :initarg :parameters :reader urlmethod-function-parameter-mismatch-parameters))
(:report (lambda (condition stream)
(format stream "~A has a different number of function parameters from previously defined methods: ~A"
(urlmethod-function-parameter-mismatch-parameters condition)
(urlmethod-function-parameter-mismatch-other-methods-info condition))))
(:documentation "Function parameters must be constant across all urlmethods of the same name.
parameters refers to the parameters declared in this defurlmethod. other-methods-info refers to the
method-info of previously defined urlmethods of the same name."))
;;;;;;;;;;;; Functions
(defun satisfy-spec-p (spec value)
"Given a specialization, determine if the value meets that specialization"
(if (symbolp spec)
(not (zerop (length value))) ; if it's just a variable, just check to make sure the string isn't blank
(apply (first (second spec)) value (rest (second spec))))) ; otherwise it's a function call
(defun fulfills-specialization (required-specializations parameters)
"Given a list of required specializations, determine if the url alist passed (parameters) meets that specialization"
(if (null required-specializations)
t
(let* ((spec (car required-specializations))
(param-value (second (assoc (symbol-name (parameter-name-from-url-specialization spec))
parameters
:test #'string-equal))))
(if param-value
(if (satisfy-spec-p spec param-value)
(fulfills-specialization (rest required-specializations) parameters)
nil)
nil))))
(defun remove-not-greatest (elements key &key (max #'max) (min #'min))
"Removes all elements of list that are not equal to the highest return value of key over the list.
Returns the unremoved elements and nil if nothing was removed, t if anything was"
(let* ((key-list (mapcar key elements))
(greatest (apply max key-list))
(least (apply min key-list)))
(if (eql greatest least)
(values elements nil)
(values (remove-if (lambda (elt)
(not (eql greatest (funcall key elt))))
elements)
t))))
(defun unit-list-p (list)
"Returns true if list is a list of one element"
(and (consp list) (null (cdr list))))
(defun most-specific-method (methods)
(declare (type cons methods))
(if (unit-list-p methods)
methods
(let ((methods (remove-not-greatest methods (lambda (method) ; # required parameters
(length (method-required-parameters method))))))
(if (unit-list-p methods)
methods
(let ((methods (remove-not-greatest methods (lambda (method) ; # specialized required parameters
(length (remove-if (complement #'specialized-p)
(method-required-parameters method)))))))
(if (unit-list-p methods)
methods
(let ((methods (remove-not-greatest methods (lambda (method) ; # key parameters
(length (method-key-parameters method))))))
methods)))))))
(defun select-url-method (handler request-method request urlmethod-name)
"Given a handler, request-method (GET, POST, etc), request, and the name of the urlmethod, performs
specialization and calls the method"
(declare (type handler handler)
(symbol request-method)
(type request request)
(ignore handler request-method))
(let* ((urlparameters (mapcar (lambda (x)
(list (first x) (if (second x) (untaint #'identity (second x)) nil)))
(tainted-url-query-alist (request-url request)))) ; call tainted to shut up warnings
(matching-methods (remove-if (lambda (method-info)
(or (not (eql (method-method-name method-info) urlmethod-name))
(not (fulfills-specialization (method-required-parameters method-info) urlparameters))))
*url-methods*)))
(if (null matching-methods)
(error 'no-urlmethod :method-name urlmethod-name :parameters urlparameters)
(let ((msm (most-specific-method matching-methods)))
(if (> (length msm) 1)
(error 'too-many-urlmethods-matched :matched-methods msm :method-name urlmethod-name :parameters urlparameters)
(first msm))))))
(defun call-url-method (method-info handler request-method request function-parameter-values)
(let* ((tainted-parameters (tainted-url-query-alist (request-url request)))
(parameter-values (mapcar (lambda (x)
(let ((value (second (assoc x tainted-parameters :test #'string-equal))))
(if value
value
(let ((key-parameter (find x
(method-key-parameters method-info)
:key #'parameter-name-from-key-parameter)))
(if key-parameter
(taint (default-value-for-key-parameter key-parameter))
nil)))))
(remove-if (lambda (param)
(member param (method-function-parameters method-info)))
(method-all-parameters method-info)))))
(ecase (method-type method-info)
(:untainted (apply (method-lambda method-info) (list* handler request-method request
(append function-parameter-values
(mapcar (lambda (x) (if x (untaint #'identity x) nil)) parameter-values)))))
(:tainted (apply (method-lambda method-info) (list* handler request-method request
(append function-parameter-values
parameter-values)))))))
(defun specialized-p (parameter)
(consp parameter))
(defun defaulted-p (parameter)
(consp parameter))
(defun default-value-for-key-parameter (parameter)
(if (consp parameter)
(second parameter)
nil))
(defun parameter-name-from-url-specialization (place)
(if (symbolp place)
place
(first place)))
(defun parameter-name-from-key-parameter (place)
(if (consp place)
(first place)
place))
(defun equal-urlmethod-signature (signature-1 signature-2)
(equal (subseq signature-1 0 6)
(subseq signature-2 0 6)))
(defun extract-parameters-for-urlmethod (parameters)
(let ((function-parameters nil)
(require-parameters nil)
(key-parameters nil)
(all-parameters nil)
(current-elt :function))
(dolist (i parameters)
(if (and (symbolp i) (equal (elt (symbol-name i) 0) #\&))
(let ((iname (symbol-name i)))
(cond
((string-equal iname "&REQUIRE") (setf current-elt :require))
((string-equal iname "&KEY") (setf current-elt :key))
(t (error 'urlmethod-unknown-keyword :unknown iname :lambda-list parameters))))
(progn
(ecase current-elt
(:function (push i function-parameters))
(:require (push i require-parameters))
(:key (push i key-parameters)))
(push (parameter-name-from-url-specialization i) all-parameters))))
(values (reverse function-parameters)
(reverse require-parameters)
(reverse key-parameters)
(reverse all-parameters))))
(defun define-urlmethod-function (method-name handlersym methodsym requestsym parameters)
(unless (find method-name *url-methods-seen*)
(push method-name *url-methods-seen*)
(multiple-value-bind (function-parameters require-parameters key-parameters all-parameters) (extract-parameters-for-urlmethod parameters)
(declare (ignore require-parameters key-parameters all-parameters))
`(defun ,method-name (,handlersym ,methodsym ,requestsym ,@function-parameters)
(araneida::call-url-method (araneida::select-url-method ,handlersym ,methodsym ,requestsym ',method-name)
,handlersym ,methodsym ,requestsym (list ,@function-parameters))))))
(defun create-urlmethod (type method-name handlersym methodsym requestsym parameters body)
(multiple-value-bind (function-parameters require-parameters key-parameters all-parameters) (extract-parameters-for-urlmethod parameters)
(with-gensyms (method-info conflicting-signature-pos length-function-parameters methods-of-the-same-name)
`(let* ((,method-info (list
',method-name ,(ecase type (:tainted :tainted) (:untainted :untainted))
',function-parameters
',require-parameters ',key-parameters
',all-parameters (lambda (,handlersym ,methodsym ,requestsym ,@all-parameters)
,@body)))
(,conflicting-signature-pos (position-if (lambda (elt)
(araneida::equal-urlmethod-signature elt
,method-info))
araneida::*url-methods*))
(,length-function-parameters ,(length function-parameters))
(,methods-of-the-same-name (remove-if (lambda (method)
(not (eql (araneida::method-method-name method) ',method-name)))
araneida::*url-methods*)))
(unless (zerop (length ,methods-of-the-same-name))
(when (some (lambda (method)
(not (equal (length (araneida::method-function-parameters method)) ,length-function-parameters)))
,methods-of-the-same-name)
(error 'araneida::urlmethod-function-parameter-mismatch
:parameters ',parameters
:other-methods-info ',methods-of-the-same-name)))
(if ,conflicting-signature-pos
(setf (elt araneida::*url-methods* ,conflicting-signature-pos) ,method-info)
(pushnew ,method-info *url-methods*))))))
;FIXME: add specialization for methodsym
(defmacro defurlmethod (method-name (handlersym methodsym requestsym &rest parameters) &body body)
"Define a urlmehod. This is like a CLOS method, but the parameters are extracted from the url (eventually will work with POST as well)
The syntax is very similar to defmethod.
(defurlmethod method-name (handler-symbol method-symbol request-symbol [function-parameter...] [&require require-parameter...] [&key key-parameter...])
[docstring]
body)
*-symbol: names which will be bound to the handler, method, and request
function-parameter -- when the method is called like so (method-name handler method request a b c...), a b c are function-parameters
require-parameter: parameter-name -- requires that the parameter named be present. Parameter will be bound to this name
| (parameter-name (function [function-parameter...]) -- requires that parameter be present and that it satisfy
(apply #'function parameter-value function-parameters)
key-parameter: parameter-name -- bind the value of the parameter (if any) to this name. nil if no value
| (parameter-name parameter-default-value) -- binds the value to parameter name, or parameter-default-value if no value
Please note that parameter-name is matched to parameters without regard to case.
There are numerous examples in test-server.lisp
Precendence algorithm is as follows:
Given a list of methods that all satisfy the current call, return the most specific one(s).
The algorithm for this is a bit different than for standard generic methods.
(unimplemented) If any have a specialized handler, they take precedence over unspecialized
(unimplemented) Of specialized handlers, class precedence is as for standard CLOS
(unimplemented) Specialized request-method takes precedence over unspecialized
Methods with more required parameters take precedence over those with fewer
Methods with more specialized required parameters take precedence over those with fewer
Methods with more key parameters take precedence over those with fewer
Tainted methods take precedence over untainted"
`(progn
,(define-urlmethod-function method-name handlersym methodsym requestsym parameters)
,(create-urlmethod :untainted method-name handlersym methodsym requestsym parameters body)))
(defmacro deftaintedurlmethod (method-name (handlersym methodsym requestsym &rest parameters) &body body)
"Just like defurlmethod, except the parameter values will be tainted"
`(progn
,(define-urlmethod-function method-name handlersym methodsym requestsym parameters)
,(create-urlmethod :tainted method-name handlersym methodsym requestsym parameters body)))
|
