From dcf0cca8d7d9771f0337e8a3b28653b9a459755d Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sat, 10 Feb 2024 17:09:25 +0000
Subject: scripts: substitute: Allow not using with-timeout in download-nar.

I don't think the approach of using SIGALARM here for the timeout will work
well in all cases (e.g. when using Guile Fibers), so make it possible to avoid
this.

* guix/scripts/substitute.scm (download-nar): Pass the fetch timeout in as an
option.

Change-Id: I8cbe6cdfa10cdaa7d41974cbea56a95f5efecfe6
---
 guix/scripts/substitute.scm | 37 ++++++++++++++++++++++---------------
 1 file changed, 22 insertions(+), 15 deletions(-)

(limited to 'guix')

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 9726a80753..aae6eddf3f 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -452,7 +452,8 @@ server certificates."
 
 (define* (download-nar narinfo destination
                        #:key status-port
-                       deduplicate? print-build-trace?)
+                       deduplicate? print-build-trace?
+                       (fetch-timeout %fetch-timeout))
   "Download the nar prescribed in NARINFO, which is assumed to be authentic
 and authorized, and write it to DESTINATION.  When DEDUPLICATE? is true, and
 if DESTINATION is in the store, deduplicate its files.  Print a status line to
@@ -473,20 +474,26 @@ STATUS-PORT."
        (let ((port (open-file (uri-path uri) "r0b")))
          (values port (stat:size (stat port)))))
       ((http https)
-       ;; 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))))
+       (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))))
       (else
        (leave (G_ "unsupported substitute URI scheme: ~a~%")
               (uri->string uri)))))
-- 
cgit v1.2.3