02/02: substitute-binary: Adjust to better deal with Nginx's behavior.

[Ludovic Courtès]

civodul pushed a commit to branch wip-http-pipelining
in repository guix.

commit a851c620128a8c076bd258ed73838add82058c40
Author: Ludovic Courtès <address@hidden>
Date:   Wed Dec 10 13:43:51 2014 +0100

    substitute-binary: Adjust to better deal with Nginx's behavior.
    
    * guix/scripts/substitute-binary.scm (eof-if-connection-reset): New
      macro.
      (read-response-and-body): New procedure.
      (http-multiple-get): Use it.  Handle RESP or BODY being EOF.  Wrap
      PROC call in 'eof-if-connection-reset'.
      (fetch-narinfos)[handle-narinfo-response]: Call 'update-progress!'
      after 'cache-narinfo!'.
---
 guix/scripts/substitute-binary.scm |   62 +++++++++++++++++++++++++++++------
 1 files changed, 51 insertions(+), 11 deletions(-)

diff --git a/guix/scripts/substitute-binary.scm 
b/guix/scripts/substitute-binary.scm
index f470c5f..c24484d 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -440,6 +440,38 @@ be #f, in which case it indicates that PATH is unavailable 
at CACHE."
                             ".narinfo")))
     (build-request (string->uri url) #:method 'GET)))
 
+
+(define-syntax eof-if-connection-reset
+  (syntax-rules ()
+    "Return the end-of-file object if the connection is reset while evaluating
+EXP."
+    ((_ (results ...) exp)
+     (catch 'bad-response
+       (lambda ()
+         (catch 'system-error
+           (lambda ()
+             exp)
+           (lambda args
+             (if (= ECONNRESET (system-error-errno args))
+                 (let ((results (eof-object)) ...)
+                   (values results ...))
+                 (apply throw args)))))
+       (lambda args
+         ;; Sometimes Nginx hangs up in the middle of a response, which leads
+         ;; (web client) to throw 'bad-response, hence this handler.
+         (let ((results (eof-object)) ...)
+           (values results ...)))))
+    ((_ exp)
+     (eof-if-connection-reset (one-value) exp))))
+
+(define (read-response-and-body port)
+  "Read an HTTP response and its body from PORT, and return these two values.
+Return the end-of-file object if the connection is lost while reading."
+  (eof-if-connection-reset (resp body)
+                           (let* ((resp (read-response port))
+                                  (body (response-body-port resp)))
+                             (values resp body))))
+
 (define (http-multiple-get base-url requests proc)
   "Send all of REQUESTS to the server at BASE-URL.  Call PROC for each
 response, passing it the request object, the response, and a port from which
@@ -461,16 +493,23 @@ to read the response body.  Return the list of results."
           (()
            (reverse result))
           ((head tail ...)
-           (let* ((resp (read-response p))
-                  (body (response-body-port resp)))
+           (let-values (((resp body) (read-response-and-body p)))
              ;; The server can choose to stop responding at any time, in which
-             ;; case we have to try again.  Check whether that is the case.
-             (match (assq 'connection (response-headers resp))
-               (('connection 'close)
-                (connect requests result))        ; try again
-               (_
-                (loop tail                        ; keep going
-                      (cons (proc head resp body) result)))))))))))
+             ;; case we have to try again.  Nginx just closes the connection
+             ;; brutally, which is handled using 'eof-if-connection-reset'.
+             ;; Check whether that is the case.
+             (if (or (eof-object? resp) (eof-object? body))
+                 (connect requests result)
+                 (match (assq 'connection (response-headers resp))
+                   (('connection 'close)
+                    (connect requests result))    ;try again
+                   (_
+                    (let ((item (eof-if-connection-reset
+                                 (proc head resp body))))
+                      (if (eof-object? item)
+                          (connect requests result)
+                          (loop tail                 ;keep going
+                                (cons item result))))))))))))))
 
 (define (read-to-eof port)
   "Read from PORT until EOF is reached.  The data are discarded."
@@ -504,11 +543,11 @@ if file doesn't exist, and the narinfo otherwise."
         (set! done (+ 1 done)))))
 
   (define (handle-narinfo-response request response port)
-    (update-progress!)
     (case (response-code response)
       ((200)                                      ; hit
        (let ((narinfo (read-narinfo port url)))
          (cache-narinfo! cache (narinfo-path narinfo) narinfo)
+         (update-progress!)
          narinfo))
       ((404)                                      ; failure
        (let* ((path      (uri-path (request-uri request)))
@@ -516,7 +555,8 @@ if file doesn't exist, and the narinfo otherwise."
          (read-to-eof port)
          (cache-narinfo! cache
                          (find (cut string-contains <> hash-part) paths)
-                         #f))
+                         #f)
+         (update-progress!))
        #f)
       (else                                       ; transient failure
        (read-to-eof port)