[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
12/14: substitute: Inline fetch in to process-substitutes.
From: |
guix-commits |
Subject: |
12/14: substitute: Inline fetch in to process-substitutes. |
Date: |
Mon, 22 Feb 2021 15:44:47 -0500 (EST) |
cbaines pushed a commit to branch master
in repository guix.
commit 8116cc66733134a8fb6f9117d4648288b83c8356
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Thu Jan 7 20:41:50 2021 +0000
substitute: Inline fetch in to process-substitutes.
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 26fd054..717c232 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))
- 03/14: substitute: Remove redundant let block from fetch., (continued)
- 03/14: substitute: Remove redundant let block from fetch., guix-commits, 2021/02/22
- 04/14: guix: Move http-multiple-get to (guix http-client)., guix-commits, 2021/02/22
- 05/14: http-client: Add error handling to http-multiple-get., guix-commits, 2021/02/22
- 06/14: substitute: open-connection-for-uri/maybe add #:verify-certificate?., guix-commits, 2021/02/22
- 10/14: substitute: Remove now redundant connection caching helpers., guix-commits, 2021/02/22
- 08/14: http-client: Accept #:open-connection in http-fetch., guix-commits, 2021/02/22
- 07/14: substitute: Stop using call-with-cached-connection in fetch-narinfos., guix-commits, 2021/02/22
- 09/14: substitute: Change connection cache handling in process-substitution., guix-commits, 2021/02/22
- 13/14: substitute: Remove fetch-narinfos use open-connection-for-uri/maybe., guix-commits, 2021/02/22
- 11/14: substitute: Remove redundant fetch arguments., guix-commits, 2021/02/22
- 12/14: substitute: Inline fetch in to process-substitutes.,
guix-commits <=
- 14/14: substitute: Rework connection error handling., guix-commits, 2021/02/22