GNU bug report logs - #45409
[PATCH 0/3] Move some (guix scripts substitute) code to two new modules

Previous Next

Full log

View this message in rfc822 format

From: Christopher Baines <mail <at> cbaines.net>
To: 45409 <at> debbugs.gnu.org
Subject: [bug#45409] [PATCH v5 12/14] substitute: Inline fetch in to process-substitutes.
Date: Sat, 13 Feb 2021 13:47:17 +0000

As it's only called in one place, and this should make the code easier to
read.

* guix/scripts/substitute.scm (fetch): Move procedure inside…
(process-substitution): …here.
---
 guix/scripts/substitute.scm | 60 ++++++++++++++++++-------------------
 1 file changed, 29 insertions(+), 31 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 26fd05429f..717c232633 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -169,37 +169,6 @@ again."
         (sigaction SIGALRM SIG_DFL)
         (apply values result)))))
 
-(define (fetch uri)
-  "Return a binary input port to URI and the number of bytes it's expected to
-provide."
-  (case (uri-scheme uri)
-    ((file)
-     (let ((port (open-file (uri-path uri) "r0b")))
-       (values port (stat:size (stat port)))))
-    ((http https)
-     (guard (c ((http-get-error? c)
-                (leave (G_ "download from '~a' failed: ~a, ~s~%")
-                       (uri->string (http-get-error-uri c))
-                       (http-get-error-code c)
-                       (http-get-error-reason c))))
-       ;; 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~%")))
-         (http-fetch uri #:text? #f
-                     #:open-connection open-connection-for-uri/maybe
-                     #:keep-alive? #t
-                     #:buffered? #f
-                     #:verify-certificate? #f))))
-    (else
-     (leave (G_ "unsupported substitute URI scheme: ~a~%")
-            (uri->string uri)))))
-
 (define (narinfo-cache-file cache-url path)
   "Return the name of the local file that contains an entry for PATH.  The
 entry is stored in a sub-directory specific to CACHE-URL."
@@ -706,6 +675,35 @@ the current output port."
     (apply dump-file/deduplicate
            (append args (list #:store (%store-prefix)))))
 
+  (define (fetch uri)
+    (case (uri-scheme uri)
+      ((file)
+       (let ((port (open-file (uri-path uri) "r0b")))
+         (values port (stat:size (stat port)))))
+      ((http https)
+       (guard (c ((http-get-error? c)
+                  (leave (G_ "download from '~a' failed: ~a, ~s~%")
+                         (uri->string (http-get-error-uri c))
+                         (http-get-error-code c)
+                         (http-get-error-reason c))))
+         ;; 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~%")))
+           (http-fetch uri #:text? #f
+                       #:open-connection open-connection-for-uri/maybe
+                       #:keep-alive? #t
+                       #:buffered? #f
+                       #:verify-certificate? #f))))
+      (else
+       (leave (G_ "unsupported substitute URI scheme: ~a~%")
+              (uri->string uri)))))
+
   (unless narinfo
     (leave (G_ "no valid substitute for '~a'~%")
            store-item))
-- 
2.30.0

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.