futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

50
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 @@
#: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 @@ true, verify HTTPS certificates; otherwise simply ignore them."
(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 @@ otherwise simply ignore them."
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 @@ otherwise simply ignore them."
(() (()
;; 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)
#:verify-certificate? verify-certificate? (disarchive-fetch/any disarchive-uris file
#:timeout timeout) #:verify-certificate? verify-certificate?
#: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)

15
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 @@ 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 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)
#:lfs? lfs? (git-fetch url commit directory
#:recursive? recursive? #:lfs? lfs?
#:git-command git-command) #:recursive? recursive?
(download-nar item directory) #:git-command git-command))
(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...~%")

28
guix/bzr-download.scm
View File

@ -24,7 +24,7 @@
#: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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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)
(report-invoke-error c) (guard (c ((invoke-error? c)
#f)) (report-invoke-error c)
(bzr-fetch (getenv "bzr url") (getenv "bzr reference") #f))
#$output (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
#:bzr-command (string-append #+bzr "/bin/brz"))) #$output
(download-nar #$output)))))) #:bzr-command
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#: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")

24
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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
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-reference-module ref) (cvs-fetch '#$(cvs-reference-root-directory ref)
'#$(cvs-reference-revision ref) '#$(cvs-reference-module ref)
#$output '#$(cvs-reference-revision ref)
#:cvs-command (string-append #+cvs "/bin/cvs")) #$output
(download-nar #$output)))))) #:cvs-command
#+(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 @@
#: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 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 @@ download by itself using its own dependencies."
("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 @@ download by itself using its own dependencies."
;; 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 @@ name in the store."
(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 @@ name in the store."
#: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 @@
#: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 @@ respective documentation."
;; 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 @@ download by itself using its own dependencies."
#: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")

36
guix/hg-download.scm
View File

@ -84,6 +84,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#~(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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-reference-changeset ref) (hg-fetch '#$(hg-reference-url ref)
#$output '#$(hg-reference-changeset ref)
#:hg-command (string-append #+hg "/bin/hg")) #$output
(download-nar #$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. ;; 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.
(parameterize ((%verify-swh-certificate? #f)) (and (download-method-enabled? 'swh)
(format (current-error-port) (parameterize ((%verify-swh-certificate? #f))
"Trying to download from Software Heritage...~%") (format (current-error-port)
(or (swh-download-directory-by-nar-hash #$hash '#$hash-algo "Trying to download from Software Heritage...~%")
#$output) (or (swh-download-directory-by-nar-hash
(swh-download #$(hg-reference-url ref) #$hash '#$hash-algo #$output)
#$(hg-reference-changeset ref) (swh-download #$(hg-reference-url ref)
#$output)))))))) #$(hg-reference-changeset ref)
#$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

70
guix/scripts/perform-download.scm
View File

@ -21,7 +21,7 @@
#: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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
(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,26 +65,30 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
(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
#:print-build-trace? print-build-trace? (and download-methods
#:mirrors (if mirrors (call-with-input-string download-methods
(call-with-input-file mirrors read) read))))
'()) (url-fetch url output
#:content-addressed-mirrors #:print-build-trace? print-build-trace?
(if content-addressed-mirrors #:mirrors (if mirrors
(call-with-input-file content-addressed-mirrors (call-with-input-file mirrors read)
(lambda (port) '())
(eval (read port) %user-module))) #:content-addressed-mirrors
'()) (if content-addressed-mirrors
#:disarchive-mirrors (call-with-input-file content-addressed-mirrors
(if disarchive-mirrors (lambda (port)
(call-with-input-file disarchive-mirrors read) (eval (read port) %user-module)))
'()) '())
#:hashes `((,algo . ,hash)) #: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 ;; 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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
'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,14 +120,18 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
;; 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")
;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are (parameterize ((%download-methods
;; different, hence the #:item argument below. (and download-methods
(git-fetch-with-fallback url commit output (call-with-input-string download-methods
#:hash hash read))))
#:hash-algorithm algo ;; Note: When doing a '--check' build, DRV-OUTPUT and OUTPUT are
#:recursive? recursive? ;; different, hence the #:item argument below.
#:item (derivation-output-path drv-output) (git-fetch-with-fallback url commit output
#:git-command %git)))) #:hash hash
#:hash-algorithm algo
#:recursive? recursive?
#:item (derivation-output-path drv-output)
#:git-command %git)))))
(define (assert-low-privileges) (define (assert-low-privileges)
(when (zero? (getuid)) (when (zero? (getuid))

88
guix/svn-download.scm
View File

@ -93,6 +93,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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,23 +101,28 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
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)
(string->number (getenv "svn revision")) (svn-fetch (getenv "svn url")
#$output (string->number (getenv "svn revision"))
#:svn-command #+(file-append svn "/bin/svn") #$output
#:recursive? (match (getenv "svn recursive?") #:svn-command #+(file-append svn "/bin/svn")
("yes" #t) #:recursive? (match (getenv "svn recursive?")
(_ #f)) ("yes" #t)
#:user-name (getenv "svn user name") (_ #f))
#:password (getenv "svn password")) #:user-name (getenv "svn user name")
(download-nar #$output) #:password (getenv "svn password")))
(parameterize ((%verify-swh-certificate? #f)) (and (download-method-enabled? 'nar)
(swh-download-directory-by-nar-hash #$hash '#$hash-algo (download-nar #$output))
#$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))) (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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
,@(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#~(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,30 +210,33 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
;; 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))))
(svn-fetch (string-append (getenv "svn url") "/" location) (and (download-method-enabled? 'upstream)
(string->number (getenv "svn revision")) (svn-fetch (string-append (getenv "svn url") "/" location)
(if (string-suffix? "/" location) (string->number (getenv "svn revision"))
(string-append #$output "/" location) (if (string-suffix? "/" location)
(string-append #$output "/" (dirname location))) (string-append #$output "/" location)
#:svn-command #+(file-append svn "/bin/svn") (string-append #$output "/" (dirname location)))
#:recursive? (match (getenv "svn recursive?") #:svn-command #+(file-append svn "/bin/svn")
("yes" #t) #:recursive? (match (getenv "svn recursive?")
(_ #f)) ("yes" #t)
#:user-name (getenv "svn user name") (_ #f))
#:password (getenv "svn password"))) #:user-name (getenv "svn user name")
#: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
;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>. ;; retrieve the entire combination at once:
(swh-download-directory-by-nar-hash ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>.
#$hash '#$hash-algo #$output))))))))) (parameterize ((%verify-swh-certificate? #f))
(swh-download-directory-by-nar-hash
#$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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
,@(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"