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   (if (accept-node-name o)
  66       (call-next-method)
  67       (pprint-logical-block (s nil)
  68         (print-unreadable-object (o s :type t)
  69           (print-accept-tree o s)))))
  70
  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))))
  80
  81 (defun insert (range q tree)
  82   (labels ((ensure-node (range tree)
  83              (cond
  84                ((null range) tree)
  85                (t (ensure-node (cdr range)
  86                                (or (find (car range) (accept-node-children tree)
  87                                          :key #'accept-node-name :test #'string=)
  88                                    (car (push
  89                                          (make-accept-node :name (car range))
  90                                          (accept-node-children tree)))))))))
  91     (let ((node (ensure-node range tree)))
  92       ;; we could choose different behaviour here
  93       (setf (accept-node-q node) q))
  94     tree))
  95
  96 (defun parse-accept-string (string)
  97   (flet ((whitespacep (x)
  98            (member x '(#\Space #\Tab))))
  99     (let ((string (remove-if #'whitespacep string))
 100           (result (make-accept-node :name nil)))
 101       (cl-ppcre:do-register-groups (type subtype qp q)
 102           ;; not desperately error-proof
 103           ("([a-z]*|\\*)/([a-z]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
 104         (if qp
 105             (setf q (float (+ (digit-char-p (char q 0))
 106                               (/ (parse-integer q :start 2)
 107                                  (expt 10 (- (length q) 2))))))
 108             (setf q 1.0))
 109         (let ((range (and (string/= type "*")
 110                           (cons type (and (string/= subtype "*")
 111                                           (list subtype))))))
 112           (insert range q result))))))
 113
 114 (defclass accept-generic-function (specializable-generic-function)
 115   ()
 116   (:metaclass sb-mop:funcallable-standard-class))
 117
 118
 119
 120
 121 (defgeneric respond (request)
 122   (:method-combination content-negotiation)
 123   (:generic-function-class accept-generic-function))
 124 (defmethod respond :after (request)
 125   (print *actual-content-type*))
 126 (defmethod respond (request)
 127   t)