04/06: download: Add parameter to test download fallback mechanisms.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit c4a7aa82e25503133a1bd33148d17968c899a5f5
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Oct 14 15:41:43 2021 +0200

    download: Add parameter to test download fallback mechanisms.
    
    This allows you to run, say:
    
      GUIX_DOWNLOAD_FALLBACK_TEST=disarchive-mirrors guix build -S r-ebimage 
--check
    
    or:
    
      GUIX_DOWNLOAD_FALLBACK_TEST=content-addressed-mirrors ./pre-inst-env guix 
build -S r-ebimage --check
    
    to check whether these fallback mechanisms work as expected.
    
    * guix/download.scm (%no-mirrors-file, %no-disarchive-mirrors-file)
    (%download-fallback-test): New variables.
    (url-fetch*): Honor (%download-fallback-test).
---
 guix/download.scm | 40 +++++++++++++++++++++++++++++++++++++---
 1 file changed, 37 insertions(+), 3 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index 1324105..d5351d0 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -36,6 +36,7 @@
   #:use-module (srfi srfi-26)
   #:export (%mirrors
             %disarchive-mirrors
+            %download-fallback-test
             (url-fetch* . url-fetch)
             url-fetch/executable
             url-fetch/tarbomb
@@ -399,6 +400,10 @@
   (plain-file "content-addressed-mirrors"
               (object->string %content-addressed-mirrors)))
 
+(define %no-mirrors-file
+  ;; File specifying an empty list of mirrors, for fallback tests.
+  (plain-file "no-content-addressed-mirrors" (object->string ''())))
+
 (define %disarchive-mirrors
   ;; TODO: Eventually turn into a procedure that takes a hash algorithm
   ;; (symbol) and hash (bytevector).
@@ -408,6 +413,10 @@
 (define %disarchive-mirror-file
   (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors)))
 
+(define %no-disarchive-mirrors-file
+  ;; File specifying an empty list of Disarchive mirrors, for fallback tests.
+  (plain-file "no-disarchive-mirrors" (object->string '())))
+
 (define built-in-builders*
   (store-lift built-in-builders))
 
@@ -456,6 +465,22 @@ download by itself using its own dependencies."
                     ;; for that built-in is widespread.
                     #:local-build? #t)))
 
+(define %download-fallback-test
+  ;; Define whether to test one of the download fallback mechanism.  Possible
+  ;; values are:
+  ;;
+  ;;   - #f, to use the normal download methods, not trying to exercise the
+  ;;     fallback mechanism;
+  ;;
+  ;;   - 'content-addressed-mirrors, to purposefully attempt to download from
+  ;;     a content-addressed mirror;
+  ;;
+  ;;   - 'disarchive-mirrors, to download from Disarchive + Software Heritage.
+  ;;
+  ;; This is meant to be used for testing purposes.
+  (make-parameter (and=> (getenv "GUIX_DOWNLOAD_FALLBACK_TEST")
+                         string->symbol)))
+
 (define* (url-fetch* url hash-algo hash
                      #:optional name
                      #:key (system (%current-system))
@@ -491,7 +516,10 @@ name in the store."
           (unless (member "download" builtins)
             (error "'guix-daemon' is too old, please upgrade" builtins))
 
-          (built-in-download (or name file-name) url
+          (built-in-download (or name file-name)
+                             (if (%download-fallback-test)
+                                 "https://example.org/does-not-exist";
+                                 url)
                              #:guile guile
                              #:system system
                              #:hash-algo hash-algo
@@ -499,9 +527,15 @@ name in the store."
                              #:executable? executable?
                              #:mirrors %mirror-file
                              #:content-addressed-mirrors
-                             %content-addressed-mirror-file
+                             (match (%download-fallback-test)
+                               ((or #f 'content-addressed-mirrors)
+                                %content-addressed-mirror-file)
+                               (_ %no-mirrors-file))
                              #:disarchive-mirrors
-                             %disarchive-mirror-file)))))
+                             (match (%download-fallback-test)
+                               ((or #f 'disarchive-mirrors)
+                                %disarchive-mirror-file)
+                               (_ %no-disarchive-mirrors-file)))))))
 
 (define* (url-fetch/executable url hash-algo hash
                                #:optional name