me
/
guix
Archived
1
0
Fork 0
Code

download: Add parameter to test download fallback mechanisms. 

This allows you to run, say:

  GUIX_DOWNLOAD_FALLBACK_TEST=disarchive-mirrors guix build -S r-ebimage --check

or:

  GUIX_DOWNLOAD_FALLBACK_TEST=content-addressed-mirrors ./pre-inst-env guix build -S r-ebimage --check

to check whether these fallback mechanisms work as expected.

* guix/download.scm (%no-mirrors-file, %no-disarchive-mirrors-file)
(%download-fallback-test): New variables.
(url-fetch*): Honor (%download-fallback-test).
master
Ludovic Courtès 2021-10-14 15:41:43 +02:00
parent 689d529e74
commit c4a7aa82e2
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 37 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
guix/download.scm
View File

@ -36,6 +36,7 @@
#:use-module (srfi srfi-26)
#:export (%mirrors
%disarchive-mirrors
%download-fallback-test
(url-fetch* . url-fetch)
url-fetch/executable
url-fetch/tarbomb
@ -399,6 +400,10 @@
(plain-file "content-addressed-mirrors"
(object->string %content-addressed-mirrors)))
(define %no-mirrors-file
;; File specifying an empty list of mirrors, for fallback tests.
(plain-file "no-content-addressed-mirrors" (object->string ''())))
(define %disarchive-mirrors
;; TODO: Eventually turn into a procedure that takes a hash algorithm
;; (symbol) and hash (bytevector).
@ -408,6 +413,10 @@
(define %disarchive-mirror-file
(plain-file "disarchive-mirrors" (object->string %disarchive-mirrors)))
(define %no-disarchive-mirrors-file
;; File specifying an empty list of Disarchive mirrors, for fallback tests.
(plain-file "no-disarchive-mirrors" (object->string '())))
(define built-in-builders*
(store-lift built-in-builders))
@ -456,6 +465,22 @@ 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;
;;
;; - '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))
@ -491,7 +516,10 @@ name in the store."
(unless (member "download" builtins)
(error "'guix-daemon' is too old, please upgrade" builtins))
(built-in-download (or name file-name) url
(built-in-download (or name file-name)
(if (%download-fallback-test)
"https://example.org/does-not-exist"
url)
#:guile guile
#:system system
#:hash-algo hash-algo
@ -499,9 +527,15 @@ name in the store."
#:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
%content-addressed-mirror-file
(match (%download-fallback-test)
((or #f 'content-addressed-mirrors)
%content-addressed-mirror-file)
(_ %no-mirrors-file))
#:disarchive-mirrors
%disarchive-mirror-file)))))
(match (%download-fallback-test)
((or #f 'disarchive-mirrors)
%disarchive-mirror-file)
(_ %no-disarchive-mirrors-file)))))))
(define* (url-fetch/executable url hash-algo hash
#:optional name