accept-specializer.lisp

   1 (in-package "SPECIALIZABLE")
   2
   3 (defstruct accept-node
   4   (name (error "missing name"))
   5   (children nil)
   6   (q nil))
   7 (defun print-accept-tree (tree stream)
   8   (let (*stack*)
   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)))
  14                (funcall fun node))
  15              (stringify (node)
  16                (case (length *stack*)
  17                  (0 "*/*")
  18                  (1 (format nil "~A/*" (accept-node-name node)))
  19                  (2 (format nil "~A/~A" (accept-node-name (car *stack*)) (accept-node-name node))))))
  20       (let ((first t))
  21         (walk
  22          (lambda (x)
  23            (let ((q (accept-node-q x)))
  24              (when q
  25                (format stream "~:[, ~;~]" first)
  26                (format stream "~A~:[;q=~A~;~]" (stringify x) (= q 1.0) q)
  27                (setf first nil))))
  28          tree)))))
  29 (defmethod print-object ((o accept-node) s)
  30   (if (accept-node-name o)
  31       (call-next-method)
  32       (pprint-logical-block (s nil)
  33         (print-unreadable-object (o s :type t)
  34           (print-accept-tree o s)))))
  35
  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))))
  45
  46 (defun q-ok (media-type accept-tree)
  47   (let ((q (q media-type accept-tree)))
  48     (and q (> q 0) q)))
  49
  50 (defun insert (range q tree)
  51   (labels ((ensure-node (range tree)
  52              (cond
  53                ((null range) tree)
  54                (t (ensure-node (cdr range)
  55                                (or (find (car range) (accept-node-children tree)
  56                                          :key #'accept-node-name :test #'string=)
  57                                    (car (push
  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))
  63     tree))
  64
  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)
  73         (if qp
  74             (setf q (float (+ (digit-char-p (char q 0))
  75                               (/ (parse-integer q :start 2)
  76                                  (expt 10 (- (length q) 2))))))
  77             (setf q 1.0))
  78         (let ((range (and (string/= type "*")
  79                           (cons type (and (string/= subtype "*")
  80                                           (list subtype))))))
  81           (insert range q result))))))
  82 \f
  83 ;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
  84 (defclass accept-specializer (extended-specializer)
  85   ((media-type :initarg :media-type :type string :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
  91 ;;; functionality?
  92 (defclass accept-generalizer ()
  93   ((header :initarg :header :reader header)
  94    (tree)
  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)
 101       (slot-value x 'tree)
 102       (setf (slot-value x 'tree) (parse-accept-string (header x)))))
 103 (defclass accept-generic-function (specializable-generic-function)
 104   ()
 105   (:metaclass sb-mop:funcallable-standard-class))
 106
 107 (define-extended-specializer accept (gf arg)
 108   (declare (ignore gf))
 109   (make-instance 'accept-specializer :media-type arg))
 110 (defmethod sb-pcl:unparse-specializer-using-class
 111     ((gf accept-generic-function) (specializer accept-specializer))
 112   `(accept ,(media-type specializer)))
 113 (defmethod sb-pcl::same-specializer-p
 114     ((s1 accept-specializer) (s2 accept-specializer))
 115   (string= (media-type s1) (media-type s2)))
 116
 117 (defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
 118   (make-instance 'accept-generalizer
 119                  :header (tbnl:header-in :accept arg)
 120                  :next (call-next-method)))
 121 (defmethod generalizer-equal-hash-key
 122     ((gf accept-generic-function) (g accept-generalizer))
 123   `(accept-generalizer ,(header g)))
 124 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
 125   (values (q-ok (media-type s) (tree generalizer)) t))
 126 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
 127   (values nil t))
 128 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
 129   (specializer-accepts-generalizer-p gf s (next generalizer)))
 130
 131 (defmethod specializer-accepts-p ((specializer accept-specializer) obj)
 132   nil)
 133 (defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
 134   (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
 135
 136 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
 137   (cond
 138     ((string= (media-type s1) (media-type s2)) '=)
 139     (t (let ((q1 (q (media-type s1) (tree generalizer)))
 140              (q2 (q (media-type s2) (tree generalizer))))
 141          (cond
 142            ((= q1 q2) '=)
 143            ((< q1 q2) '>)
 144            (t '<))))))
 145 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
 146   '<)
 147 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
 148   '>)
 149 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
 150   (ecase (specializer< gf s2 s1 generalizer)
 151     ((>) '<)
 152     ((<) '>)))
 153 (defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
 154   (specializer< gf s1 s2 (next g)))
 155 \f
 156 (defvar *actual-content-type*)
 157 (defgeneric handle-content-type (x))
 158 (define-method-combination content-negotiation ()
 159   ((around (:around))
 160    (before (:before))
 161    (primary () :required t)
 162    (after (:after)))
 163   (:arguments request)
 164   (labels ((call-methods (methods)
 165              (mapcar #'(lambda (method)
 166                          `(call-method ,method))
 167                      methods))
 168            (transform (primaries)
 169              (let ((method (car primaries))
 170                    (nexts (cdr primaries)))
 171                `(make-method
 172                  (progn
 173                    (let ((request-specializer (car (sb-mop:method-specializers ,method))))
 174                      (when (typep request-specializer 'accept-specializer)
 175                        (setf *actual-content-type* (media-type request-specializer))))
 176                    (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
 177            (wrap (form)
 178              `(let ((*actual-content-type*))
 179                 (multiple-value-prog1
 180                     ,form
 181                   (handle-content-type ,request)))))
 182     (let ((form (if (or before after (rest primary))
 183                     `(multiple-value-prog1
 184                          (progn ,@(call-methods before)
 185                                 (catch 'content-negotiation (call-method ,(transform primary))))
 186                        ,@(call-methods (reverse after)))
 187                     `(catch 'content-negotiation (call-method ,(transform primary))))))
 188       (if around
 189           (wrap `(call-method ,(first around)
 190                               (,@(rest around) (make-method ,form))))
 191           (wrap form)))))
 192 (define-method-combination content-negotiation/or ()
 193   ((around (:around))
 194    (primary () :required t))
 195   (:arguments request)
 196   (labels ((transform/1 (method)
 197              `(make-method
 198                (progn
 199                  (let ((s (car (sb-mop:method-specializers ,method))))
 200                    (when (typep s 'accept-specializer)
 201                      (setf *actual-content-type* (media-type s))))
 202                  (call-method ,method))))
 203            (transform (primaries)
 204              (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
 205                      primaries))
 206            (wrap (form)
 207              `(let ((*actual-content-type*))
 208                 (multiple-value-prog1
 209                     ,form
 210                   (handle-content-type ,request)))))
 211     (let ((form (if (rest primary)
 212                     `(or ,@(transform primary))
 213                     `(call-method ,(transform/1 (car primary))))))
 214       (if around
 215           (wrap `(call-method ,(first around)
 216                               (,@(rest around) (make-method ,form))))
 217           (wrap form)))))
 218
 219 (defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
 220   (make-instance 'accept-generalizer
 221                  :header s
 222                  :next (call-next-method)))
 223 (defmethod specializer-accepts-p ((s accept-specializer) (string string))
 224   (q-ok (media-type s) (parse-accept-string string)))
 225
 226 (defmethod handle-content-type ((x tbnl:request))
 227   (setf (tbnl:content-type*) *actual-content-type*))
 228 (defmethod handle-content-type ((x string))
 229   (format t "~&Content-Type: ~A" *actual-content-type*))
 230
 231 (defgeneric respond (request)
 232   (:generic-function-class accept-generic-function)
 233   (:method-combination list))
 234 (defmethod respond list (request)
 235   t)
 236 (defmethod respond list ((s string))
 237   'string)
 238 (defmethod respond list ((s (accept "text/html")))
 239   "text/html")
 240 (defmethod respond list ((s (accept "audio/mp3")))
 241   "audio/mp3")
 242
 243 (defgeneric cn-test (request)
 244   (:generic-function-class accept-generic-function)
 245   (:method-combination content-negotiation))
 246 (defmethod cn-test ((request (accept "text/html")))
 247   'html)
 248 (defmethod cn-test ((request (accept "text/plain")))
 249   'plain)
 250 (defmethod cn-test ((request (accept "image/webp")))
 251   'webp)
 252 (defmethod cn-test ((request (accept "audio/mp3")))
 253   (call-next-method)
 254   'mp3)
 255 (defmethod cn-test :after (request)
 256   (print 'after))
 257
 258 (defgeneric cn/or-test (request)
 259   (:generic-function-class accept-generic-function)
 260   (:method-combination content-negotiation/or))
 261
 262 (defmethod cn/or-test or ((request (accept "audio/mp3")))
 263   'mp3)
 264 (defmethod cn/or-test or ((request (accept "image/webp")))
 265   'webp)
 266 (defmethod cn/or-test :around ((request t))
 267   (print :around)
 268   (call-next-method))