diff options
| -rw-r--r-- | guix/narinfo.scm | 21 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 35 | ||||
| -rw-r--r-- | tests/substitute.scm | 36 |
3 files changed, 71 insertions, 21 deletions
diff --git a/guix/narinfo.scm b/guix/narinfo.scm index 741c7ad406..a149d9a901 100644 --- a/guix/narinfo.scm +++ b/guix/narinfo.scm @@ -54,6 +54,7 @@ narinfo-hash-algorithm+value narinfo-hash->sha256 + narinfo-preferred-uris narinfo-best-uri valid-narinfo? @@ -309,9 +310,11 @@ than 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 @@ compression ratio (typically lzip)." ((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)))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 0b27ebb0fc..3626832dda 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -481,18 +481,29 @@ STATUS-PORT." (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))) - - (let* ((raw download-size - ;; 'guix publish' without '--cache' doesn't specify a - ;; Content-Length, so DOWNLOAD-SIZE is #f in this case. - (fetch uri)) + (define (try-fetch choices) + (match choices + (((uri compression file-size) rest ...) + (guard (c ((and (pair? rest) (http-get-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 ((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") diff --git a/tests/substitute.scm b/tests/substitute.scm index 9032a50268..8df3938b59 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -64,11 +64,11 @@ it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX." (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 @@ System: mips64el-linux\n"))) (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* |