~ chicken-core (chicken-5) d464fe9396435af8c8fdc6744a01359fdd647a1b

commit d464fe9396435af8c8fdc6744a01359fdd647a1b
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sun Sep 15 16:17:35 2019 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Sep 29 11:47:11 2019 +1300

    Handle 301/302 redirects in chicken-install
    
    This was noted as a TODO, now implemented.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index 9b71bd35..84a65d48 100644
--- a/NEWS
+++ b/NEWS
@@ -44,6 +44,7 @@
     been emitted as a separate file (for example with "-J").
   - chicken-install now correctly checks server response code to avoid
     interpreting error response bodies (like 404, 500) as Scheme code.
+  - chicken-install now follows HTTP redirects when downloading eggs.
 
 
 5.1.0
diff --git a/egg-download.scm b/egg-download.scm
index 15dddbbd..1acc09a6 100644
--- a/egg-download.scm
+++ b/egg-download.scm
@@ -27,6 +27,7 @@
 (define +default-tcp-connect-timeout+ 30000) ; 30 seconds
 (define +default-tcp-read/write-timeout+ 30000) ; 30 seconds
 (define +url-regex+ "(http://)?([^/:]+)(:([^:/]+))?(/.*)?")
+(define +max-redirects+ 3)
 
 (tcp-connect-timeout +default-tcp-connect-timeout+)
 (tcp-read-timeout +default-tcp-read/write-timeout+)
@@ -60,15 +61,25 @@
     (http-retrieve-response in len)))
 
 (define (http-connect host port locn proxy-host proxy-port proxy-user-pass)
-  (d "connecting to host ~s, port ~a ~a...~%" host port
-     (if proxy-host
-         (sprintf "(via ~a:~a) " proxy-host proxy-port)
-         ""))
-  (let-values (((in out)
+  (let next-req ((redirects 0)
+		 (host host)
+		 (port port)
+		 (locn locn)
+		 (req (make-HTTP-GET/1.1
+		       locn user-agent host
+		       port: port accept: "*/*"
+		       proxy-host: proxy-host proxy-port: proxy-port)))
+
+    (when (= redirects +max-redirects+)
+      (network-failure "too many redirects" redirects))
+
+    (d "connecting to host ~s, port ~a ~a...~%" host port
+       (if proxy-host
+           (sprintf "(via ~a:~a) " proxy-host proxy-port)
+           ""))
+
+    (let-values (((in out)
                   (tcp-connect (or proxy-host host) (or proxy-port port))))
-    (let next-req ((req (make-HTTP-GET/1.1 locn user-agent host
-                         port: port accept: "*/*"
-			 proxy-host: proxy-host proxy-port: proxy-port)))
       (d "requesting ~s ...~%" locn)
       (display req out)
       (flush-output out)
@@ -77,34 +88,58 @@
              (datalen #f)
              (h1 (read-line in))
              (response-match (match-http-response h1)))
-        (d "~a~%" h1)
-        ;;XXX handle redirects here
-        (cond
+
+	(define (process-headers)
+	  (let ((ln (read-line in)))
+	    (unless (equal? ln "")
+	      (cond ((match-chunked-transfer-encoding ln)
+                     (set! chunked #t))
+                    ((match-content-length ln) =>
+                     (lambda (sz) (set! datalen sz)))
+		    ((match-location ln) =>
+                     (lambda (new-locn)
+		       (set!-values (host port locn)
+				    (deconstruct-url new-locn)))))
+	      (d "~a~%" ln)
+	      (process-headers) ) ) )
+
+	(d "~a~%" h1)
+
+	(cond
 	 ((response-match-code? response-match 407)
-          (let-values (((inpx outpx) (tcp-connect proxy-host proxy-port)))
-	    (set! in inpx) (set! out outpx)
-	    (next-req (make-HTTP-GET/1.1
-		       locn user-agent host port: port
-		       accept: "*/*"
-		       proxy-host: proxy-host proxy-port: proxy-port
-		       proxy-user-pass: proxy-user-pass))))
+	  (close-input-port in)
+	  (close-output-port out)
+
+	  (d "retrying with proxy auth ~a~%" locn)
+	  (next-req redirects host port locn
+		    (make-HTTP-GET/1.1
+		     locn user-agent host port: port
+		     accept: "*/*"
+		     proxy-host: proxy-host proxy-port: proxy-port
+		     proxy-user-pass: proxy-user-pass)))
+
+	 ((or (response-match-code? response-match 301)
+	      (response-match-code? response-match 302))
+	  (process-headers)
+	  (close-input-port in)
+	  (close-output-port out)
+
+	  (d "redirected to ~a~%" locn)
+	  (next-req (add1 redirects) host port locn
+		    (make-HTTP-GET/1.1
+		     locn user-agent host
+		     port: port accept: "*/*"
+		     proxy-host: proxy-host proxy-port: proxy-port)))
+
 	 ((response-match-code? response-match 200)
-	  (let loop ()
-    	    (let ((ln (read-line in)))
-	      (unless (equal? ln "")
-		(cond ((match-chunked-transfer-encoding ln)
-                       (set! chunked #t))
-                      ((match-content-length ln) =>
-                       (lambda (sz) (set! datalen sz))))
-		(d "~a~%" ln)
-		(loop) ) ) )
+	  (process-headers)
 	  (when chunked
 	    (d "reading chunks ")
 	    (let ((data (read-chunks in)))
 	      (close-input-port in)
-	      (set! in (open-input-string data))) ))
-	 (else (network-failure "invalid response from server" h1)))
-        (values in out datalen)))))
+	      (set! in (open-input-string data))) )
+	  (values in out datalen))
+	 (else (network-failure "invalid response from server" h1)))))))
 
 (define (http-retrieve-files in out dest)
   (d "reading files ...~%")
@@ -196,6 +231,10 @@
 (define (match-chunked-transfer-encoding ln)
   (irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
 
+(define (match-location ln)
+  (let ((m (irregex-match "[Ll]ocation:\\s*(.+)\\s*" ln)))
+    (and m (irregex-match-substring m 1))))
+
 (define (match-content-length ln)
   (let ((m (irregex-match "[Cc]ontent-[Ll]ength:\\s*([0-9]+).*" ln)))
     (and m (string->number (irregex-match-substring m 1)))))