Re: Header function

On Jan 13, 2005, at 5:45 PM, Martin Simmons wrote:

>>>>>> On Thu, 13 Jan 2005 12:50:18 +0000, David Johnson-Davies 
>>>>>> <[email protected]> said:
>
>   David> Can anyone help with the following query?
>
>   David> I want to discover when a URL is called with a HEAD method. 
> I've tried
>   David> supplying a header-function argument to export-url with the 
> following:
>
>   David> (export-url "/test.html"
>   David>     :computed
>   David>     :response-function #'serve-page
>   David>     :header-function #'(lambda (url) (print "HEAD call") 
> :html)
>   David>     :public t)
>
>   David> This gives the error:
>
>   David> Error: Arguments don't match lambda list..
>
>   David> Any suggestions welcomed.
>
> It is usually a good idea to say which version of which software you 
> are
> using!
>
> In CL-HTTP 70.190 at least, it looks like a bug -- try changing this
> definition in server/url.lisp:
>
> (defmethod initialize-specialization ((url http-computed-url) class 
> init-args)
>   (with-class-change-for-initialize-specialization (url class 
> init-args)
>     (destructuring-bind (response-function &optional header-function) 
> init-args
>       (setf (response-function url) response-function
>             (header-function url) header-function)
>       url)))
>
> to read:
>
> (defmethod initialize-specialization ((url http-computed-url) class 
> init-args)
>   (with-class-change-for-initialize-specialization (url class 
> init-args)
>     (destructuring-bind (response-function . header-function) init-args
>       (setf (response-function url) response-function
>             (header-function url) header-function)
>       url)))
>
> i.e. destructuring a cons instead of using &OPTIONAL.  I think
> HTTP-COMPUTED-FORM and HTTP-CLIENT-SCRIPT have the same problem.
>
> __Martin
>
> _______________________________________________
> WWW-CL mailing list
> [email protected]
> http://lists.csail.mit.edu/mailman/listinfo/www-cl

The following patch to CL-HTTP 70.190 fixes this problem in general.

;; Fix destructuring bind error on export of header functions for
;; http-form, http-computed-form, http-computed-url, and
;; http-client-script. These url classe will now hanlde the 
header-function correctly

;;http:server;server.lisp
(in-package :http)

(defun %export-computed-url (url translation args)
   (destructuring-bind (&key response-function header-function pathname 
character-set &allow-other-keys) args
     (when pathname
       (setf (translated-pathname url) pathname))
     (unless (and response-function (good-response-function-p 
response-function))
       (error "RESPONSE-FUNCTION, ~S, must be a defined function when 
exporting the URL, ~S, with translation, ~S"
              response-function url translation))
     (setf (translation-method url) translation
           (character-set url) character-set)
     (let ((init-args `(,response-function ,header-function)))
       (declare (dynamic-extent init-args))
       (url:initialize-specialization url 'url:http-computed-url 
init-args))
     url))

(defmethod  export-url ((url url:http-object) (translation (eql 
:html-form)) &rest args)
   (destructuring-bind (&key response-function header-function pathname 
server character-set
			    (durable-form-values nil durable-form-values-p-supplied)
			    (maximum-upload-file-size nil 
maximum-upload-file-size-supplied-p)
			    &allow-other-keys) args
     (cond (pathname
            (setf (translated-pathname  url) pathname))
           (t (error "No PATHNAME was provided while exporting the URL, 
~S, with translation, ~S"
                     url translation)))
     (unless (and response-function (good-response-function-p 
response-function))
       (error "RESPONSE-FUNCTION, ~S, must be a defined function when 
exporting the URL, ~S, with translation, ~S"
              response-function url translation))
     (setf (translation-method url) translation
           (character-set url) character-set)
     (if durable-form-values-p-supplied
	(setf (get-value url :durable-form-values-p) durable-form-values)
	(remove-value url :durable-form-values-p))
     (if maximum-upload-file-size-supplied-p
	(setf (get-value url :maximum-upload-file-size) 
maximum-upload-file-size)
	(remove-value url :maximum-upload-file-size))
     (let ((init-args `(,server ,response-function ,header-function)))
       (declare (dynamic-extent init-args))
       (url:initialize-specialization url 'url:http-form init-args))
     url))

(defun %export-computed-form (url translation args)
   (destructuring-bind (&key form-function response-function 
header-function
			    (durable-form-values nil durable-form-values-p-supplied)
			    (maximum-upload-file-size nil 
maximum-upload-file-size-supplied-p)
			    &allow-other-keys) args
     (unless (and response-function (good-response-function-p 
response-function))
       (error "RESPONSE-FUNCTION, ~S, must be a defined function when 
exporting the URL, ~S, with translation, ~S"
              response-function url translation))
     (unless (and form-function (good-response-function-p form-function))
       (error "FORM-FUNCTION, ~S, must be a defined function when 
exporting the URL, ~S, with translation, ~S"
              form-function url translation))
     (setf (translation-method url) translation)
     (if durable-form-values-p-supplied
	(setf (get-value url :durable-form-values-p) durable-form-values)
	(remove-value url :durable-form-values-p))
     (if maximum-upload-file-size-supplied-p
	(setf (get-value url :maximum-upload-file-size) 
maximum-upload-file-size)
	(remove-value url :maximum-upload-file-size))
     (let ((init-args `(,form-function ,response-function 
,header-function)))
       (declare (dynamic-extent init-args))
       (url:initialize-specialization url 'url:http-computed-form 
init-args))
     url))

(defmethod export-url ((url url:http-minimum-object) (translation (eql 
:script)) &rest args)
   (destructuring-bind (&key script header-function &allow-other-keys) 
args
     (unless script
       (error "No script was provided while exporting the URL, ~S, with 
EXPORT-TYPE, ~S"
              url translation))
     (setf (translation-method url) translation)
     (let ((args `(,script ,header-function)))
       (declare (dynamic-extent args))
       (url:initialize-specialization url 'url:http-client-script args))
     url))

;; http:server;url.lisp
(in-package :url)

(defmethod initialize-specialization ((url http-form) class init-args)
   (with-class-change-for-initialize-specialization (url class init-args)
     (destructuring-bind (server response-function header-function) 
init-args
       (setf (form-server url) server
             (response-function url) response-function
             (header-function url) header-function)
       url)))

(defmethod initialize-specialization ((url http-computed-url) class 
init-args)
   (with-class-change-for-initialize-specialization (url class init-args)
     (destructuring-bind (response-function header-function) init-args
       (setf (response-function url) response-function
             (header-function url) header-function)
       url)))

(defmethod initialize-specialization ((url http-computed-form) class 
init-args)
   (with-class-change-for-initialize-specialization (url class init-args)
     (destructuring-bind (form-function response-function 
header-function) init-args
       (setf (form-function url) form-function
             (response-function url) response-function
             (header-function url) header-function)
       url)))

(defmethod initialize-specialization ((url http-client-script) class 
init-args)
   (with-class-change-for-initialize-specialization (url class init-args)
     (destructuring-bind (script header-function) init-args
       (setf (script url) script
             (header-function url) header-function)
       url)))



_______________________________________________
WWW-CL mailing list
[email protected]
http://lists.csail.mit.edu/mailman/listinfo/www-cl