1 (in-package "SPECIALIZABLE")
3 (defvar *actual-content-type*)
5 (define-method-combination content-negotiation ()
8 (primary () :required t)
11 (labels ((call-methods (methods)
12 (mapcar #'(lambda (method)
13 `(call-method ,method))
15 (transform (primaries)
16 (let ((method (car primaries))
17 (nexts (cdr primaries)))
20 (setf *actual-content-type* ,method)
21 (call-method ,method ,@(and nexts `((,(transform nexts)))))))))
23 `(let ((*actual-content-type*))
27 (let ((form (if (or before after (rest primary))
28 `(multiple-value-prog1
29 (progn ,@(call-methods before)
30 (call-method ,(transform primary)))
31 ,@(call-methods (reverse after)))
32 `(call-method ,(transform primary)))))
34 (wrap `(call-method ,(first around)
35 (,@(rest around) (make-method ,form))))
38 (defstruct accept-node
39 (name (error "missing name"))
42 (defun print-accept-tree (tree stream)
44 (declare (special *stack*))
45 (labels ((walk (fun node)
46 (let ((*stack* (cons node *stack*)))
47 (declare (special *stack*))
48 (mapc (lambda (x) (walk fun x)) (accept-node-children node)))
51 (case (length *stack*)
53 (1 (format nil "~A/*" (accept-node-name node)))
54 (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
58 (let ((q (accept-node-q x)))
60 (format stream "~:[, ~;~]" first)
61 (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
64 (defmethod print-object ((o accept-node) s)
65 (if (accept-node-name o)
67 (pprint-logical-block (s nil)
68 (print-unreadable-object (o s :type t)
69 (print-accept-tree o s)))))
71 (defun q (media-type accept-tree)
72 (let* ((pos (position #\/ media-type))
73 (type (subseq media-type 0 pos))
74 (subtype (subseq media-type (1+ pos)))
75 (type-node (find type (accept-node-children accept-tree) :key #'accept-node-name :test #'string=))
76 (subtype-node (and type-node (find subtype (accept-node-children type-node) :key #'accept-node-name :test #'string=))))
77 (or (and subtype-node (accept-node-q subtype-node))
78 (and type-node (accept-node-q type-node))
79 (accept-node-q accept-tree))))
81 (defclass accept-generic-function (specializable-generic-function)
83 (:metaclass sb-mop:funcallable-standard-class))
88 (defgeneric respond (request)
89 (:method-combination content-negotiation)
90 (:generic-function-class accept-generic-function))
91 (defmethod respond :after (request)
92 (print *actual-content-type*))
93 (defmethod respond (request)