Toggle diff (264 lines)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index e3b382d0d8..cf59db4315 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -460,25 +460,20 @@ (define (fetch uri)
(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~%")))
- (with-cached-connection uri port
- (http-fetch uri #:text? #f
- #:port port
- #:keep-alive? #t
- #:buffered? #f)))))
+ ;; 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))))
(else
(leave (G_ "unsupported substitute URI scheme: ~a~%")
(uri->string uri)))))
@@ -572,6 +567,68 @@ (define cpu-usage
(bytevector->nix-base32-string expected)
(bytevector->nix-base32-string actual)))))))
+(define system-error?
+ (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args)))
+ (lambda (exception)
+ "Return true if EXCEPTION is a Guile 'system-error exception."
+ (and (kind-and-args? exception)
+ (eq? 'system-error (exception-kind exception))))))
+
+(define network-error?
+ (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args)))
+ (lambda (exception)
+ "Return true if EXCEPTION denotes a networking error."
+ (or (and (system-error? exception)
+ (let ((errno (system-error-errno
+ (cons 'system-error (exception-args exception)))))
+ (memv errno (list ECONNRESET ECONNABORTED
+ ECONNREFUSED EHOSTUNREACH
+ ENOENT)))) ;for "file://"
+ (and (kind-and-args? exception)
+ (memq (exception-kind exception)
+ '(gnutls-error getaddrinfo-error)))
+ (and (http-get-error? exception)
+ (begin
+ (warning (G_ "download from '~a' failed: ~a, ~s~%")
+ (uri->string (http-get-error-uri exception))
+ (http-get-error-code exception)
+ (http-get-error-reason exception))
+ #t))))))
+
+(define* (process-substitution/fallback port narinfo destination
+ #:key cache-urls acl
+ deduplicate? print-build-trace?)
+ "Attempt to substitute NARINFO, which is assumed to be authorized or
+equivalent, by trying to download its nar from each entry in CACHE-URLS.
+
+This can be less efficient than 'lookup-narinfo', which stops at the first
+entry that provides a valid narinfo, but it makes sure we eventually find a
+way to download the nar."
+ ;; Note: Keep NARINFO's uri-base in CACHE-URLS: that lets us retry in case
+ ;; this was a transient issue.
+ (let loop ((cache-urls cache-urls))
+ (match cache-urls
+ (()
+ (leave (G_ "failed to find alternative substitute for '~a'~%")
+ (narinfo-path narinfo)))
+ ((cache-url rest ...)
+ (match (lookup-narinfos cache-url
+ (list (narinfo-path narinfo))
+ #:open-connection
+ open-connection-for-uri/cached)
+ ((alternate)
+ (if (or (equivalent-narinfo? narinfo alternate)
+ (valid-narinfo? alternate acl)
+ (%allow-unauthenticated-substitutes?))
+ (guard (c ((network-error? c) (loop rest)))
+ (download-nar alternate destination
+ #:status-port port
+ #:deduplicate? deduplicate?
+ #:print-build-trace? print-build-trace?))
+ (loop rest)))
+ (()
+ (loop rest)))))))
+
(define* (process-substitution port store-item destination
#:key cache-urls acl
deduplicate? print-build-trace?)
@@ -590,10 +647,20 @@ (define narinfo
(leave (G_ "no valid substitute for '~a'~%")
store-item))
- (download-nar narinfo destination
- #:status-port port
- #:deduplicate? deduplicate?
- #:print-build-trace? print-build-trace?))
+ (guard (c ((network-error? c)
+ (format (current-error-port)
+ (G_ "retrying download of '~a' with other substitute URLs...~%")
+ store-item)
+ (process-substitution/fallback port narinfo destination
+ #:cache-urls cache-urls
+ #:acl acl
+ #:deduplicate? deduplicate?
+ #:print-build-trace?
+ print-build-trace?)))
+ (download-nar narinfo destination
+ #:status-port port
+ #:deduplicate? deduplicate?
+ #:print-build-trace? print-build-trace?)))
;;;
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 5315292987..9032a50268 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -523,6 +523,119 @@ (define-syntax-rule (with-narinfo* narinfo directory body ...)
(lambda ()
(false-if-exception (delete-file "substitute-retrieved")))))))
+(test-equal "substitute, first URL has narinfo but lacks nar, second URL unauthorized"
+ "Substitutable data."
+ (with-narinfo*
+ (string-append %narinfo "Signature: "
+ (signature-field
+ %narinfo
+ #:public-key %wrong-public-key))
+ %alternate-substitute-directory
+
+ (with-narinfo* (string-append %narinfo "Signature: "
+ (signature-field %narinfo))
+ %main-substitute-directory
+
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ ;; Remove this file so that the substitute can only be retrieved
+ ;; from %ALTERNATE-SUBSTITUTE-DIRECTORY.
+ (delete-file (string-append %main-substitute-directory
+ "/example.nar"))
+
+ (parameterize ((substitute-urls
+ (map (cut string-append "file://" <>)
+ (list %main-substitute-directory
+ %alternate-substitute-directory))))
+ (request-substitution (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))
+ (call-with-input-file "substitute-retrieved" get-string-all))
+ (lambda ()
+ (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first URL has narinfo but nar is 404, both URLs authorized"
+ "Substitutable data."
+ (with-narinfo*
+ (string-append %narinfo "Signature: "
+ (signature-field %narinfo))
+ %main-substitute-directory
+
+ (with-http-server `((200 ,(string-append %narinfo "Signature: "
+ (signature-field %narinfo)))
+ (404 "Sorry, nar is missing!"))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (parameterize ((substitute-urls
+ (list (%local-url)
+ (string-append "file://"
+ %main-substitute-directory))))
+ (request-substitution (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))
+ (call-with-input-file "substitute-retrieved" get-string-all))
+ (lambda ()
+ (false-if-exception (delete-file "substitute-retrieved")))))))
+
+(test-equal "substitute, first URL has narinfo but nar is 404, one URL authorized"
+ "Substitutable data."
+ (with-narinfo*
+ (string-append %narinfo "Signature: "
+ (signature-field
+ %narinfo
+ #:public-key %wrong-public-key))
+ %main-substitute-directory
+
+ (with-http-server `((200 ,(string-append %narinfo "Signature: "
+ (signature-field
+ %narinfo
+ #:public-key %wrong-public-key)))
+ (404 "Sorry, nar is missing!"))
+ (let ((url1 (%local-url)))
+ (parameterize ((%http-server-port 0))
+ (with-http-server `((200 ,(string-append %narinfo "Signature: "
+ (signature-field %narinfo)))
+ (404 "Sorry, nar is missing!"))
+ (let ((url2 (%local-url)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (parameterize ((substitute-urls
+ (list url1 url2
+ (string-append "file://"
+ %main-substitute-directory))))
+ (request-substitution (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved"))
+ (call-with-input-file "substitute-retrieved" get-string-all))
+ (lambda ()
+ (false-if-exception (delete-file "substitute-retrieved")))))))))))
+
+(test-quit "substitute, narinfo is available but nar is missing"
+ "failed to find alternative substitute"
+ (with-narinfo*
+ (string-append %narinfo "Signature: "
+ (signature-field
+ %narinfo
+ #:public-key %wrong-public-key))
+ %main-substitute-directory
+
+ (with-http-server `((200 ,(string-append %narinfo "Signature: "
+ (signature-field %narinfo)))
+ (404 "Sorry, nar is missing!"))
+ (parameterize ((substitute-urls
+ (list (%local-url)
+ (string-append "file://"
+ %main-substitute-directory))))
+ (delete-file (string-append %main-substitute-directory
+ "/example.nar"))
+ (request-substitution (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ "substitute-retrieved")
+ (not (file-exists? "substitute-retrieved"))))))
+
(test-equal "substitute, first narinfo is unsigned and has wrong hash"
"Substitutable data."
(with-narinfo* (regexp-substitute #f
--
2.37.3
