1 (in-package "SPECIALIZABLE")
4 (name (error "missing name"))
7 (defun print-accept-tree (tree stream)
9 (declare (special *stack*))
10 (labels ((walk (fun node)
11 (let ((*stack* (cons node *stack*)))
12 (declare (special *stack*))
13 (mapc (lambda (x) (walk fun x)) (accept-node-children node)))
16 (case (length *stack*)
18 (1 (format nil "~A/*" (accept-node-name node)))
19 (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
23 (let ((q (accept-node-q x)))
25 (format stream "~:[, ~;~]" first)
26 (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
29 (defmethod print-object ((o accept-node) s)
30 (if (accept-node-name o)
32 (pprint-logical-block (s nil)
33 (print-unreadable-object (o s :type t)
34 (print-accept-tree o s)))))
36 (defun q (media-type accept-tree)
37 (let* ((pos (position #\/ media-type))
38 (type (subseq media-type 0 pos))
39 (subtype (subseq media-type (1+ pos)))
40 (type-node (find type (accept-node-children accept-tree) :key #'accept-node-name :test #'string=))
41 (subtype-node (and type-node (find subtype (accept-node-children type-node) :key #'accept-node-name :test #'string=))))
42 (or (and subtype-node (accept-node-q subtype-node))
43 (and type-node (accept-node-q type-node))
44 (accept-node-q accept-tree))))
46 (defun q-ok (media-type accept-tree)
47 (let ((q (q media-type accept-tree)))
50 (defun insert (range q tree)
51 (labels ((ensure-node (range tree)
54 (t (ensure-node (cdr range)
55 (or (find (car range) (accept-node-children tree)
56 :key #'accept-node-name :test #'string=)
58 (make-accept-node :name (car range))
59 (accept-node-children tree)))))))))
60 (let ((node (ensure-node range tree)))
61 ;; we could choose different behaviour here
62 (setf (accept-node-q node) q))
65 (defun parse-accept-string (string)
66 (flet ((whitespacep (x)
67 (member x '(#\Space #\Tab))))
68 (let ((string (remove-if #'whitespacep string))
69 (result (make-accept-node :name nil)))
70 (cl-ppcre:do-register-groups (type subtype qp q)
71 ;; not desperately error-proof
72 ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
74 (setf q (float (+ (digit-char-p (char q 0))
75 (/ (parse-integer q :start 2)
76 (expt 10 (- (length q) 2))))))
78 (let ((range (and (string/= type "*")
79 (cons type (and (string/= subtype "*")
81 (insert range q result))))))
83 ;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
84 (defclass accept-specializer (extended-specializer)
85 ((media-type :initarg :media-type :type string :reader media-type)))
86 (defmethod print-object ((o accept-specializer) s)
87 (print-unreadable-object (o s :type t)
88 (format s "~S" (media-type o))))
89 ;;; FIXME: would be cute to have sb-pcl:generalizer to inherit from.
90 ;;; Or maybe specializable:extended-generalizer could handle the NEXT
92 (defclass accept-generalizer ()
93 ((header :initarg :header :reader header)
95 (next :initarg :next :reader next)))
96 (defmethod print-object ((o accept-generalizer) s)
97 (print-unreadable-object (o s :type t)
98 (print-accept-tree (tree o) s)))
99 (defmethod tree ((x accept-generalizer))
100 (if (slot-boundp x 'tree)
102 (setf (slot-value x 'tree) (parse-accept-string (header x)))))
103 (defclass accept-generic-function (specializable-generic-function)
105 (:metaclass sb-mop:funcallable-standard-class))
107 (define-extended-specializer accept (gf arg)
108 (declare (ignore gf))
109 (make-instance 'accept-specializer :media-type arg))
110 (defmethod sb-pcl:unparse-specializer-using-class
111 ((gf accept-generic-function) (specializer accept-specializer))
112 `(accept ,(media-type specializer)))
113 (defmethod sb-pcl::same-specializer-p
114 ((s1 accept-specializer) (s2 accept-specializer))
115 (string= (media-type s1) (media-type s2)))
117 (defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
118 (make-instance 'accept-generalizer
119 :header (tbnl:header-in :accept arg)
120 :next (call-next-method)))
121 (defmethod generalizer-equal-hash-key
122 ((gf accept-generic-function) (g accept-generalizer))
123 `(accept-generalizer ,(header g)))
124 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
125 (values (q-ok (media-type s) (tree generalizer)) t))
126 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
128 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
129 (specializer-accepts-generalizer-p gf s (next generalizer)))
131 (defmethod specializer-accepts-p ((specializer accept-specializer) obj)
133 (defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
134 (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
136 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
138 ((string= (media-type s1) (media-type s2)) '=)
139 (t (let ((q1 (q (media-type s1) (tree generalizer)))
140 (q2 (q (media-type s2) (tree generalizer))))
145 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
147 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
149 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
150 (ecase (specializer< gf s2 s1 generalizer)
153 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
154 (specializer< gf s1 s2 (next g)))
156 (defvar *actual-content-type*)
157 (defgeneric handle-content-type (x))
158 (define-method-combination content-negotiation ()
161 (primary () :required t)
164 (labels ((call-methods (methods)
165 (mapcar #'(lambda (method)
166 `(call-method ,method))
168 (transform (primaries)
169 (let ((method (car primaries))
170 (nexts (cdr primaries)))
173 (let ((request-specializer (car (sb-mop:method-specializers ,method))))
174 (when (typep request-specializer 'accept-specializer)
175 (setf *actual-content-type* (media-type request-specializer))))
176 (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
178 `(let ((*actual-content-type*))
179 (multiple-value-prog1
181 (handle-content-type ,request)))))
182 (let ((form (if (or before after (rest primary))
183 `(multiple-value-prog1
184 (progn ,@(call-methods before)
185 (catch 'content-negotiation (call-method ,(transform primary))))
186 ,@(call-methods (reverse after)))
187 `(catch 'content-negotiation (call-method ,(transform primary))))))
189 (wrap `(call-method ,(first around)
190 (,@(rest around) (make-method ,form))))
192 (define-method-combination content-negotiation/or ()
194 (primary () :required t))
196 (labels ((transform/1 (method)
199 (let ((s (car (sb-mop:method-specializers ,method))))
200 (when (typep s 'accept-specializer)
201 (setf *actual-content-type* (media-type s))))
202 (call-method ,method))))
203 (transform (primaries)
204 (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
207 `(let ((*actual-content-type*))
208 (multiple-value-prog1
210 (handle-content-type ,request)))))
211 (let ((form (if (rest primary)
212 `(or ,@(transform primary))
213 `(call-method ,(transform/1 (car primary))))))
215 (wrap `(call-method ,(first around)
216 (,@(rest around) (make-method ,form))))
219 (defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
220 (make-instance 'accept-generalizer
222 :next (call-next-method)))
223 (defmethod specializer-accepts-p ((s accept-specializer) (string string))
224 (q-ok (media-type s) (parse-accept-string string)))
226 (defmethod handle-content-type ((x tbnl:request))
227 (setf (tbnl:content-type*) *actual-content-type*))
228 (defmethod handle-content-type ((x string))
229 (format t "~&Content-Type: ~A" *actual-content-type*))
231 (defgeneric respond (request)
232 (:generic-function-class accept-generic-function)
233 (:method-combination list))
234 (defmethod respond list (request)
236 (defmethod respond list ((s string))
238 (defmethod respond list ((s (accept "text/html")))
240 (defmethod respond list ((s (accept "audio/mp3")))
243 (defgeneric cn-test (request)
244 (:generic-function-class accept-generic-function)
245 (:method-combination content-negotiation))
246 (defmethod cn-test ((request (accept "text/html")))
248 (defmethod cn-test ((request (accept "text/plain")))
250 (defmethod cn-test ((request (accept "image/webp")))
252 (defmethod cn-test ((request (accept "audio/mp3")))
255 (defmethod cn-test :after (request)
258 (defgeneric cn/or-test (request)
259 (:generic-function-class accept-generic-function)
260 (:method-combination content-negotiation/or))
262 (defmethod cn/or-test or ((request (accept "audio/mp3")))
264 (defmethod cn/or-test or ((request (accept "image/webp")))
266 (defmethod cn/or-test :around ((request t))