From: Christophe Rhodes Date: Mon, 16 Dec 2013 16:31:55 +0000 (+0000) Subject: finish implementing ACCEPT specializers X-Git-Tag: els2014-submission~21 X-Git-Url: http://christophe.rhodes.io/gitweb/?a=commitdiff_plain;h=bdc75e3e968861ffb821925bdf1626bcbd268777;p=specializable.git finish implementing ACCEPT specializers A handy example to do dispatch based on the Accept: header in HTTP requests. Includes a tricky method combination which in addition can set the Content-Type: header of the response. --- diff --git a/accept-specializer.lisp b/accept-specializer.lisp index 67d9d36..dee8a89 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) @@ -110,18 +75,137 @@ (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 :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) + (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 (class-of arg))) +(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)) +(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 (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)))) + (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) + (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))))) + +(defmethod generalizer-of-using-class ((gf accept-generic-function) (s string)) + (make-instance 'accept-generalizer + :header s + :next (class-of s))) +(defmethod specializer-accepts-p ((s accept-specializer) (string string)) + (q (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") +