ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 22:08:16 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

download: Honor ‘GUIX_DOWNLOAD_METHODS’ environment variable.

Browse source 
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
This commit is contained in:
Ludovic Courtès 2024-02-23 14:42:43 +01:00
parent abd0cca2a9
commit 2f441fc738
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
9 changed files with 230 additions and 154 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
guix/build/download.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com> ;;; 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?) #:autoload (guix swh) (swh-download-directory %verify-swh-certificate?)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:export (open-socket-for-uri #:export (%download-methods
download-method-enabled?
open-socket-for-uri
open-connection-for-uri open-connection-for-uri
http-fetch http-fetch
%x509-certificate-directory %x509-certificate-directory
@ -622,6 +625,20 @@ (define-syntax-rule (false-if-exception* body ...)
(lambda (key . args) (lambda (key . args)
(print-exception (current-error-port) #f 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) (define (uri-vicinity dir file)
"Concatenate DIR, slash, and FILE, keeping only one slash in between. "Concatenate DIR, slash, and FILE, keeping only one slash in between.
This is required by some HTTP servers." This is required by some HTTP servers."
@ -788,18 +805,28 @@ (define disarchive-uris
hashes))) hashes)))
disarchive-mirrors)) 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 ;; Make this unbuffered so 'progress-report/file' works as expected. 'line
;; means '\n', not '\r', so it's not appropriate here. ;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) 'none) (setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'line) (setvbuf (current-error-port) 'line)
(let try ((uri (append uri content-addressed-uris (let try ((uri initial-uris))
(match uri
((first . _)
(or (and=> (internet-archive-uri first) list)
'()))
(() '())))))
(match uri (match uri
((uri tail ...) ((uri tail ...)
(or (fetch uri file) (or (fetch uri file)
@ -807,9 +834,10 @@ (define disarchive-uris
(() (()
;; If we are looking for a software archive, one last thing we ;; If we are looking for a software archive, one last thing we
;; can try is to use Disarchive to assemble it. ;; can try is to use Disarchive to assemble it.
(or (disarchive-fetch/any disarchive-uris file (or (and (download-method-enabled? 'disarchive)
(disarchive-fetch/any disarchive-uris file
#:verify-certificate? verify-certificate? #:verify-certificate? verify-certificate?
#:timeout timeout) #:timeout timeout))
(begin (begin
(format (current-error-port) "failed to download ~s from ~s~%" (format (current-error-port) "failed to download ~s from ~s~%"
file url) file url)

11
guix/build/git.scm
View file

@ -19,6 +19,8 @@
(define-module (guix build git) (define-module (guix build git)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module ((guix build download)
#:select (download-method-enabled?))
#:autoload (guix build download-nar) (download-nar) #:autoload (guix build download-nar) (download-nar)
#:autoload (guix swh) (%verify-swh-certificate? #:autoload (guix swh) (%verify-swh-certificate?
swh-download 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 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 hash of the directory of interested and are used as its content address at
SWH." SWH."
(or (git-fetch url commit directory (or (and (download-method-enabled? 'upstream)
(git-fetch url commit directory
#:lfs? lfs? #:lfs? lfs?
#:recursive? recursive? #:recursive? recursive?
#:git-command git-command) #:git-command git-command))
(download-nar item directory) (and (download-method-enabled? 'nar)
(download-nar item directory))
;; As a last resort, attempt to download from Software Heritage. ;; As a last resort, attempt to download from Software Heritage.
;; Disable X.509 certificate verification to avoid depending ;; Disable X.509 certificate verification to avoid depending
;; on nss-certs--we're authenticating the checkout anyway. ;; on nss-certs--we're authenticating the checkout anyway.
;; XXX: Currently recursive checkouts are not supported. ;; XXX: Currently recursive checkouts are not supported.
(and (not recursive?) (and (not recursive?)
(download-method-enabled? 'swh)
(parameterize ((%verify-swh-certificate? #f)) (parameterize ((%verify-swh-certificate? #f))
(format (current-error-port) (format (current-error-port)
"Trying to download from Software Heritage...~%") "Trying to download from Software Heritage...~%")

20
guix/bzr-download.scm
View file

@ -24,7 +24,7 @@ (define-module (guix bzr-download)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix store) #:use-module (guix store)
#:use-module (ice-9 match)
#:export (bzr-reference #:export (bzr-reference
bzr-reference? bzr-reference?
bzr-reference-url bzr-reference-url
@ -72,20 +72,26 @@ (define build
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((guix build bzr) '((guix build bzr)
(guix build utils) (guix build utils)
(guix build download)
(guix build download-nar))) (guix build download-nar)))
#~(begin #~(begin
(use-modules (guix build bzr) (use-modules (guix build bzr)
(guix build download-nar) (guix build download-nar)
((guix build download)
#:select (download-method-enabled?))
(guix build utils) (guix build utils)
(srfi srfi-34)) (srfi srfi-34))
(or (guard (c ((invoke-error? c) (or (and (download-method-enabled? 'upstream)
(guard (c ((invoke-error? c)
(report-invoke-error c) (report-invoke-error c)
#f)) #f))
(bzr-fetch (getenv "bzr url") (getenv "bzr reference") (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
#$output #$output
#:bzr-command (string-append #+bzr "/bin/brz"))) #:bzr-command
(download-nar #$output)))))) (string-append #+bzr "/bin/brz"))))
(and (download-method-enabled? 'nar)
(download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system))) (mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "bzr-branch") build (gexp->derivation (or name "bzr-branch") build
@ -95,7 +101,11 @@ (define build
#:script-name "bzr-download" #:script-name "bzr-download"
#:env-vars #:env-vars
`(("bzr url" . ,(bzr-reference-url ref)) `(("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" #:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG" "LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS") "COLUMNS")

18
guix/cvs-download.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; ;;;
@ -73,6 +73,7 @@ (define gnutls
(define modules (define modules
(delete '(guix config) (delete '(guix config)
(source-module-closure '((guix build cvs) (source-module-closure '((guix build cvs)
(guix build download)
(guix build download-nar))))) (guix build download-nar)))))
(define build (define build
(with-imported-modules modules (with-imported-modules modules
@ -80,20 +81,29 @@ (define build
guile-lzlib) guile-lzlib)
#~(begin #~(begin
(use-modules (guix build cvs) (use-modules (guix build cvs)
((guix build download)
#:select (download-method-enabled?))
(guix build download-nar)) (guix build download-nar))
(or (cvs-fetch '#$(cvs-reference-root-directory ref) (or (and (download-method-enabled? 'upstream)
(cvs-fetch '#$(cvs-reference-root-directory ref)
'#$(cvs-reference-module ref) '#$(cvs-reference-module ref)
'#$(cvs-reference-revision ref) '#$(cvs-reference-revision ref)
#$output #$output
#:cvs-command (string-append #+cvs "/bin/cvs")) #:cvs-command
(download-nar #$output)))))) #+(file-append cvs "/bin/cvs")))
(and (download-method-enabled? 'nar)
(download-nar #$output)))))))
(mlet %store-monad ((guile (package->derivation guile system))) (mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "cvs-checkout") build (gexp->derivation (or name "cvs-checkout") build
#:leaked-env-vars '("http_proxy" "https_proxy" #:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG" "LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS") "COLUMNS")
#:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS")
(#f '())
(value
`(("GUIX_DOWNLOAD_METHODS" . ,value))))
#:system system #:system system
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash

53
guix/download.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@ -35,9 +35,9 @@ (define-module (guix download)
#:use-module (web uri) #:use-module (web uri)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (%mirrors #:export (%download-methods
%mirrors
%disarchive-mirrors %disarchive-mirrors
%download-fallback-test
(url-fetch* . url-fetch) (url-fetch* . url-fetch)
url-fetch/executable url-fetch/executable
url-fetch/tarbomb url-fetch/tarbomb
@ -434,10 +434,19 @@ (define %no-disarchive-mirrors-file
(define built-in-builders* (define built-in-builders*
(store-lift 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 (define* (built-in-download file-name url
#:key system hash-algo hash #:key system hash-algo hash
mirrors content-addressed-mirrors mirrors content-addressed-mirrors
disarchive-mirrors disarchive-mirrors
(download-methods (%download-methods))
executable? executable?
(guile 'unused)) (guile 'unused))
"Download FILE-NAME from URL using the built-in 'download' builder. When "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) ("disarchive-mirrors" . ,disarchive-mirrors)
,@(if executable? ,@(if executable?
'(("executable" . "1")) '(("executable" . "1"))
'())
,@(if download-methods
`(("download-methods"
. ,(object->string
download-methods)))
'())) '()))
;; Do not offload this derivation because we cannot be ;; 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. ;; for that built-in is widespread.
#:local-build? #t))) #: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 (define* (url-fetch* url hash-algo hash
#:optional name #:optional name
#:key (system (%current-system)) #:key (system (%current-system))
@ -532,10 +528,7 @@ (define file-name
(unless (member "download" builtins) (unless (member "download" builtins)
(error "'guix-daemon' is too old, please upgrade" builtins)) (error "'guix-daemon' is too old, please upgrade" builtins))
(built-in-download (or name file-name) (built-in-download (or name file-name) url
(match (%download-fallback-test)
((or #f 'none) url)
(_ "https://example.org/does-not-exist"))
#:guile guile #:guile guile
#:system system #:system system
#:hash-algo hash-algo #:hash-algo hash-algo
@ -543,15 +536,9 @@ (define file-name
#:executable? executable? #:executable? executable?
#:mirrors %mirror-file #:mirrors %mirror-file
#:content-addressed-mirrors #:content-addressed-mirrors
(match (%download-fallback-test) %content-addressed-mirror-file
((or #f 'content-addressed-mirrors)
%content-addressed-mirror-file)
(_ %no-mirrors-file))
#:disarchive-mirrors #:disarchive-mirrors
(match (%download-fallback-test) %disarchive-mirror-file)))))
((or #f 'disarchive-mirrors)
%disarchive-mirror-file)
(_ %no-disarchive-mirrors-file)))))))
(define* (url-fetch/executable url hash-algo hash (define* (url-fetch/executable url hash-algo hash
#:optional name #:optional name

20
guix/git-download.scm
View file

@ -29,8 +29,8 @@ (define-module (guix git-download)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module ((guix derivations) #:select (raw-derivation)) #:use-module ((guix derivations) #:select (raw-derivation))
#:autoload (guix download) (%download-methods)
#:autoload (guix build-system gnu) (standard-packages) #:autoload (guix build-system gnu) (standard-packages)
#:autoload (guix download) (%download-fallback-test)
#:autoload (git bindings) (libgit2-init!) #:autoload (git bindings) (libgit2-init!)
#:autoload (git repository) (repository-open #:autoload (git repository) (repository-open
repository-close! repository-close!
@ -180,11 +180,7 @@ (define recursive?
;; downloads. ;; downloads.
#:script-name "git-download" #:script-name "git-download"
#:env-vars #:env-vars
`(("git url" . ,(match (%download-fallback-test) `(("git url" . ,(git-reference-url ref))
('content-addressed-mirrors
"https://example.org/does-not-exist")
(_
(git-reference-url ref))))
("git commit" . ,(git-reference-commit ref)) ("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string ("git recursive?" . ,(object->string
(git-reference-recursive? ref))) (git-reference-recursive? ref)))
@ -246,14 +242,14 @@ (define* (git-fetch/built-in ref hash-algo hash
#:recursive? #t #:recursive? #t
#:env-vars #:env-vars
`(("url" . ,(object->string `(("url" . ,(object->string
(match (%download-fallback-test) (git-reference-url ref)))
('content-addressed-mirrors
"https://example.org/does-not-exist")
(_
(git-reference-url ref)))))
("commit" . ,(git-reference-commit ref)) ("commit" . ,(git-reference-commit ref))
("recursive?" . ,(object->string ("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" #:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG" "LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS") "COLUMNS")

22
guix/hg-download.scm
View file

@ -84,6 +84,7 @@ (define gnutls
(define modules (define modules
(delete '(guix config) (delete '(guix config)
(source-module-closure '((guix build hg) (source-module-closure '((guix build hg)
(guix build download)
(guix build download-nar) (guix build download-nar)
(guix swh))))) (guix swh)))))
@ -94,6 +95,8 @@ (define build
#~(begin #~(begin
(use-modules (guix build hg) (use-modules (guix build hg)
(guix build utils) ;for `set-path-environment-variable' (guix build utils) ;for `set-path-environment-variable'
((guix build download)
#:select (download-method-enabled?))
(guix build download-nar) (guix build download-nar)
(guix swh) (guix swh)
(ice-9 match)) (ice-9 match))
@ -106,28 +109,35 @@ (define build
(setvbuf (current-output-port) 'line) (setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line) (setvbuf (current-error-port) 'line)
(or (hg-fetch '#$(hg-reference-url ref) (or (and (download-method-enabled? 'upstream)
(hg-fetch '#$(hg-reference-url ref)
'#$(hg-reference-changeset ref) '#$(hg-reference-changeset ref)
#$output #$output
#:hg-command (string-append #+hg "/bin/hg")) #:hg-command (string-append #+hg "/bin/hg")))
(download-nar #$output) (and (download-method-enabled? 'nar)
(download-nar #$output))
;; As a last resort, attempt to download from Software Heritage. ;; As a last resort, attempt to download from Software Heritage.
;; Disable X.509 certificate verification to avoid depending ;; Disable X.509 certificate verification to avoid depending
;; on nss-certs--we're authenticating the checkout anyway. ;; on nss-certs--we're authenticating the checkout anyway.
(and (download-method-enabled? 'swh)
(parameterize ((%verify-swh-certificate? #f)) (parameterize ((%verify-swh-certificate? #f))
(format (current-error-port) (format (current-error-port)
"Trying to download from Software Heritage...~%") "Trying to download from Software Heritage...~%")
(or (swh-download-directory-by-nar-hash #$hash '#$hash-algo (or (swh-download-directory-by-nar-hash
#$output) #$hash '#$hash-algo #$output)
(swh-download #$(hg-reference-url ref) (swh-download #$(hg-reference-url ref)
#$(hg-reference-changeset ref) #$(hg-reference-changeset ref)
#$output)))))))) #$output)))))))))
(mlet %store-monad ((guile (package->derivation guile system))) (mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build (gexp->derivation (or name "hg-checkout") build
#:leaked-env-vars '("http_proxy" "https_proxy" #:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG" "LC_ALL" "LC_MESSAGES" "LANG"
"COLUMNS") "COLUMNS")
#:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS")
(#f '())
(value
`(("GUIX_DOWNLOAD_METHODS" . ,value))))
#:system system #:system system
#:local-build? #t ;don't offload repo cloning #:local-build? #t ;don't offload repo cloning
#:hash-algo hash-algo #:hash-algo hash-algo

22
guix/scripts/perform-download.scm
View file

@ -21,7 +21,7 @@ (define-module (guix scripts perform-download)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module ((guix store) #:select (derivation-path? store-path?)) #: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 build git) (git-fetch-with-fallback)
#:autoload (guix config) (%git) #:autoload (guix config) (%git)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -55,7 +55,8 @@ (define* (perform-download drv output
(executable "executable") (executable "executable")
(mirrors "mirrors") (mirrors "mirrors")
(content-addressed-mirrors "content-addressed-mirrors") (content-addressed-mirrors "content-addressed-mirrors")
(disarchive-mirrors "disarchive-mirrors")) (disarchive-mirrors "disarchive-mirrors")
(download-methods "download-methods"))
(unless url (unless url
(leave (G_ "~a: missing URL~%") (derivation-file-name drv))) (leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
@ -64,7 +65,11 @@ (define* (perform-download drv output
(algo (derivation-output-hash-algo drv-output)) (algo (derivation-output-hash-algo drv-output))
(hash (derivation-output-hash drv-output))) (hash (derivation-output-hash drv-output)))
;; We're invoked by the daemon, which gives us write access to OUTPUT. ;; We're invoked by the daemon, which gives us write access to OUTPUT.
(when (url-fetch url output (when (parameterize ((%download-methods
(and download-methods
(call-with-input-string download-methods
read))))
(url-fetch url output
#:print-build-trace? print-build-trace? #:print-build-trace? print-build-trace?
#:mirrors (if mirrors #:mirrors (if mirrors
(call-with-input-file mirrors read) (call-with-input-file mirrors read)
@ -83,7 +88,7 @@ (define* (perform-download drv output
;; Since DRV's output hash is known, X.509 certificate ;; Since DRV's output hash is known, X.509 certificate
;; validation is pointless. ;; validation is pointless.
#:verify-certificate? #f) #:verify-certificate? #f))
(when (and executable (string=? executable "1")) (when (and executable (string=? executable "1"))
(chmod output #o755)))))) (chmod output #o755))))))
@ -96,7 +101,8 @@ (define* (perform-git-download drv output
'bmRepair' builds." 'bmRepair' builds."
(derivation-let drv ((url "url") (derivation-let drv ((url "url")
(commit "commit") (commit "commit")
(recursive? "recursive?")) (recursive? "recursive?")
(download-methods "download-methods"))
(unless url (unless url
(leave (G_ "~a: missing Git URL~%") (derivation-file-name drv))) (leave (G_ "~a: missing Git URL~%") (derivation-file-name drv)))
(unless commit (unless commit
@ -114,6 +120,10 @@ (define* (perform-git-download drv output
;; on ambient authority, hence the PATH value below. ;; on ambient authority, hence the PATH value below.
(setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin") (setenv "PATH" "/run/current-system/profile/bin:/bin:/usr/bin")
(parameterize ((%download-methods
(and download-methods
(call-with-input-string download-methods
read))))
;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
;; different, hence the #:item argument below. ;; different, hence the #:item argument below.
(git-fetch-with-fallback url commit output (git-fetch-with-fallback url commit output
@ -121,7 +131,7 @@ (define* (perform-git-download drv output
#:hash-algorithm algo #:hash-algorithm algo
#:recursive? recursive? #:recursive? recursive?
#:item (derivation-output-path drv-output) #:item (derivation-output-path drv-output)
#:git-command %git)))) #:git-command %git)))))
(define (assert-low-privileges) (define (assert-low-privileges)
(when (zero? (getuid)) (when (zero? (getuid))

46
guix/svn-download.scm
View file

@ -93,6 +93,7 @@ (define guile-gnutls
(define build (define build
(with-imported-modules (with-imported-modules
(source-module-closure '((guix build svn) (source-module-closure '((guix build svn)
(guix build download)
(guix build download-nar) (guix build download-nar)
(guix build utils) (guix build utils)
(guix swh))) (guix swh)))
@ -100,11 +101,14 @@ (define build
guile-lzlib) guile-lzlib)
#~(begin #~(begin
(use-modules (guix build svn) (use-modules (guix build svn)
((guix build download)
#:select (download-method-enabled?))
(guix build download-nar) (guix build download-nar)
(guix swh) (guix swh)
(ice-9 match)) (ice-9 match))
(or (svn-fetch (getenv "svn url") (or (and (download-method-enabled? 'upstream)
(svn-fetch (getenv "svn url")
(string->number (getenv "svn revision")) (string->number (getenv "svn revision"))
#$output #$output
#:svn-command #+(file-append svn "/bin/svn") #:svn-command #+(file-append svn "/bin/svn")
@ -112,11 +116,13 @@ (define build
("yes" #t) ("yes" #t)
(_ #f)) (_ #f))
#:user-name (getenv "svn user name") #:user-name (getenv "svn user name")
#:password (getenv "svn password")) #:password (getenv "svn password")))
(download-nar #$output) (and (download-method-enabled? 'nar)
(download-nar #$output))
(and (download-method-enabled? 'swh)
(parameterize ((%verify-swh-certificate? #f)) (parameterize ((%verify-swh-certificate? #f))
(swh-download-directory-by-nar-hash #$hash '#$hash-algo (swh-download-directory-by-nar-hash #$hash '#$hash-algo
#$output))))))) #$output))))))))
(mlet %store-monad ((guile (package->derivation guile system))) (mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build (gexp->derivation (or name "svn-checkout") build
@ -139,7 +145,11 @@ (define build
,@(if (svn-reference-password ref) ,@(if (svn-reference-password ref)
`(("svn password" `(("svn password"
. ,(svn-reference-password ref))) . ,(svn-reference-password ref)))
'())) '())
,@(match (getenv "GUIX_DOWNLOAD_METHODS")
(#f '())
(value
`(("GUIX_DOWNLOAD_METHODS" . ,value)))))
#:system system #:system system
#:hash-algo hash-algo #:hash-algo hash-algo
@ -178,6 +188,7 @@ (define guile-gnutls
(define build (define build
(with-imported-modules (with-imported-modules
(source-module-closure '((guix build svn) (source-module-closure '((guix build svn)
(guix build download)
(guix build download-nar) (guix build download-nar)
(guix build utils) (guix build utils)
(guix swh))) (guix swh)))
@ -186,6 +197,8 @@ (define build
#~(begin #~(begin
(use-modules (guix build svn) (use-modules (guix build svn)
(guix build utils) (guix build utils)
((guix build download)
#:select (download-method-enabled?))
(guix build download-nar) (guix build download-nar)
(guix swh) (guix swh)
(srfi srfi-1) (srfi srfi-1)
@ -197,6 +210,7 @@ (define build
;; single file. ;; single file.
(unless (string-suffix? "/" location) (unless (string-suffix? "/" location)
(mkdir-p (string-append #$output "/" (dirname location)))) (mkdir-p (string-append #$output "/" (dirname location))))
(and (download-method-enabled? 'upstream)
(svn-fetch (string-append (getenv "svn url") "/" location) (svn-fetch (string-append (getenv "svn url") "/" location)
(string->number (getenv "svn revision")) (string->number (getenv "svn revision"))
(if (string-suffix? "/" location) (if (string-suffix? "/" location)
@ -207,20 +221,22 @@ (define build
("yes" #t) ("yes" #t)
(_ #f)) (_ #f))
#:user-name (getenv "svn user name") #:user-name (getenv "svn user name")
#:password (getenv "svn password"))) #:password (getenv "svn password"))))
(call-with-input-string (getenv "svn locations") (call-with-input-string (getenv "svn locations")
read)) read))
(begin (begin
(when (file-exists? #$output) (when (file-exists? #$output)
(delete-file-recursively #$output)) (delete-file-recursively #$output))
(or (download-nar #$output) (or (and (download-method-enabled? 'nar)
(parameterize ((%verify-swh-certificate? #f)) (download-nar #$output))
;; SWH keeps HASH as an ExtID for the combination of (and (download-method-enabled? 'swh)
;; files/directories, which allows us to retrieve the ;; SWH keeps HASH as an ExtID for the combination
;; entire combination at once: ;; of files/directories, which allows us to
;; retrieve the entire combination at once:
;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>. ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>.
(parameterize ((%verify-swh-certificate? #f))
(swh-download-directory-by-nar-hash (swh-download-directory-by-nar-hash
#$hash '#$hash-algo #$output))))))))) #$hash '#$hash-algo #$output))))))))))
(mlet %store-monad ((guile (package->derivation guile system))) (mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build (gexp->derivation (or name "svn-checkout") build
@ -245,7 +261,11 @@ (define build
,@(if (svn-multi-reference-password ref) ,@(if (svn-multi-reference-password ref)
`(("svn password" `(("svn password"
. ,(svn-multi-reference-password ref))) . ,(svn-multi-reference-password ref)))
'())) '())
,@(match (getenv "GUIX_DOWNLOAD_METHODS")
(#f '())
(value
`(("GUIX_DOWNLOAD_METHODS" . ,value)))))
#:leaked-env-vars '("http_proxy" "https_proxy" #:leaked-env-vars '("http_proxy" "https_proxy"
"LC_ALL" "LC_MESSAGES" "LANG" "LC_ALL" "LC_MESSAGES" "LANG"