substitute-binary: Avoid dangling connections to the server.

* guix/web.scm (open-socket-for-uri): New procedure.
  (http-fetch): Add `port' keyword parameter; use it.
* guix/scripts/substitute-binary.scm (%random-state): New variable.
  (with-timeout): Wait a little before retrying.
  (fetch): Use `open-socket-for-uri', and keep a copy of the socket in
  variable `port'.  Close PORT upon timeout.

2 files changed, 84 insertions, 66 deletions

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 271a22541a..24e5d68c4f 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -124,6 +124,9 @@ pairs."
   ;; Number of seconds after which networking is considered "slow".
   3)
 
+(define %random-state
+  (seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
+
 (define-syntax-rule (with-timeout duration handler body ...)
   "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
 again."
@@ -140,11 +143,15 @@ again."
               (lambda ()
                 body ...)
               (lambda args
-                ;; The SIGALRM triggers EINTR.  When that happens, try again.
-                ;; Note: SA_RESTART cannot be used because of
-                ;; <http://bugs.gnu.org/14640>.
+                ;; The SIGALRM triggers EINTR, because of the bug at
+                ;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
+                ;; When that happens, try again.  Note: SA_RESTART cannot be
+                ;; used because of <http://bugs.gnu.org/14640>.
                 (if (= EINTR (system-error-errno args))
-                    (try)
+                    (begin
+                      ;; Wait a little to avoid bursts.
+                      (usleep (random 3000000 %random-state))
+                      (try))
                     (apply throw args))))))
       (lambda result
         (alarm 0)
@@ -168,14 +175,19 @@ provide."
      ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
      ;; and then cancel with:
      ;;   sudo tc qdisc del dev eth0 root
-     (with-timeout (if (or timeout? (version>? (version) "2.0.5"))
-                       %fetch-timeout
-                       0)
-       (begin
-         (warning (_ "while fetching ~a: server is unresponsive~%")
-                  (uri->string uri))
-         (warning (_ "try `--no-substitutes' if the problem persists~%")))
-       (http-fetch uri #:text? #f #:buffered? buffered?)))))
+     (let ((port #f))
+       (with-timeout (if (or timeout? (version>? (version) "2.0.5"))
+                         %fetch-timeout
+                         0)
+         (begin
+           (warning (_ "while fetching ~a: server is unresponsive~%")
+                    (uri->string uri))
+           (warning (_ "try `--no-substitutes' if the problem persists~%"))
+           (when port
+             (close-port port)))
+         (begin
+           (set! port (open-socket-for-uri uri #:buffered? buffered?))
+           (http-fetch uri #:text? #f #:port port)))))))
 
 (define-record-type <cache>
   (%make-cache url store-directory wants-mass-query?)
@@ -535,7 +547,7 @@ PORT.  REPORT-PROGRESS is a two-argument procedure such as that returned by
       (show-version-and-exit "guix substitute-binary")))))
 
 
-;;; Local Variable:
+;;; Local Variables:
 ;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1)
 ;;; eval: (put 'with-timeout 'scheme-indent-function 1)
 ;;; End:
diff --git a/guix/web.scm b/guix/web.scm
index d24f15853d..321c38391d 100644
--- a/guix/web.scm
+++ b/guix/web.scm
@@ -27,7 +27,8 @@
   #:use-module (rnrs bytevectors)
   #:use-module (guix ui)
   #:use-module (guix utils)
-  #:export (http-fetch))
+  #:export (open-socket-for-uri
+            http-fetch))
 
 ;;; Commentary:
 ;;;
@@ -141,62 +142,67 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true."
 (module-define! (resolve-module '(web client))
                 'shutdown (const #f))
 
-(define* (http-fetch uri #:key (text? #f) (buffered? #t))
+(define* (open-socket-for-uri uri #:key (buffered? #t))
+  "Return an open port for URI.  When BUFFERED? is false, the returned port is
+unbuffered."
+  (let ((s ((@ (web client) open-socket-for-uri) uri)))
+    (unless buffered?
+      (setvbuf s _IONBF))
+    s))
+
+(define* (http-fetch uri #:key port (text? #f) (buffered? #t))
   "Return an input port containing the data at URI, and the expected number of
 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
 textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
 unbuffered port, suitable for use in `filtered-port'."
   (let loop ((uri uri))
-    (define port
-      (let ((s (open-socket-for-uri uri)))
-        (unless buffered?
-          (setvbuf s _IONBF))
-        s))
-
-    (let*-values (((resp data)
-                   ;; Try hard to use the API du jour to get an input port.
-                   ;; On Guile 2.0.5 and before, we can only get a string or
-                   ;; bytevector, and not an input port.  Work around that.
-                  (if (version>? (version) "2.0.7")
-                      (http-get uri #:streaming? #t #:port port) ; 2.0.9+
-                      (if (defined? 'http-get*)
-                          (http-get* uri #:decode-body? text?
-                                     #:port port)                ; 2.0.7
-                          (http-get uri #:decode-body? text?
-                                    #:port port))))              ; 2.0.5-
-                  ((code)
-                   (response-code resp)))
-      (case code
-        ((200)
-         (let ((len (response-content-length resp)))
-           (cond ((not data)
-                  (begin
-                    ;; Guile 2.0.5 and earlier did not support chunked
-                    ;; transfer encoding, which is required for instance when
-                    ;; fetching %PACKAGE-LIST-URL (see
-                    ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
-                    ;; Normally the `when-guile<=2.0.5' block above fixes
-                    ;; that, but who knows what could happen.
-                    (warning (_ "using Guile ~a, which does not support ~s encoding~%")
-                             (version)
-                             (response-transfer-encoding resp))
-                    (leave (_ "download failed; use a newer Guile~%")
-                           uri resp)))
-                 ((string? data)                   ; `http-get' from 2.0.5-
-                  (values (open-input-string data) len))
-                 ((bytevector? data)               ; likewise
-                  (values (open-bytevector-input-port data) len))
-                 (else                             ; input port
-                  (values data len)))))
-        ((301                                      ; moved permanently
-          302)                                     ; found (redirection)
-         (let ((uri (response-location resp)))
-           (close-port port)
-           (format #t (_ "following redirection to `~a'...~%")
-                   (uri->string uri))
-           (loop uri)))
-        (else
-         (error "download failed" uri code
-                (response-reason-phrase resp)))))))
+    (let ((port (or port
+                    (open-socket-for-uri uri
+                                         #:buffered? buffered?))))
+      (let*-values (((resp data)
+                     ;; Try hard to use the API du jour to get an input port.
+                     ;; On Guile 2.0.5 and before, we can only get a string or
+                     ;; bytevector, and not an input port.  Work around that.
+                     (if (version>? (version) "2.0.7")
+                         (http-get uri #:streaming? #t #:port port) ; 2.0.9+
+                         (if (defined? 'http-get*)
+                             (http-get* uri #:decode-body? text?
+                                        #:port port) ; 2.0.7
+                             (http-get uri #:decode-body? text?
+                                       #:port port)))) ; 2.0.5-
+                    ((code)
+                     (response-code resp)))
+        (case code
+          ((200)
+           (let ((len (response-content-length resp)))
+             (cond ((not data)
+                    (begin
+                      ;; Guile 2.0.5 and earlier did not support chunked
+                      ;; transfer encoding, which is required for instance when
+                      ;; fetching %PACKAGE-LIST-URL (see
+                      ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
+                      ;; Normally the `when-guile<=2.0.5' block above fixes
+                      ;; that, but who knows what could happen.
+                      (warning (_ "using Guile ~a, which does not support ~s encoding~%")
+                               (version)
+                               (response-transfer-encoding resp))
+                      (leave (_ "download failed; use a newer Guile~%")
+                             uri resp)))
+                   ((string? data)                ; `http-get' from 2.0.5-
+                    (values (open-input-string data) len))
+                   ((bytevector? data)            ; likewise
+                    (values (open-bytevector-input-port data) len))
+                   (else                          ; input port
+                    (values data len)))))
+          ((301                                   ; moved permanently
+            302)                                  ; found (redirection)
+           (let ((uri (response-location resp)))
+             (close-port port)
+             (format #t (_ "following redirection to `~a'...~%")
+                     (uri->string uri))
+             (loop uri)))
+          (else
+           (error "download failed" uri code
+                  (response-reason-phrase resp))))))))
 
 ;;; web.scm ends here