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
;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012-2022, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
@ -40,7 +40,10 @@
#:autoload (guix swh) (swh-download-directory %verify-swh-certificate?)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (open-socket-for-uri
#:export (%download-methods
download-method-enabled?
open-socket-for-uri
open-connection-for-uri
http-fetch
%x509-certificate-directory
@ -622,6 +625,20 @@ true, verify HTTPS certificates; otherwise simply ignore them."
(lambda (key . args)
(print-exception (current-error-port) #f key args))))
(define %download-methods
;; Either #f (the default) or a list of symbols denoting the sequence of
;; download methods to be used--e.g., '(swh nar upstream).
(make-parameter
(and=> (getenv "GUIX_DOWNLOAD_METHODS")
(lambda (str)
(map string->symbol (string-tokenize str))))))
(define (download-method-enabled? method)
"Return true if METHOD (a symbol such as 'swh) is enabled as part of the
download fallback sequence."
(or (not (%download-methods))
(memq method (%download-methods))))
(define (uri-vicinity dir file)
"Concatenate DIR, slash, and FILE, keeping only one slash in between.
This is required by some HTTP servers."
@ -788,18 +805,28 @@ otherwise simply ignore them."
hashes)))
disarchive-mirrors))
(define initial-uris
(append (if (download-method-enabled? 'upstream)
uri
'())
(if (download-method-enabled? 'content-addressed-mirrors)
content-addressed-uris
'())
(if (download-method-enabled? 'internet-archive)
(match uri
((first . _)
(or (and=> (internet-archive-uri first) list)
'()))
(() '()))
'())))
;; Make this unbuffered so 'progress-report/file' works as expected. 'line
;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) 'none)
(setvbuf (current-error-port) 'line)
(let try ((uri (append uri content-addressed-uris
(match uri
((first . _)
(or (and=> (internet-archive-uri first) list)
'()))
(() '())))))
(let try ((uri initial-uris))
(match uri
((uri tail ...)
(or (fetch uri file)
@ -807,9 +834,10 @@ otherwise simply ignore them."
(()
;; If we are looking for a software archive, one last thing we
;; can try is to use Disarchive to assemble it.
(or (disarchive-fetch/any disarchive-uris file
#:verify-certificate? verify-certificate?
#:timeout timeout)
(or (and (download-method-enabled? 'disarchive)
(disarchive-fetch/any disarchive-uris file
#:verify-certificate? verify-certificate?
#:timeout timeout))
(begin
(format (current-error-port) "failed to download ~s from ~s~%"
file url)

15
guix/build/git.scm
View File

@ -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 @@ for ITEM, and if that also fails, download from the Software Heritage archive.
When HASH and HASH-ALGORITHM are provided, they are interpreted as the nar
hash of the directory of interested and are used as its content address at
SWH."
(or (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...~%")

28
guix/bzr-download.scm
View File

@ -24,7 +24,7 @@
#: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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#: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")

24
guix/cvs-download.scm
View File

@ -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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
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

53
guix/download.scm
View File

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

20
guix/git-download.scm
View File

@ -29,8 +29,8 @@
#: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 @@ respective documentation."
;; 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 @@ download by itself using its own dependencies."
#: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")

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
(delete '(guix config)
(source-module-closure '((guix build hg)
(guix build download)
(guix build download-nar)
(guix swh)))))
@ -94,6 +95,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#~(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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

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

@ -21,7 +21,7 @@
#: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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
(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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
(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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
'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 @@ Note: OUTPUT may differ from the 'out' value of DRV, notably for 'bmCheck' or
;; 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))

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
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
,@(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#~(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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
;; 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 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
,@(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"