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 insert (range q tree)
47 (labels ((ensure-node (range tree)
50 (t (ensure-node (cdr range)
51 (or (find (car range) (accept-node-children tree)
52 :key #'accept-node-name :test #'string=)
54 (make-accept-node :name (car range))
55 (accept-node-children tree)))))))))
56 (let ((node (ensure-node range tree)))
57 ;; we could choose different behaviour here
58 (setf (accept-node-q node) q))
61 (defun parse-accept-string (string)
62 (flet ((whitespacep (x)
63 (member x '(#\Space #\Tab))))
64 (let ((string (remove-if #'whitespacep string))
65 (result (make-accept-node :name nil)))
66 (cl-ppcre:do-register-groups (type subtype qp q)
67 ;; not desperately error-proof
68 ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
70 (setf q (float (+ (digit-char-p (char q 0))
71 (/ (parse-integer q :start 2)
72 (expt 10 (- (length q) 2))))))
74 (let ((range (and (string/= type "*")
75 (cons type (and (string/= subtype "*")
77 (insert range q result))))))
79 ;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
80 (defclass accept-specializer (extended-specializer)
81 ((media-type :initarg :media-type :reader media-type)))
82 (defmethod print-object ((o accept-specializer) s)
83 (print-unreadable-object (o s :type t)
84 (format s "~S" (media-type o))))
85 ;;; FIXME: would be cute to have sb-pcl:generalizer to inherit from.
86 ;;; Or maybe specializable:extended-generalizer could handle the NEXT
88 (defclass accept-generalizer ()
89 ((header :initarg :header :reader header)
91 (next :initarg :next :reader next)))
92 (defmethod print-object ((o accept-generalizer) s)
93 (print-unreadable-object (o s :type t)
94 (print-accept-tree (tree o) s)))
95 (defmethod tree ((x accept-generalizer))
96 (if (slot-boundp x 'tree)
98 (setf (slot-value x 'tree) (parse-accept-string (header x)))))
99 (defclass accept-generic-function (specializable-generic-function)
101 (:metaclass sb-mop:funcallable-standard-class))
103 (define-extended-specializer accept (gf arg)
104 (make-instance 'accept-specializer :media-type arg))
105 (defmethod sb-pcl:unparse-specializer-using-class
106 ((gf accept-generic-function) (specializer accept-specializer))
107 `(accept ,(media-type specializer)))
108 (defmethod sb-pcl::same-specializer-p
109 ((s1 accept-specializer) (s2 accept-specializer))
110 (string= (media-type s1) (media-type s2)))
112 (defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
113 (make-instance 'accept-generalizer
114 :header (tbnl:header-in :accept arg)
115 :next (class-of arg)))
116 (defmethod generalizer-equal-hash-key
117 ((gf accept-generic-function) (g accept-generalizer))
118 `(accept-generalizer ,(header g)))
119 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
120 (values (q (media-type s) (tree generalizer)) t))
121 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
123 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
124 (specializer-accepts-generalizer-p gf s (next generalizer)))
126 (defmethod specializer-accepts-p ((specializer accept-specializer) obj)
128 (defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
129 (q (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
131 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
133 ((string= (media-type s1) (media-type s2)) '=)
134 (t (let ((q1 (q (media-type s1) (tree generalizer)))
135 (q2 (q (media-type s2) (tree generalizer))))
140 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
142 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
144 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
145 (ecase (specializer< gf s2 s1 generalizer)
148 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
149 (specializer< gf s1 s2 (next g)))
151 (defvar *actual-content-type*)
152 (defgeneric handle-content-type (x))
153 (define-method-combination content-negotiation ()
156 (primary () :required t)
159 (labels ((call-methods (methods)
160 (mapcar #'(lambda (method)
161 `(call-method ,method))
163 (transform (primaries)
164 (let ((method (car primaries))
165 (nexts (cdr primaries)))
168 (let ((request-specializer (car (sb-mop:method-specializers ,method))))
169 (when (typep request-specializer 'accept-specializer)
170 (setf *actual-content-type* (media-type request-specializer))))
171 (call-method ,method ,@(and nexts `((,(transform nexts)))))))))
173 `(let ((*actual-content-type*))
174 (multiple-value-prog1
176 (handle-content-type ,request)))))
177 (let ((form (if (or before after (rest primary))
178 `(multiple-value-prog1
179 (progn ,@(call-methods before)
180 (call-method ,(transform primary)))
181 ,@(call-methods (reverse after)))
182 `(call-method ,(transform primary)))))
184 (wrap `(call-method ,(first around)
185 (,@(rest around) (make-method ,form))))
188 (defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
189 (make-instance 'accept-generalizer
192 (defmethod specializer-accepts-p ((s accept-specializer) (string string))
193 (q (media-type s) (parse-accept-string string)))
195 (defmethod handle-content-type ((x tbnl:request))
196 (setf (tbnl:content-type*) *actual-content-type*))
197 (defmethod handle-content-type ((x string))
198 (format t "~&Content-Type: ~A" *actual-content-type*))
200 (defgeneric respond (request)
201 (:generic-function-class accept-generic-function)
202 (:method-combination list))
203 (defmethod respond list (request)
205 (defmethod respond list ((s string))
207 (defmethod respond list ((s (accept "text/html")))
209 (defmethod respond list ((s (accept "audio/mp3")))