content-negotiation is better described using OR method-combination

[specializable.git] / accept-specializer.lisp

diff --git a/accept-specializer.lisp b/accept-specializer.lisp
index f8d55638432ac53f2acfd454b6290ce6aa41613c..c08f5373a18d19b49ec1c8db18bfe9eb04c89978 100644 (file)
--- a/accept-specializer.lisp
+++ b/accept-specializer.lisp
@@ -43,6 +43,10 @@
         (and type-node (accept-node-q type-node))
         (accept-node-q accept-tree))))
 
+(defun q-ok (media-type accept-tree)
+  (let ((q (q media-type accept-tree)))
+    (and q (> q 0) q)))
+
 (defun insert (range q tree)
   (labels ((ensure-node (range tree)
              (cond
@@ -78,7 +82,7 @@
 \f
 ;;; FIXME: tiebreaker predicate (maybe defaulting to string<)?
 (defclass accept-specializer (extended-specializer)
-  ((media-type :initarg :media-type :reader media-type)))
+  ((media-type :initarg :media-type :type string :reader media-type)))
 (defmethod print-object ((o accept-specializer) s)
   (print-unreadable-object (o s :type t)
     (format s "~S" (media-type o))))
@@ -101,6 +105,7 @@
   (:metaclass sb-mop:funcallable-standard-class))
 
 (define-extended-specializer accept (gf arg)
+  (declare (ignore gf))
   (make-instance 'accept-specializer :media-type arg))
 (defmethod sb-pcl:unparse-specializer-using-class
     ((gf accept-generic-function) (specializer accept-specializer))
@@ -112,12 +117,12 @@
 (defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
   (make-instance 'accept-generalizer
                  :header (tbnl:header-in :accept arg)
-                 :next (class-of arg)))
+                 :next (call-next-method)))
 (defmethod generalizer-equal-hash-key
     ((gf accept-generic-function) (g accept-generalizer))
   `(accept-generalizer ,(header g)))
 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
-  (values (q (media-type s) (tree generalizer)) t))
+  (values (q-ok (media-type s) (tree generalizer)) t))
 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
   (values nil t))
 (defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
@@ -126,7 +131,7 @@
 (defmethod specializer-accepts-p ((specializer accept-specializer) obj)
   nil)
 (defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
-  (q (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
+  (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
 
 (defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
   (cond
@@ -168,7 +173,7 @@
                    (let ((request-specializer (car (sb-mop:method-specializers ,method))))
                      (when (typep request-specializer 'accept-specializer)
                        (setf *actual-content-type* (media-type request-specializer))))
-                   (call-method ,method ,@(and nexts `((,(transform nexts)))))))))
+                   (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
            (wrap (form)
              `(let ((*actual-content-type*))
                 (multiple-value-prog1
@@ -177,9 +182,35 @@
     (let ((form (if (or before after (rest primary))
                     `(multiple-value-prog1
                          (progn ,@(call-methods before)
-                                (call-method ,(transform primary)))
+                                (catch 'content-negotiation (call-method ,(transform primary))))
                        ,@(call-methods (reverse after)))
-                    `(call-method ,(transform primary)))))
+                    `(catch 'content-negotiation (call-method ,(transform primary))))))
+      (if around
+          (wrap `(call-method ,(first around)
+                              (,@(rest around) (make-method ,form))))
+          (wrap form)))))
+(define-method-combination content-negotiation/or ()
+  ((around (:around))
+   (primary () :required t))
+  (:arguments request)
+  (labels ((transform/1 (method)
+             `(make-method
+               (progn
+                 (let ((s (car (sb-mop:method-specializers ,method))))
+                   (when (typep s 'accept-specializer)
+                     (setf *actual-content-type* (media-type s))))
+                 (call-method ,method))))
+           (transform (primaries)
+             (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
+                     primaries))
+           (wrap (form)
+             `(let ((*actual-content-type*))
+                (multiple-value-prog1
+                    ,form
+                  (handle-content-type ,request)))))
+    (let ((form (if (rest primary)
+                    `(or ,@(transform primary))
+                    `(call-method ,(transform/1 (car primary))))))
       (if around
           (wrap `(call-method ,(first around)
                               (,@(rest around) (make-method ,form))))
@@ -188,9 +219,9 @@
 (defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
   (make-instance 'accept-generalizer
                  :header s
-                 :next (class-of s)))
+                 :next (call-next-method)))
 (defmethod specializer-accepts-p ((s accept-specializer) (string string))
-  (q (media-type s) (parse-accept-string string)))
+  (q-ok (media-type s) (parse-accept-string string)))
 
 (defmethod handle-content-type ((x tbnl:request))
   (setf (tbnl:content-type*) *actual-content-type*))
@@ -209,3 +240,29 @@
 (defmethod respond list ((s (accept "audio/mp3")))
   "audio/mp3")
 
+(defgeneric cn-test (request)
+  (:generic-function-class accept-generic-function)
+  (:method-combination content-negotiation))
+(defmethod cn-test ((request (accept "text/html")))
+  'html)
+(defmethod cn-test ((request (accept "text/plain")))
+  'plain)
+(defmethod cn-test ((request (accept "image/webp")))
+  'webp)
+(defmethod cn-test ((request (accept "audio/mp3")))
+  (call-next-method)
+  'mp3)
+(defmethod cn-test :after (request)
+  (print 'after))
+
+(defgeneric cn/or-test (request)
+  (:generic-function-class accept-generic-function)
+  (:method-combination content-negotiation/or))
+
+(defmethod cn/or-test or ((request (accept "audio/mp3")))
+  'mp3)
+(defmethod cn/or-test or ((request (accept "image/webp")))
+  'webp)
+(defmethod cn/or-test :around ((request t))
+  (print :around)
+  (call-next-method))