X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=accept-specializer.lisp;h=c08f5373a18d19b49ec1c8db18bfe9eb04c89978;hp=99149a1ebd12e6caf33d16e37458de1407571175;hb=d55ebbbcbd77023c799d8d95dce5d3772aec5841;hpb=140cc1055c002dfdbc5e9c5bb994d9e6862b08de diff --git a/accept-specializer.lisp b/accept-specializer.lisp index 99149a1..c08f537 100644 --- a/accept-specializer.lisp +++ b/accept-specializer.lisp @@ -1,40 +1,5 @@ (in-package "SPECIALIZABLE") -(defvar *actual-content-type*) - -(define-method-combination content-negotiation () - ((around (:around)) - (before (:before)) - (primary () :required t) - (after (:after))) - (:arguments request) - (labels ((call-methods (methods) - (mapcar #'(lambda (method) - `(call-method ,method)) - methods)) - (transform (primaries) - (let ((method (car primaries)) - (nexts (cdr primaries))) - `(make-method - (progn - (setf *actual-content-type* ,method) - (call-method ,method ,@(and nexts `((,(transform nexts))))))))) - (wrap (form) - `(let ((*actual-content-type*)) - (multiple-value-prog1 - ,form - (print ,request))))) - (let ((form (if (or before after (rest primary)) - `(multiple-value-prog1 - (progn ,@(call-methods before) - (call-method ,(transform primary))) - ,@(call-methods (reverse after))) - `(call-method ,(transform primary))))) - (if around - (wrap `(call-method ,(first around) - (,@(rest around) (make-method ,form)))) - (wrap form))))) - (defstruct accept-node (name (error "missing name")) (children nil) @@ -62,9 +27,11 @@ (setf first nil)))) tree))))) (defmethod print-object ((o accept-node) s) - (pprint-logical-block (s nil) - (print-unreadable-object (o s :type t) - (print-accept-tree o s)))) + (if (accept-node-name o) + (call-next-method) + (pprint-logical-block (s nil) + (print-unreadable-object (o s :type t) + (print-accept-tree o s))))) (defun q (media-type accept-tree) (let* ((pos (position #\/ media-type)) @@ -76,17 +43,226 @@ (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 + ((null range) tree) + (t (ensure-node (cdr range) + (or (find (car range) (accept-node-children tree) + :key #'accept-node-name :test #'string=) + (car (push + (make-accept-node :name (car range)) + (accept-node-children tree))))))))) + (let ((node (ensure-node range tree))) + ;; we could choose different behaviour here + (setf (accept-node-q node) q)) + tree)) + +(defun parse-accept-string (string) + (flet ((whitespacep (x) + (member x '(#\Space #\Tab)))) + (let ((string (remove-if #'whitespacep string)) + (result (make-accept-node :name nil))) + (cl-ppcre:do-register-groups (type subtype qp q) + ;; not desperately error-proof + ("([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) + (expt 10 (- (length q) 2)))))) + (setf q 1.0)) + (let ((range (and (string/= type "*") + (cons type (and (string/= subtype "*") + (list subtype)))))) + (insert range q result)))))) + +;;; FIXME: tiebreaker predicate (maybe defaulting to string<)? +(defclass accept-specializer (extended-specializer) + ((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)))) +;;; FIXME: would be cute to have sb-pcl:generalizer to inherit from. +;;; Or maybe specializable:extended-generalizer could handle the NEXT +;;; functionality? +(defclass accept-generalizer () + ((header :initarg :header :reader header) + (tree) + (next :initarg :next :reader next))) +(defmethod print-object ((o accept-generalizer) s) + (print-unreadable-object (o s :type t) + (print-accept-tree (tree o) s))) +(defmethod tree ((x accept-generalizer)) + (if (slot-boundp x 'tree) + (slot-value x 'tree) + (setf (slot-value x 'tree) (parse-accept-string (header x))))) (defclass accept-generic-function (specializable-generic-function) () (: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)) + `(accept ,(media-type specializer))) +(defmethod sb-pcl::same-specializer-p + ((s1 accept-specializer) (s2 accept-specializer)) + (string= (media-type s1) (media-type s2))) +(defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request)) + (make-instance 'accept-generalizer + :header (tbnl:header-in :accept 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-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)) + (specializer-accepts-generalizer-p gf s (next generalizer))) +(defmethod specializer-accepts-p ((specializer accept-specializer) obj) + nil) +(defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request)) + (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 + ((string= (media-type s1) (media-type s2)) '=) + (t (let ((q1 (q (media-type s1) (tree generalizer))) + (q2 (q (media-type s2) (tree generalizer)))) + (cond + ((= q1 q2) '=) + ((< q1 q2) '>) + (t '<)))))) +(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer) + '<) +(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer) + '>) +(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer) + (ecase (specializer< gf s2 s1 generalizer) + ((>) '<) + ((<) '>))) +(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer)) + (specializer< gf s1 s2 (next g))) + +(defvar *actual-content-type*) +(defgeneric handle-content-type (x)) +(define-method-combination content-negotiation () + ((around (:around)) + (before (:before)) + (primary () :required t) + (after (:after))) + (:arguments request) + (labels ((call-methods (methods) + (mapcar #'(lambda (method) + `(call-method ,method)) + methods)) + (transform (primaries) + (let ((method (car primaries)) + (nexts (cdr primaries))) + `(make-method + (progn + (let ((request-specializer (car (sb-mop:method-specializers ,method)))) + (when (typep request-specializer 'accept-specializer) + (setf *actual-content-type* (media-type request-specializer)))) + (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts)))))))))) + (wrap (form) + `(let ((*actual-content-type*)) + (multiple-value-prog1 + ,form + (handle-content-type ,request))))) + (let ((form (if (or before after (rest primary)) + `(multiple-value-prog1 + (progn ,@(call-methods before) + (catch 'content-negotiation (call-method ,(transform primary)))) + ,@(call-methods (reverse after))) + `(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)))) + (wrap form))))) + +(defmethod generalizer-of-using-class ((gf accept-generic-function) (s string)) + (make-instance 'accept-generalizer + :header s + :next (call-next-method))) +(defmethod specializer-accepts-p ((s accept-specializer) (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*)) +(defmethod handle-content-type ((x string)) + (format t "~&Content-Type: ~A" *actual-content-type*)) (defgeneric respond (request) - (:method-combination content-negotiation) - (:generic-function-class accept-generic-function)) -(defmethod respond :after (request) - (print *actual-content-type*)) -(defmethod respond (request) + (:generic-function-class accept-generic-function) + (:method-combination list)) +(defmethod respond list (request) t) +(defmethod respond list ((s string)) + 'string) +(defmethod respond list ((s (accept "text/html"))) + "text/html") +(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))