[closure-cvs] CVS update: closure/src/net/http.lisp

[Eric Marsden]

Update of /project/closure/cvsroot/closure/src/net
In directory common-lisp.net:/tmp/cvs-serv16846/src/net

Modified Files:
	http.lisp 
Log Message:
Partial fix for following HTTP redirects (code 301 or 302 or 303).
Certain servers (such as www.lisp.org) only include a path in the
Location header, instead of a complete URL. We now accept either
a path (in which case the rest of the URL is derived from the current
URL), or a complete URL.

This fix is only partial, since the GUI code in gui/clim-gui.lisp
is not prepared to handle redirects correctly.

Date: Sun Jul 17 11:44:40 2005
Author: emarsden

Index: closure/src/net/http.lisp
diff -u closure/src/net/http.lisp:1.6 closure/src/net/http.lisp:1.7
--- closure/src/net/http.lisp:1.6	Wed Jul 13 17:13:05 2005
+++ closure/src/net/http.lisp	Sun Jul 17 11:44:40 2005
@@ -99,7 +99,7 @@
 
 (defparameter *user-agent* "Lynx/2.7.1ac-0.98 libwww-FM/2.14")
 (defparameter *user-agent* "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)")
-(defparameter *user-agent* "CLOSURE/0.1")
+(defparameter *user-agent* "Closure/200507")
 
 
 #||
@@ -549,20 +549,19 @@
               response-header)))
         
           ((301 302 303) 
-           ;; moved permanently; moved temponary; see other
-           (multiple-value-bind (input header)
-               (http-open-document
-                (url:parse-url
-                 (or (get-header-field response-header :location)
-                     (error "301/302 Response from ~A lacks a 'Location' field."
-                            (url:url-host url))))
-                :yet-urls (cons url yet-urls))
-             (values input
-                     (append header
-                             (list 
-                              (cons "Location" 
-                                    (get-header-field response-header :location)))))))
-        
+           ;; moved permanently; moved temporary; see other
+           ;;
+           ;; the Location field may be either a complete URI, or just a path
+           (let* ((new-location (or (url:parse-url
+                                     (get-header-field response-header :location))
+                                    (error "301/302 Response from ~A lacks a 'Location' field."
+                                           (url:url-host url))))
+                  (new-url (if (url:url-host new-location) new-location
+                               (url:merge-url new-location url))))
+             (multiple-value-bind (input header)
+                 (apply #'http-open-document new-url :yet-urls (cons url yet-urls) options)
+               (values input `(, at header ("Location" . ,(unparse-url new-url)))))))
+          
           (304
            ;; not modified
            (values (cl-byte-stream->gstream (open (hce-pathname (http-cache) ce)