Hi all, We noticed in yesterday's Salmonella run that chicken-install isn't handling HTTP error codes correctly:
https://salmonella-freebsd-x86-64.call-cc.org/master/clang/freebsd/x86-64/2019/09/15/yesterday-diff/log2/install/zmq.html As you can see, we get a compiler error on an HTML document which is being processed as Scheme code. After a quick look at egg-download.scm, it become clear that the handling for error codes was wrapped only inside the code that handled 407 codes. That code itself did not look correct either, because it would not read the response line or headers after sending the new request through the proxy. The first patch fixes these issues. While in there, I decided that adding support for redirects shouldn't be too hard, so that's what the second patch does. Cheers, Peter
From da2b5d0cbe5b67ea120b5d9157a64ee2eb3fe164 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 15 Sep 2019 15:52:01 +0200
Subject: [PATCH 1/2] Fix egg-download response handling
There were two issues:
- The check for 200 "OK" was nested inside the 407 code handling,
which meant we would misinterpret error HTML pages as egg contents.
- The code which handled 407 "Proxy Authentication Required" would
simply send a new request without reading the response headers
correctly.
---
NEWS | 2 ++
egg-download.scm | 59 ++++++++++++++++++++++++------------------------
2 files changed, 31 insertions(+), 30 deletions(-)
diff --git a/NEWS b/NEWS
index 5642c85b..9b71bd35 100644
--- a/NEWS
+++ b/NEWS
@@ -42,6 +42,8 @@
- The new "-module-registration" options causes module registration
code to always be included in the program, even when it has also
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.
5.1.0
diff --git a/egg-download.scm b/egg-download.scm
index 0839ad83..15dddbbd 100644
--- a/egg-download.scm
+++ b/egg-download.scm
@@ -66,10 +66,10 @@
""))
(let-values (((in out)
(tcp-connect (or proxy-host host) (or proxy-port port))))
- (d "requesting ~s ...~%" locn)
- (let ((req (make-HTTP-GET/1.1 locn user-agent host
- port: port accept: "*/*"
- proxy-host: proxy-host proxy-port: proxy-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)
(d "reading response ...~%")
@@ -79,32 +79,31 @@
(response-match (match-http-response h1)))
(d "~a~%" h1)
;;XXX handle redirects here
- (if (response-match-code? response-match 407)
- (let-values (((inpx outpx) (tcp-connect proxy-host proxy-port)))
- (set! in inpx) (set! out outpx)
- (display
- (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)
- out)
- (unless (response-match-code? response-match 200)
- (network-failure "invalid response from server" h1)))
- (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) ) ) ) )
- (when chunked
- (d "reading chunks ")
- (let ((data (read-chunks in)))
- (close-input-port in)
- (set! in (open-input-string data))) )
+ (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))))
+ ((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) ) ) )
+ (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)))))
(define (http-retrieve-files in out dest)
--
2.20.1
From 81d2be07979deccc274fe2cff48a68fddc7ca5f5 Mon Sep 17 00:00:00 2001
From: Peter Bex <pe...@more-magic.net>
Date: Sun, 15 Sep 2019 16:17:35 +0200
Subject: [PATCH 2/2] Handle 301/302 redirects in chicken-install
This was noted as a TODO, now implemented.
---
NEWS | 1 +
egg-download.scm | 99 +++++++++++++++++++++++++++++++++---------------
2 files changed, 70 insertions(+), 30 deletions(-)
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)))))
--
2.20.1
signature.asc
Description: PGP signature
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
