@@ -54,6 +54,7 @@ (define-module (guix narinfo)
narinfo-hash-algorithm+value
narinfo-hash->sha256
+ narinfo-preferred-uris
narinfo-best-uri
valid-narinfo?
@@ -309,9 +310,11 @@ (define (decompresses-faster? compression1 compression2)
("gzip" (string=? compression2 "lzip"))
(_ #f)))
-(define* (narinfo-best-uri narinfo #:key fast-decompression?)
- "Select the \"best\" URI to download NARINFO's nar, and return three values:
-the URI, its compression method (a string), and the compressed file size.
+(define* (narinfo-preferred-uris narinfo #:key fast-decompression?)
+ "Return the sorted list of \"preferred\" nar URIs from NARINFO (preferred
+comes first) where each entry is a tuple containing: the URI, its compression
+method (a string), and the compressed file size.
+
When FAST-DECOMPRESSION? is true, prefer substitutes with faster
decompression (typically zstd) rather than substitutes with a higher
compression ratio (typically lzip)."
@@ -343,6 +346,16 @@ (define* (narinfo-best-uri narinfo #:key fast-decompression?)
((uri2 compression2 . _)
(decompresses-faster? compression2 compression1))))))
- (match (sort choices (if fast-decompression? (negate speed<?) file-size<?))
+ (sort choices (if fast-decompression? (negate speed<?) file-size<?)))
+
+(define* (narinfo-best-uri narinfo #:key fast-decompression?)
+ "Select the \"best\" URI to download NARINFO's nar, and return three values:
+the URI, its compression method (a string), and the compressed file size.
+
+When FAST-DECOMPRESSION? is true, prefer substitutes with faster
+decompression (typically zstd) rather than substitutes with a higher
+compression ratio (typically lzip)."
+ (match (narinfo-preferred-uris narinfo
+ #:fast-decompression? fast-decompression?)
(((uri compression file-size) _ ...)
(values uri compression file-size))))
@@ -481,18 +481,29 @@ (define* (download-nar narinfo destination
(leave (G_ "unsupported substitute URI scheme: ~a~%")
(uri->string uri)))))
- (let ((uri compression file-size
- (narinfo-best-uri narinfo
- #:fast-decompression?
- %prefer-fast-decompression?)))
- (unless print-build-trace?
- (format (current-error-port)
- (G_ "Downloading ~a...~%") (uri->string uri)))
+ (define (try-fetch choices)
+ (match choices
+ (((uri compression file-size) rest ...)
+ (guard (c ((and (pair? rest) (network-error? c))
+ (warning (G_ "download from '~a' failed, trying next URL~%")
+ (uri->string uri))
+ (try-fetch rest)))
+ (let ((port download-size (fetch uri)))
+ (unless print-build-trace?
+ (format (current-error-port)
+ (G_ "Downloading ~a...~%") (uri->string uri)))
+ (values port uri compression download-size))))
+ (()
+ (leave (G_ "no valid nar URLs for ~a at ~a~%")
+ (narinfo-path narinfo)
+ (narinfo-uri-base narinfo)))))
- (let* ((raw download-size
- ;; 'guix publish' without '--cache' doesn't specify a
- ;; Content-Length, so DOWNLOAD-SIZE is #f in this case.
- (fetch uri))
+ (let ((choices (narinfo-preferred-uris narinfo
+ #:fast-decompression?
+ %prefer-fast-decompression?)))
+ ;; 'guix publish' without '--cache' doesn't specify a Content-Length, so
+ ;; DOWNLOAD-SIZE is #f in this case.
+ (let* ((raw uri compression download-size (try-fetch choices))
(progress
(let* ((dl-size (or download-size
(and (equal? compression "none")
@@ -64,11 +64,11 @@ (define-syntax-rule (test-quit name error-rx exp)
(define (request-substitution item destination)
"Run 'guix substitute --substitute' to fetch ITEM to DESTINATION."
- (parameterize ((guix-warning-port (current-error-port)))
- (with-input-from-string (string-append "substitute " item " "
- destination "\n")
- (lambda ()
- (guix-substitute "--substitute")))))
+ (false-if-exception (delete-file destination))
+ (with-input-from-string (string-append "substitute " item " "
+ destination "\n")
+ (lambda ()
+ (guix-substitute "--substitute"))))
(define %public-key
;; This key is known to be in the ACL by default.
@@ -613,6 +613,32 @@ (define-syntax-rule (with-narinfo* narinfo directory body ...)
(lambda ()
(false-if-exception (delete-file "substitute-retrieved")))))))))))
+(test-equal "substitute, preferred nar URL is 404, other is 200"
+ "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)
+ "\n"
+ "URL: example.nar.lz\n"
+ "Compression: lzip\n"))
+ (404 "Sorry, nar.lz is missing!")
+ (200 ,(call-with-input-file
+ (string-append %main-substitute-directory
+ "/example.nar")
+ get-bytevector-all)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (parameterize ((substitute-urls (list (%local-url))))
+ (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*
If a substitute server advertises in its narinfo, for example, both a /zstd and a /lzip URL but the /zstd URL is unreachable, try the /lzip URL. Fixes <https://issues.guix.gnu.org/63634>. * guix/narinfo.scm (narinfo-preferred-uris): New procedure. (narinfo-best-uri): Rebase on top of it. * guix/scripts/substitute.scm (download-nar)[try-fetch]: New procedure. Use 'narinfo-preferred-uris' and 'try-fetch' to attempt all the URLs of NARINFO. * tests/substitute.scm (request-substitution): Remove 'parameterize'. Delete DESTINATION. ("substitute, preferred nar URL is 404, other is 200"): New test. --- guix/narinfo.scm | 21 +++++++++++++++++---- guix/scripts/substitute.scm | 33 ++++++++++++++++++++++----------- tests/substitute.scm | 36 +++++++++++++++++++++++++++++++----- 3 files changed, 70 insertions(+), 20 deletions(-) base-commit: dff1689bb37e5303868584d3f1d7a33cbcb7f51e