From c4a7aa82e25503133a1bd33148d17968c899a5f5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 14 Oct 2021 15:41:43 +0200
Subject: 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(-)

(limited to 'guix/download.scm')

diff --git a/guix/download.scm b/guix/download.scm
index 13241053bf..d5351d0673 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
-- 
cgit v1.2.3