02/06: substitute: If a server's nar URL is 404, try the next one(s).

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 8af9a2aa5fa2fa5b00234c1cbe12e9aff60888a0
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon May 22 17:19:39 2023 +0200

    substitute: If a server's nar URL is 404, try the next one(s).
    
    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 | 35 +++++++++++++++++++++++------------
 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*