Merge branch 'master' into emacs-team

4 files changed, 64 insertions, 28 deletions

diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm
index a0f5e15880..dede5e031a 100644
--- a/guix/build/bzr.scm
+++ b/guix/build/bzr.scm
@@ -37,6 +37,7 @@ revision identifier.  Return #t on success, else throw an exception."
   (invoke bzr-command "-Ossl.cert_reqs=none" "checkout"
           "--lightweight" "-r" revision url directory)
   (with-directory-excursion directory
-    (delete-file-recursively ".bzr")))
+    (delete-file-recursively ".bzr"))
+  #t)
 
 ;;; bzr.scm ends here
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
index 3ba121b7fb..f26ad28cd0 100644
--- a/guix/build/download-nar.scm
+++ b/guix/build/download-nar.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019, 2020, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,9 +57,9 @@ ITEM."
       (restore-file decompressed-port
                     item))))
 
-(define (download-nar item)
-  "Download and extract the normalized archive for ITEM.  Return #t on
-success, #f otherwise."
+(define* (download-nar item #:optional (output item))
+  "Download and extract to OUTPUT the normalized archive for ITEM, a store
+item.  Return #t on success, #f otherwise."
   ;; Let progress reports go through.
   (setvbuf (current-error-port) 'none)
   (setvbuf (current-output-port) 'none)
@@ -96,10 +96,10 @@ success, #f otherwise."
                                              #:download-size size)))
                  (if (string-contains url "/lzip")
                      (restore-lzipped-nar port-with-progress
-                                          item
+                                          output
                                           size)
                      (restore-file port-with-progress
-                                   item)))
+                                   output)))
                (newline)
                #t))))
       (()
diff --git a/guix/build/download.scm b/guix/build/download.scm
index db0a39084b..74b7486b7b 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
@@ -40,7 +40,10 @@
   #:autoload   (guix swh) (swh-download-directory %verify-swh-certificate?)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:export (open-socket-for-uri
+  #:export (%download-methods
+            download-method-enabled?
+
+            open-socket-for-uri
             open-connection-for-uri
             http-fetch
             %x509-certificate-directory
@@ -622,6 +625,20 @@ true, verify HTTPS certificates; otherwise simply ignore them."
     (lambda (key . args)
       (print-exception (current-error-port) #f key args))))
 
+(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 (download-method-enabled? method)
+  "Return true if METHOD (a symbol such as 'swh) is enabled as part of the
+download fallback sequence."
+  (or (not (%download-methods))
+      (memq method (%download-methods))))
+
 (define (uri-vicinity dir file)
   "Concatenate DIR, slash, and FILE, keeping only one slash in between.
 This is required by some HTTP servers."
@@ -788,18 +805,28 @@ otherwise simply ignore them."
                          hashes)))
                 disarchive-mirrors))
 
+  (define initial-uris
+    (append (if (download-method-enabled? 'upstream)
+                uri
+                '())
+            (if (download-method-enabled? 'content-addressed-mirrors)
+                content-addressed-uris
+                '())
+            (if (download-method-enabled? 'internet-archive)
+                (match uri
+                  ((first . _)
+                   (or (and=> (internet-archive-uri first) list)
+                       '()))
+                  (() '()))
+                '())))
+
   ;; Make this unbuffered so 'progress-report/file' works as expected.  'line
   ;; means '\n', not '\r', so it's not appropriate here.
   (setvbuf (current-output-port) 'none)
 
   (setvbuf (current-error-port) 'line)
 
-  (let try ((uri (append uri content-addressed-uris
-                   (match uri
-                     ((first . _)
-                      (or (and=> (internet-archive-uri first) list)
-                          '()))
-                     (() '())))))
+  (let try ((uri initial-uris))
     (match uri
       ((uri tail ...)
        (or (fetch uri file)
@@ -807,9 +834,10 @@ otherwise simply ignore them."
       (()
        ;; If we are looking for a software archive, one last thing we
        ;; can try is to use Disarchive to assemble it.
-       (or (disarchive-fetch/any disarchive-uris file
-                                 #:verify-certificate? verify-certificate?
-                                 #:timeout timeout)
+       (or (and (download-method-enabled? 'disarchive)
+                (disarchive-fetch/any disarchive-uris file
+                                      #:verify-certificate? verify-certificate?
+                                      #:timeout timeout))
            (begin
              (format (current-error-port) "failed to download ~s from ~s~%"
                      file url)
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 4c69365a7b..62877394bb 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -19,6 +19,8 @@
 
 (define-module (guix build git)
   #:use-module (guix build utils)
+  #:use-module ((guix build download)
+                #:select (download-method-enabled?))
   #:autoload   (guix build download-nar) (download-nar)
   #:autoload   (guix swh) (%verify-swh-certificate?
                            swh-download
@@ -92,25 +94,30 @@ fetched, recursively.  Return #t on success, #f otherwise."
 
 
 (define* (git-fetch-with-fallback url commit directory
-                                  #:key (git-command "git")
+                                  #:key (item directory)
+                                  (git-command "git")
                                   hash hash-algorithm
                                   lfs? recursive?)
   "Like 'git-fetch', fetch COMMIT from URL into DIRECTORY, but fall back to
-alternative methods when fetching from URL fails: attempt to download a nar,
-and if that also fails, download from the Software Heritage archive.  When
-HASH and HASH-ALGORITHM are provided, they are interpreted as the nar hash of
-the directory of interested and are used as its content address at SWH."
-  (or (git-fetch url commit directory
-                 #:lfs? lfs?
-                 #:recursive? recursive?
-                 #:git-command git-command)
-      (download-nar directory)
+alternative methods when fetching from URL fails: attempt to download a nar
+for ITEM, and if that also fails, download from the Software Heritage archive.
+When HASH and HASH-ALGORITHM are provided, they are interpreted as the nar
+hash of the directory of interested and are used as its content address at
+SWH."
+  (or (and (download-method-enabled? 'upstream)
+           (git-fetch url commit directory
+                      #:lfs? lfs?
+                      #:recursive? recursive?
+                      #:git-command git-command))
+      (and (download-method-enabled? 'nar)
+           (download-nar item directory))
 
       ;; As a last resort, attempt to download from Software Heritage.
       ;; Disable X.509 certificate verification to avoid depending
       ;; on nss-certs--we're authenticating the checkout anyway.
       ;; XXX: Currently recursive checkouts are not supported.
       (and (not recursive?)
+           (download-method-enabled? 'swh)
            (parameterize ((%verify-swh-certificate? #f))
              (format (current-error-port)
                      "Trying to download from Software Heritage...~%")