\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))))
(: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))
(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)))
(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))))
+ (wrap form)))))
(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-ok (media-type s) (parse-accept-string string)))
'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))