From 13abc599f747eb68e628f9f4355e230ee43e6ec2 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 21 Apr 2024 10:42:38 +0100
Subject: scripts: substitute: Simplify with-timeout usage.

To reduce the codepaths in download-nar.

* guix/scripts/substitute.scm (with-timeout): Accept a #f duration and don't
set a timeout.
(download-nar): Remove the if for fetch-timeout.

Change-Id: I4e944a425a8612e96659dd84dd0e315012f080ab
---
 guix/scripts/substitute.scm | 93 ++++++++++++++++++++++-----------------------
 1 file changed, 45 insertions(+), 48 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 362d9fbe7a..b4bb9d51ff 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -101,34 +101,37 @@ disabled!~%"))
 (define-syntax-rule (with-timeout duration handler body ...)
   "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
 again."
-  (begin
-    (sigaction SIGALRM
-      (lambda (signum)
-        (sigaction SIGALRM SIG_DFL)
-        handler))
-    (alarm duration)
-    (call-with-values
-        (lambda ()
-          (let try ()
-            (catch 'system-error
-              (lambda ()
-                body ...)
-              (lambda args
-                ;; Before Guile v2.0.9-39-gfe51c7b, 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))
-                    (begin
-                      ;; Wait a little to avoid bursts.
-                      (usleep (random 3000000 %random-state))
-                      (try))
-                    (apply throw args))))))
-      (lambda result
-        (alarm 0)
-        (sigaction SIGALRM SIG_DFL)
-        (apply values result)))))
+  (if duration
+      (begin
+        (sigaction SIGALRM
+          (lambda (signum)
+            (sigaction SIGALRM SIG_DFL)
+            handler))
+        (alarm duration)
+        (call-with-values
+            (lambda ()
+              (let try ()
+                (catch 'system-error
+                  (lambda ()
+                    body ...)
+                  (lambda args
+                    ;; Before Guile v2.0.9-39-gfe51c7b, 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))
+                        (begin
+                          ;; Wait a little to avoid bursts.
+                          (usleep (random 3000000 %random-state))
+                          (try))
+                        (apply throw args))))))
+          (lambda result
+            (alarm 0)
+            (sigaction SIGALRM SIG_DFL)
+            (apply values result))))
+      (begin
+        body ...)))
 
 (define (at-most max-length lst)
   "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
@@ -475,26 +478,20 @@ if DESTINATION is in the store, deduplicate its files."
        (let ((port (open-file (uri-path uri) "r0b")))
          (values port (stat:size (stat port)))))
       ((http https)
-       (if fetch-timeout
-           ;; Test this with:
-           ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
-           ;; and then cancel with:
-           ;;   sudo tc qdisc del dev eth0 root
-           (with-timeout %fetch-timeout
-             (begin
-               (warning (G_ "while fetching ~a: server is somewhat slow~%")
-                        (uri->string uri))
-               (warning (G_ "try `--no-substitutes' if the problem persists~%")))
-             (with-cached-connection uri port
-               (http-fetch uri #:text? #f
-                           #:port port
-                           #:keep-alive? #t
-                           #:buffered? #f)))
-           (with-cached-connection uri port
-             (http-fetch uri #:text? #f
-                         #:port port
-                         #:keep-alive? #t
-                         #:buffered? #f))))
+       ;; Test this with:
+       ;;   sudo tc qdisc add dev eth0 root netem delay 1500ms
+       ;; and then cancel with:
+       ;;   sudo tc qdisc del dev eth0 root
+       (with-timeout fetch-timeout
+         (begin
+           (warning (G_ "while fetching ~a: server is somewhat slow~%")
+                    (uri->string uri))
+           (warning (G_ "try `--no-substitutes' if the problem persists~%")))
+         (with-cached-connection uri port
+           (http-fetch uri #:text? #f
+                       #:port port
+                       #:keep-alive? #t
+                       #:buffered? #f))))
       (else
        (raise
         (formatted-message
-- 
cgit v1.2.3