download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable.

This replaces ‘GUIX_DOWNLOAD_FALLBACK_TEST’ and allows you to test
various download methods, like so:

  GUIX_DOWNLOAD_METHODS=nar guix build guile-gcrypt -S --check
  GUIX_DOWNLOAD_METHODS=disarchive guix build hello -S --check

* guix/build/download.scm (%download-methods): New variable.
(download-method-enabled?): New procedure.
(url-fetch): Define ‘initial-uris’; honor ‘download-method-enabled?’.
Call ‘disarchive-fetch/any’ only when the 'disarchive method is enabled.
* guix/build/git.scm (git-fetch-with-fallback): Honor
‘download-method-enabled?’.
* guix/download.scm (%download-methods): New variable.
(%download-fallback-test): Remove.
(built-in-download): Add #:download-methods parameter and honor it.
(url-fetch*): Pass #:content-addressed-mirrors and #:disarchive-mirrors
unconditionally.
* guix/git-download.scm (git-fetch/in-band*): Pass “git url”
unconditionally.
(git-fetch/built-in): Likewise.  Pass “download-methods”.
* guix/bzr-download.scm (bzr-fetch)[build]: Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_METHODS’ to #:env-vars.
* guix/cvs-download.scm (cvs-fetch)[build]: Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_METHODS’ to #:env-vars.
* guix/hg-download.scm (hg-fetch): Honor ‘download-method-enabled?’.
Pass #:env-vars to ‘gexp->derivation’.
* guix/scripts/perform-download.scm (perform-download): Honor
“download-methods” from DRV.  Parameterize ‘%download-methods’ before
calling ‘url-fetch’.
(perform-git-download): Likewise.
* guix/svn-download.scm (svn-fetch): Honor ‘download-method-enabled?’.
Pass ‘GUIX_DOWNLOAD_METHODS’ to #:env-vars.
(svn-multi-fetch): Likewise.

Change-Id: Ia3402e17f0303dfa964bdc761265efe8a1dd69ab

1 files changed, 20 insertions, 33 deletions

diff --git a/guix/download.scm b/guix/download.scm
index 21d02ab203..3dfe143e9f 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2021, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@@ -35,9 +35,9 @@
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
-  #:export (%mirrors
+  #:export (%download-methods
+            %mirrors
             %disarchive-mirrors
-            %download-fallback-test
             (url-fetch* . url-fetch)
             url-fetch/executable
             url-fetch/tarbomb
@@ -434,10 +434,19 @@
 (define built-in-builders*
   (store-lift built-in-builders))
 
+(define %download-methods
+  ;; Either #f (the default) or a list of symbols denoting the sequence of
+  ;; download methods to be used--e.g., '(swh nar upstream).
+  (make-parameter
+   (and=> (getenv "GUIX_DOWNLOAD_METHODS")
+          (lambda (str)
+            (map string->symbol (string-tokenize str))))))
+
 (define* (built-in-download file-name url
                             #:key system hash-algo hash
                             mirrors content-addressed-mirrors
                             disarchive-mirrors
+                            (download-methods (%download-methods))
                             executable?
                             (guile 'unused))
   "Download FILE-NAME from URL using the built-in 'download' builder.  When
@@ -471,6 +480,11 @@ download by itself using its own dependencies."
                                  ("disarchive-mirrors" . ,disarchive-mirrors)
                                  ,@(if executable?
                                        '(("executable" . "1"))
+                                       '())
+                                 ,@(if download-methods
+                                       `(("download-methods"
+                                          . ,(object->string
+                                              download-methods)))
                                        '()))
 
                     ;; Do not offload this derivation because we cannot be
@@ -479,24 +493,6 @@ 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;
-  ;;
-  ;;   - 'none, to disable all the fallback mechanisms;
-  ;;
-  ;;   - '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))
@@ -532,10 +528,7 @@ name in the store."
           (unless (member "download" builtins)
             (error "'guix-daemon' is too old, please upgrade" builtins))
 
-          (built-in-download (or name file-name)
-                             (match (%download-fallback-test)
-                               ((or #f 'none) url)
-                               (_ "https://example.org/does-not-exist"))
+          (built-in-download (or name file-name) url
                              #:guile guile
                              #:system system
                              #:hash-algo hash-algo
@@ -543,15 +536,9 @@ name in the store."
                              #:executable? executable?
                              #:mirrors %mirror-file
                              #:content-addressed-mirrors
-                             (match (%download-fallback-test)
-                               ((or #f 'content-addressed-mirrors)
-                                %content-addressed-mirror-file)
-                               (_ %no-mirrors-file))
+                             %content-addressed-mirror-file
                              #:disarchive-mirrors
-                             (match (%download-fallback-test)
-                               ((or #f 'disarchive-mirrors)
-                                %disarchive-mirror-file)
-                               (_ %no-disarchive-mirrors-file)))))))
+                             %disarchive-mirror-file)))))
 
 (define* (url-fetch/executable url hash-algo hash
                                #:optional name