X-Git-Url: http://christophe.rhodes.io/gitweb/?a=blobdiff_plain;f=accept-specializer.lisp;h=c08f5373a18d19b49ec1c8db18bfe9eb04c89978;hb=d55ebbbcbd77023c799d8d95dce5d3772aec5841;hp=dee8a89d78feefc1eabce6a4fa552d2380c4f1e8;hpb=bdc75e3e968861ffb821925bdf1626bcbd268777;p=specializable.git diff --git a/accept-specializer.lisp b/accept-specializer.lisp index dee8a89..c08f537 100644 --- 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 @@ -65,7 +69,7 @@ (result (make-accept-node :name nil))) (cl-ppcre:do-register-groups (type subtype qp q) ;; not desperately error-proof - ("([a-z]*|\\*)/([a-z]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result) + ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result) (if qp (setf q (float (+ (digit-char-p (char q 0)) (/ (parse-integer q :start 2) @@ -78,7 +82,7 @@ ;;; 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))