me/guix
Archived
1
0
Fork 0
Code Activity

substitute: Inline fetch in to process-substitutes.

Browse source 
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.
This commit is contained in:
Christopher Baines 2021-01-07 20:41:50 +00:00
parent b9d058e3f7
commit 8116cc6673
No known key found for this signature in database
GPG key ID: 5E28A33B0B84F577
1 changed files with 29 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
guix/scripts/substitute.scm
View file

@ -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))