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.

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
+     (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~%")))
-       (http-fetch uri #:text? #f #:buffered? buffered?)))))
+           (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:

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,18 +142,23 @@ 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 ((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
@@ -197,6 +203,6 @@ unbuffered port, suitable for use in `filtered-port'."
              (loop uri)))
           (else
            (error "download failed" uri code
-                (response-reason-phrase resp)))))))
+                  (response-reason-phrase resp))))))))
 
 ;;; web.scm ends here