From: "Ludovic Courtès" <ludo@gnu.org>
To: 69328@debbugs.gnu.org
Cc: "Timothy Sample" <samplet@ngyro.com>,
"Ludovic Courtès" <ludo@gnu.org>,
"Christopher Baines" <guix@cbaines.net>,
"Josselin Poiret" <dev@jpoiret.xyz>,
"Ludovic Courtès" <ludo@gnu.org>,
"Mathieu Othacehe" <othacehe@gnu.org>,
"Ricardo Wurmus" <rekado@elephly.net>,
"Simon Tournier" <zimon.toutoune@gmail.com>,
"Tobias Geerinckx-Rice" <me@tobias.gr>
Subject: [bug#69328] [PATCH v2 12/12] download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable.
Date: Tue, 5 Mar 2024 12:07:00 +0100 [thread overview]
Message-ID: <e893fbe58507224a6f7bba6c9f8a1b77dcdd600a.1709636144.git.ludo@gnu.org> (raw)
In-Reply-To: <87o7btc5du.fsf@gnu.org>
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
---
guix/build/download.scm | 50 ++++++++++++++----
guix/build/git.scm | 15 ++++--
guix/bzr-download.scm | 28 ++++++----
guix/cvs-download.scm | 24 ++++++---
guix/download.scm | 53 +++++++------------
guix/git-download.scm | 20 +++----
guix/hg-download.scm | 36 ++++++++-----
guix/scripts/perform-download.scm | 70 +++++++++++++-----------
guix/svn-download.scm | 88 +++++++++++++++++++------------
9 files changed, 230 insertions(+), 154 deletions(-)
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 @@ (define-module (guix build download)
#: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 @@ (define-syntax-rule (false-if-exception* body ...)
(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 @@ (define* (url-fetch url file
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 @@ (define* (url-fetch url file
(()
;; 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 a135026fae..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
@@ -102,17 +104,20 @@ (define* (git-fetch-with-fallback url commit directory
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 item directory)
+ (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...~%")
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index 01c12fd54d..a22c9bee99 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -24,7 +24,7 @@ (define-module (guix bzr-download)
#:use-module (guix packages)
#:use-module (guix records)
#:use-module (guix store)
-
+ #:use-module (ice-9 match)
#:export (bzr-reference
bzr-reference?
bzr-reference-url
@@ -72,20 +72,26 @@ (define* (bzr-fetch ref hash-algo hash
(with-imported-modules (source-module-closure
'((guix build bzr)
(guix build utils)
+ (guix build download)
(guix build download-nar)))
#~(begin
(use-modules (guix build bzr)
(guix build download-nar)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build utils)
(srfi srfi-34))
- (or (guard (c ((invoke-error? c)
- (report-invoke-error c)
- #f))
- (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
- #$output
- #:bzr-command (string-append #+bzr "/bin/brz")))
- (download-nar #$output))))))
+ (or (and (download-method-enabled? 'upstream)
+ (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ #f))
+ (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
+ #$output
+ #:bzr-command
+ (string-append #+bzr "/bin/brz"))))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "bzr-branch") build
@@ -95,7 +101,11 @@ (define* (bzr-fetch ref hash-algo hash
#:script-name "bzr-download"
#:env-vars
`(("bzr url" . ,(bzr-reference-url ref))
- ("bzr reference" . ,(bzr-reference-revision ref)))
+ ("bzr reference" . ,(bzr-reference-revision ref))
+ ,@(match (getenv "GUIX_DOWNLOAD_METHODS")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_METHODS" . ,value)))))
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index c0c526b9db..023054941b 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
@@ -73,6 +73,7 @@ (define* (cvs-fetch ref hash-algo hash
(define modules
(delete '(guix config)
(source-module-closure '((guix build cvs)
+ (guix build download)
(guix build download-nar)))))
(define build
(with-imported-modules modules
@@ -80,20 +81,29 @@ (define* (cvs-fetch ref hash-algo hash
guile-lzlib)
#~(begin
(use-modules (guix build cvs)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build download-nar))
- (or (cvs-fetch '#$(cvs-reference-root-directory ref)
- '#$(cvs-reference-module ref)
- '#$(cvs-reference-revision ref)
- #$output
- #:cvs-command (string-append #+cvs "/bin/cvs"))
- (download-nar #$output))))))
+ (or (and (download-method-enabled? 'upstream)
+ (cvs-fetch '#$(cvs-reference-root-directory ref)
+ '#$(cvs-reference-module ref)
+ '#$(cvs-reference-revision ref)
+ #$output
+ #:cvs-command
+ #+(file-append cvs "/bin/cvs")))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "cvs-checkout") build
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
+ #:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_METHODS" . ,value))))
#:system system
#:hash-algo hash-algo
#:hash hash
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 @@ (define-module (guix download)
#: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 %no-disarchive-mirrors-file
(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 @@ (define* (built-in-download file-name url
("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 @@ (define* (built-in-download file-name url
;; 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 @@ (define* (url-fetch* url hash-algo hash
(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 @@ (define* (url-fetch* url hash-algo hash
#: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
diff --git a/guix/git-download.scm b/guix/git-download.scm
index aadcbd234c..d26a814e07 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -29,8 +29,8 @@ (define-module (guix git-download)
#:use-module (guix packages)
#:use-module (guix modules)
#:use-module ((guix derivations) #:select (raw-derivation))
+ #:autoload (guix download) (%download-methods)
#:autoload (guix build-system gnu) (standard-packages)
- #:autoload (guix download) (%download-fallback-test)
#:autoload (git bindings) (libgit2-init!)
#:autoload (git repository) (repository-open
repository-close!
@@ -180,11 +180,7 @@ (define* (git-fetch/in-band* ref hash-algo hash
;; downloads.
#:script-name "git-download"
#:env-vars
- `(("git url" . ,(match (%download-fallback-test)
- ('content-addressed-mirrors
- "https://example.org/does-not-exist")
- (_
- (git-reference-url ref))))
+ `(("git url" . ,(git-reference-url ref))
("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string
(git-reference-recursive? ref)))
@@ -246,14 +242,14 @@ (define* (git-fetch/built-in ref hash-algo hash
#:recursive? #t
#:env-vars
`(("url" . ,(object->string
- (match (%download-fallback-test)
- ('content-addressed-mirrors
- "https://example.org/does-not-exist")
- (_
- (git-reference-url ref)))))
+ (git-reference-url ref)))
("commit" . ,(git-reference-commit ref))
("recursive?" . ,(object->string
- (git-reference-recursive? ref))))
+ (git-reference-recursive? ref)))
+ ,@(if (%download-methods)
+ `(("download-methods"
+ . ,(object->string (%download-methods))))
+ '()))
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index dd28d9c244..55d908817f 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -84,6 +84,7 @@ (define* (hg-fetch ref hash-algo hash
(define modules
(delete '(guix config)
(source-module-closure '((guix build hg)
+ (guix build download)
(guix build download-nar)
(guix swh)))))
@@ -94,6 +95,8 @@ (define* (hg-fetch ref hash-algo hash
#~(begin
(use-modules (guix build hg)
(guix build utils) ;for `set-path-environment-variable'
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build download-nar)
(guix swh)
(ice-9 match))
@@ -106,28 +109,35 @@ (define* (hg-fetch ref hash-algo hash
(setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line)
- (or (hg-fetch '#$(hg-reference-url ref)
- '#$(hg-reference-changeset ref)
- #$output
- #:hg-command (string-append #+hg "/bin/hg"))
- (download-nar #$output)
+ (or (and (download-method-enabled? 'upstream)
+ (hg-fetch '#$(hg-reference-url ref)
+ '#$(hg-reference-changeset ref)
+ #$output
+ #:hg-command (string-append #+hg "/bin/hg")))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output))
;; 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.
- (parameterize ((%verify-swh-certificate? #f))
- (format (current-error-port)
- "Trying to download from Software Heritage...~%")
- (or (swh-download-directory-by-nar-hash #$hash '#$hash-algo
- #$output)
- (swh-download #$(hg-reference-url ref)
- #$(hg-reference-changeset ref)
- #$output))))))))
+ (and (download-method-enabled? 'swh)
+ (parameterize ((%verify-swh-certificate? #f))
+ (format (current-error-port)
+ "Trying to download from Software Heritage...~%")
+ (or (swh-download-directory-by-nar-hash
+ #$hash '#$hash-algo #$output)
+ (swh-download #$(hg-reference-url ref)
+ #$(hg-reference-changeset ref)
+ #$output)))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS")
+ #:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_METHODS" . ,value))))
#:system system
#:local-build? #t ;don't offload repo cloning
#:hash-algo hash-algo
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index b96959a09e..5079d0ea71 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -21,7 +21,7 @@ (define-module (guix scripts perform-download)
#:use-module (guix scripts)
#:use-module (guix derivations)
#:use-module ((guix store) #:select (derivation-path? store-path?))
- #:autoload (guix build download) (url-fetch)
+ #:autoload (guix build download) (%download-methods url-fetch)
#:autoload (guix build git) (git-fetch-with-fallback)
#:autoload (guix config) (%git)
#:use-module (ice-9 match)
@@ -55,7 +55,8 @@ (define* (perform-download drv output
(executable "executable")
(mirrors "mirrors")
(content-addressed-mirrors "content-addressed-mirrors")
- (disarchive-mirrors "disarchive-mirrors"))
+ (disarchive-mirrors "disarchive-mirrors")
+ (download-methods "download-methods"))
(unless url
(leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
@@ -64,26 +65,30 @@ (define* (perform-download drv output
(algo (derivation-output-hash-algo drv-output))
(hash (derivation-output-hash drv-output)))
;; We're invoked by the daemon, which gives us write access to OUTPUT.
- (when (url-fetch url output
- #:print-build-trace? print-build-trace?
- #:mirrors (if mirrors
- (call-with-input-file mirrors read)
- '())
- #:content-addressed-mirrors
- (if content-addressed-mirrors
- (call-with-input-file content-addressed-mirrors
- (lambda (port)
- (eval (read port) %user-module)))
- '())
- #:disarchive-mirrors
- (if disarchive-mirrors
- (call-with-input-file disarchive-mirrors read)
- '())
- #:hashes `((,algo . ,hash))
+ (when (parameterize ((%download-methods
+ (and download-methods
+ (call-with-input-string download-methods
+ read))))
+ (url-fetch url output
+ #:print-build-trace? print-build-trace?
+ #:mirrors (if mirrors
+ (call-with-input-file mirrors read)
+ '())
+ #:content-addressed-mirrors
+ (if content-addressed-mirrors
+ (call-with-input-file content-addressed-mirrors
+ (lambda (port)
+ (eval (read port) %user-module)))
+ '())
+ #:disarchive-mirrors
+ (if disarchive-mirrors
+ (call-with-input-file disarchive-mirrors read)
+ '())
+ #:hashes `((,algo . ,hash))
- ;; Since DRV's output hash is known, X.509 certificate
- ;; validation is pointless.
- #:verify-certificate? #f)
+ ;; Since DRV's output hash is known, X.509 certificate
+ ;; validation is pointless.
+ #:verify-certificate? #f))
(when (and executable (string=? executable "1"))
(chmod output #o755))))))
@@ -96,7 +101,8 @@ (define* (perform-git-download drv output
'bmRepair' builds."
(derivation-let drv ((url "url")
(commit "commit")
- (recursive? "recursive?"))
+ (recursive? "recursive?")
+ (download-methods "download-methods"))
(unless url
(leave (G_ "~a: missing Git URL~%") (derivation-file-name drv)))
(unless commit
@@ -114,14 +120,18 @@ (define* (perform-git-download drv output
;; on ambient authority, hence the PATH value below.
(setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
- ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
- ;; different, hence the #:item argument below.
- (git-fetch-with-fallback url commit output
- #:hash hash
- #:hash-algorithm algo
- #:recursive? recursive?
- #:item (derivation-output-path drv-output)
- #:git-command %git))))
+ (parameterize ((%download-methods
+ (and download-methods
+ (call-with-input-string download-methods
+ read))))
+ ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
+ ;; different, hence the #:item argument below.
+ (git-fetch-with-fallback url commit output
+ #:hash hash
+ #:hash-algorithm algo
+ #:recursive? recursive?
+ #:item (derivation-output-path drv-output)
+ #:git-command %git)))))
(define (assert-low-privileges)
(when (zero? (getuid))
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 64af996a06..17a7f4f957 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -93,6 +93,7 @@ (define* (svn-fetch ref hash-algo hash
(define build
(with-imported-modules
(source-module-closure '((guix build svn)
+ (guix build download)
(guix build download-nar)
(guix build utils)
(guix swh)))
@@ -100,23 +101,28 @@ (define* (svn-fetch ref hash-algo hash
guile-lzlib)
#~(begin
(use-modules (guix build svn)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build download-nar)
(guix swh)
(ice-9 match))
- (or (svn-fetch (getenv "svn url")
- (string->number (getenv "svn revision"))
- #$output
- #:svn-command #+(file-append svn "/bin/svn")
- #:recursive? (match (getenv "svn recursive?")
- ("yes" #t)
- (_ #f))
- #:user-name (getenv "svn user name")
- #:password (getenv "svn password"))
- (download-nar #$output)
- (parameterize ((%verify-swh-certificate? #f))
- (swh-download-directory-by-nar-hash #$hash '#$hash-algo
- #$output)))))))
+ (or (and (download-method-enabled? 'upstream)
+ (svn-fetch (getenv "svn url")
+ (string->number (getenv "svn revision"))
+ #$output
+ #:svn-command #+(file-append svn "/bin/svn")
+ #:recursive? (match (getenv "svn recursive?")
+ ("yes" #t)
+ (_ #f))
+ #:user-name (getenv "svn user name")
+ #:password (getenv "svn password")))
+ (and (download-method-enabled? 'nar)
+ (download-nar #$output))
+ (and (download-method-enabled? 'swh)
+ (parameterize ((%verify-swh-certificate? #f))
+ (swh-download-directory-by-nar-hash #$hash '#$hash-algo
+ #$output))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
@@ -139,7 +145,11 @@ (define* (svn-fetch ref hash-algo hash
,@(if (svn-reference-password ref)
`(("svn password"
. ,(svn-reference-password ref)))
- '()))
+ '())
+ ,@(match (getenv "GUIX_DOWNLOAD_METHODS")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_METHODS" . ,value)))))
#:system system
#:hash-algo hash-algo
@@ -178,6 +188,7 @@ (define* (svn-multi-fetch ref hash-algo hash
(define build
(with-imported-modules
(source-module-closure '((guix build svn)
+ (guix build download)
(guix build download-nar)
(guix build utils)
(guix swh)))
@@ -186,6 +197,8 @@ (define* (svn-multi-fetch ref hash-algo hash
#~(begin
(use-modules (guix build svn)
(guix build utils)
+ ((guix build download)
+ #:select (download-method-enabled?))
(guix build download-nar)
(guix swh)
(srfi srfi-1)
@@ -197,30 +210,33 @@ (define* (svn-multi-fetch ref hash-algo hash
;; single file.
(unless (string-suffix? "/" location)
(mkdir-p (string-append #$output "/" (dirname location))))
- (svn-fetch (string-append (getenv "svn url") "/" location)
- (string->number (getenv "svn revision"))
- (if (string-suffix? "/" location)
- (string-append #$output "/" location)
- (string-append #$output "/" (dirname location)))
- #:svn-command #+(file-append svn "/bin/svn")
- #:recursive? (match (getenv "svn recursive?")
- ("yes" #t)
- (_ #f))
- #:user-name (getenv "svn user name")
- #:password (getenv "svn password")))
+ (and (download-method-enabled? 'upstream)
+ (svn-fetch (string-append (getenv "svn url") "/" location)
+ (string->number (getenv "svn revision"))
+ (if (string-suffix? "/" location)
+ (string-append #$output "/" location)
+ (string-append #$output "/" (dirname location)))
+ #:svn-command #+(file-append svn "/bin/svn")
+ #:recursive? (match (getenv "svn recursive?")
+ ("yes" #t)
+ (_ #f))
+ #:user-name (getenv "svn user name")
+ #:password (getenv "svn password"))))
(call-with-input-string (getenv "svn locations")
read))
(begin
(when (file-exists? #$output)
(delete-file-recursively #$output))
- (or (download-nar #$output)
- (parameterize ((%verify-swh-certificate? #f))
- ;; SWH keeps HASH as an ExtID for the combination of
- ;; files/directories, which allows us to retrieve the
- ;; entire combination at once:
- ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>.
- (swh-download-directory-by-nar-hash
- #$hash '#$hash-algo #$output)))))))))
+ (or (and (download-method-enabled? 'nar)
+ (download-nar #$output))
+ (and (download-method-enabled? 'swh)
+ ;; SWH keeps HASH as an ExtID for the combination
+ ;; of files/directories, which allows us to
+ ;; retrieve the entire combination at once:
+ ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>.
+ (parameterize ((%verify-swh-certificate? #f))
+ (swh-download-directory-by-nar-hash
+ #$hash '#$hash-algo #$output))))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
@@ -245,7 +261,11 @@ (define* (svn-multi-fetch ref hash-algo hash
,@(if (svn-multi-reference-password ref)
`(("svn password"
. ,(svn-multi-reference-password ref)))
- '()))
+ '())
+ ,@(match (getenv "GUIX_DOWNLOAD_METHODS")
+ (#f '())
+ (value
+ `(("GUIX_DOWNLOAD_METHODS" . ,value)))))
#:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG"
--
2.41.0
prev parent reply other threads:[~2024-03-05 11:09 UTC|newest]
Thread overview: 33+ messages / expand[flat|nested] mbox.gz Atom feed top
2024-02-23 14:22 [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 01/12] lint: Switch to SRFI-71 Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 08/12] svn-download: " Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 09/12] bzr-download: Implement nar fallback Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès
2024-02-23 15:48 ` [bug#69328] [PATCH 12/12] download: Honor ‘GUIX_DOWNLOAD_SEQUENCE’ environment variable Ludovic Courtès
2024-03-03 4:53 ` Timothy Sample
2024-03-05 10:26 ` Ludovic Courtès
2024-02-23 15:53 ` [bug#69328] [PATCH 00/12] Better source code recovery from SWH Ludovic Courtès
2024-03-03 4:54 ` Timothy Sample
2024-03-05 10:58 ` Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 " Ludovic Courtès
2024-03-07 18:38 ` Simon Tournier
2024-03-09 18:51 ` bug#69328: " Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 01/12] lint: Switch to SRFI-71 Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 02/12] lint: archival: Fix crash in non-Git case Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 03/12] lint: archival: Trigger “Save Code Now” for VCSes other than Git Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 04/12] swh: Add ‘type’ field to <visit> Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 05/12] swh: ‘origin-visits’ takes an optional ‘max’ parameter Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 07/12] hg-download: Use ‘swh-download-directory-by-nar-hash’ Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 08/12] svn-download: " Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 09/12] bzr-download: Implement nar fallback Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 10/12] download-nar: Distinguish ‘output’ and ‘item’ parameter Ludovic Courtès
2024-03-05 11:06 ` [bug#69328] [PATCH v2 11/12] perform-download: Allow use of ‘download-nar’ for ‘--check’ builds Ludovic Courtès
2024-03-05 11:07 ` Ludovic Courtès [this message]
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=e893fbe58507224a6f7bba6c9f8a1b77dcdd600a.1709636144.git.ludo@gnu.org \
--to=ludo@gnu.org \
--cc=69328@debbugs.gnu.org \
--cc=dev@jpoiret.xyz \
--cc=guix@cbaines.net \
--cc=me@tobias.gr \
--cc=othacehe@gnu.org \
--cc=rekado@elephly.net \
--cc=samplet@ngyro.com \
--cc=zimon.toutoune@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.