amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

download: Add parameter to test download fallback mechanisms.

Browse source 
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).
This commit is contained in:
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
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) #:use-module (srfi srfi-26)
#:export (%mirrors #:export (%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
@ -399,6 +400,10 @@
(plain-file "content-addressed-mirrors" (plain-file "content-addressed-mirrors"
(object->string %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 (define %disarchive-mirrors
;; TODO: Eventually turn into a procedure that takes a hash algorithm ;; TODO: Eventually turn into a procedure that takes a hash algorithm
;; (symbol) and hash (bytevector). ;; (symbol) and hash (bytevector).
@ -408,6 +413,10 @@
(define %disarchive-mirror-file (define %disarchive-mirror-file
(plain-file "disarchive-mirrors" (object->string %disarchive-mirrors))) (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* (define built-in-builders*
(store-lift 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. ;; 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;
;;
;; - '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))
@ -491,7 +516,10 @@ 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) url (built-in-download (or name file-name)
(if (%download-fallback-test)
"https://example.org/does-not-exist"
url)
#:guile guile #:guile guile
#:system system #:system system
#:hash-algo hash-algo #:hash-algo hash-algo
@ -499,9 +527,15 @@ name in the store."
#:executable? executable? #:executable? executable?
#:mirrors %mirror-file #:mirrors %mirror-file
#:content-addressed-mirrors #: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-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 (define* (url-fetch/executable url hash-algo hash
#:optional name #:optional name