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) (sigaction SIGALRM SIG_DFL)
(apply values result))))) (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) (define (narinfo-cache-file cache-url path)
"Return the name of the local file that contains an entry for PATH. The "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." entry is stored in a sub-directory specific to CACHE-URL."
@ -706,6 +675,35 @@ the current output port."
(apply dump-file/deduplicate (apply dump-file/deduplicate
(append args (list #:store (%store-prefix))))) (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 (unless narinfo
(leave (G_ "no valid substitute for '~a'~%") (leave (G_ "no valid substitute for '~a'~%")
store-item)) store-item))