accept-specializer.lisp

   1 (in-package "SPECIALIZABLE")
   2
   3 (defvar *actual-content-type*)
   4
   5 (define-method-combination content-negotiation ()
   6   ((around (:around))
   7    (before (:before))
   8    (primary () :required t)
   9    (after (:after)))
  10   (:arguments request)
  11   (labels ((call-methods (methods)
  12              (mapcar #'(lambda (method)
  13                          `(call-method ,method))
  14                      methods))
  15            (transform (primaries)
  16              (let ((method (car primaries))
  17                    (nexts (cdr primaries)))
  18                `(make-method
  19                  (progn
  20                    (setf *actual-content-type* ,method)
  21                    (call-method ,method ,@(and nexts `((,(transform nexts)))))))))
  22            (wrap (form)
  23              `(let ((*actual-content-type*))
  24                 (multiple-value-prog1
  25                     ,form
  26                   (print ,request)))))
  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)))))
  33       (if around
  34           (wrap `(call-method ,(first around)
  35                               (,@(rest around) (make-method ,form))))
  36           (wrap form)))))
  37
  38 (defstruct accept-node
  39   (name (error "missing name"))
  40   (children nil)
  41   (q nil))
  42 (defun print-accept-tree (tree stream)
  43   (let (*stack*)
  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)))
  49                (funcall fun node))
  50              (stringify (node)
  51                (case (length *stack*)
  52                  (0 "*/*")
  53                  (1 (format nil "~A/*" (accept-node-name node)))
  54                  (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
  55       (let ((first t))
  56         (walk
  57          (lambda (x)
  58            (let ((q (accept-node-q x)))
  59              (when q
  60                (format stream "~:[, ~;~]" first)
  61                (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
  62                (setf first nil))))
  63          tree)))))
  64 (defmethod print-object ((o accept-node) s)
  65   (pprint-logical-block (s nil)
  66     (print-unreadable-object (o s :type t)
  67       (print-accept-tree o s))))
  68
  69 (defun q (media-type accept-tree)
  70   (let* ((pos (position #\/ media-type))
  71          (type (subseq media-type 0 pos))
  72          (subtype (subseq media-type (1+ pos)))
  73          (type-node (find type (accept-node-children accept-tree) :key #'accept-node-name :test #'string=))
  74          (subtype-node (and type-node (find subtype (accept-node-children type-node) :key #'accept-node-name :test #'string=))))
  75     (or (and subtype-node (accept-node-q subtype-node))
  76         (and type-node (accept-node-q type-node))
  77         (accept-node-q accept-tree))))
  78
  79 (defclass accept-generic-function (specializable-generic-function)
  80   ()
  81   (:metaclass sb-mop:funcallable-standard-class))
  82
  83
  84
  85
  86 (defgeneric respond (request)
  87   (:method-combination content-negotiation)
  88   (:generic-function-class accept-generic-function))
  89 (defmethod respond :after (request)
  90   (print *actual-content-type*))
  91 (defmethod respond (request)
  92   t)