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 :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 (make-instance 'accept-specializer :media-type arg))
109 (defmethod sb-pcl:unparse-specializer-using-class
110 ((gf accept-generic-function) (specializer accept-specializer))
111 `(accept ,(media-type specializer)))
112 (defmethod sb-pcl::same-specializer-p
113 ((s1 accept-specializer) (s2 accept-specializer))
114 (string= (media-type s1) (media-type s2)))
116 (defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
117 (make-instance 'accept-generalizer
118 :header (tbnl:header-in :accept arg)
119 :next (class-of arg)))
120 (defmethod generalizer-equal-hash-key
121 ((gf accept-generic-function) (g accept-generalizer))
122 `(accept-generalizer ,(header g)))
123 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
124 (values (q-ok (media-type s) (tree generalizer)) t))
125 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
127 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
128 (specializer-accepts-generalizer-p gf s (next generalizer)))
130 (defmethod specializer-accepts-p ((specializer accept-specializer) obj)
132 (defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
133 (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
135 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
137 ((string= (media-type s1) (media-type s2)) '=)
138 (t (let ((q1 (q (media-type s1) (tree generalizer)))
139 (q2 (q (media-type s2) (tree generalizer))))
144 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
146 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
148 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
149 (ecase (specializer< gf s2 s1 generalizer)
152 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
153 (specializer< gf s1 s2 (next g)))
155 (defvar *actual-content-type*)
156 (defgeneric handle-content-type (x))
157 (define-method-combination content-negotiation ()
160 (primary () :required t)
163 (labels ((call-methods (methods)
164 (mapcar #'(lambda (method)
165 `(call-method ,method))
167 (transform (primaries)
168 (let ((method (car primaries))
169 (nexts (cdr primaries)))
172 (let ((request-specializer (car (sb-mop:method-specializers ,method))))
173 (when (typep request-specializer 'accept-specializer)
174 (setf *actual-content-type* (media-type request-specializer))))
175 (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
177 `(let ((*actual-content-type*))
178 (multiple-value-prog1
180 (handle-content-type ,request)))))
181 (let ((form (if (or before after (rest primary))
182 `(multiple-value-prog1
183 (progn ,@(call-methods before)
184 (catch 'content-negotiation (call-method ,(transform primary))))
185 ,@(call-methods (reverse after)))
186 `(catch 'content-negotiation (call-method ,(transform primary))))))
188 (wrap `(call-method ,(first around)
189 (,@(rest around) (make-method ,form))))
192 (defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
193 (make-instance 'accept-generalizer
196 (defmethod specializer-accepts-p ((s accept-specializer) (string string))
197 (q-ok (media-type s) (parse-accept-string string)))
199 (defmethod handle-content-type ((x tbnl:request))
200 (setf (tbnl:content-type*) *actual-content-type*))
201 (defmethod handle-content-type ((x string))
202 (format t "~&Content-Type: ~A" *actual-content-type*))
204 (defgeneric respond (request)
205 (:generic-function-class accept-generic-function)
206 (:method-combination list))
207 (defmethod respond list (request)
209 (defmethod respond list ((s string))
211 (defmethod respond list ((s (accept "text/html")))
213 (defmethod respond list ((s (accept "audio/mp3")))
216 (defgeneric cn-test (request)
217 (:generic-function-class accept-generic-function)
218 (:method-combination content-negotiation))
219 (defmethod cn-test ((request (accept "text/html")))
221 (defmethod cn-test ((request (accept "text/plain")))
223 (defmethod cn-test ((request (accept "image/webp")))
225 (defmethod cn-test ((request (accept "audio/mp3")))
228 (defmethod cn-test :after (request)