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

substitute: Honor "substitute-urls" option passed by "untrusted" clients.

Browse source 
* guix/scripts/substitute.scm (or*): New macro.
  (%cache-url): Honor "untrusted-substitute-urls".
* guix/tests.scm (%test-substitute-urls): New variable.
  (open-connection-for-tests): Use it.
* tests/derivations.scm ("derivation-prerequisites-to-build and substitutes",
  "derivation-prerequisites-to-build and substitutes, non-substitutable
  build", "derivation-prerequisites-to-build and substitutes, local build"):
  Pass it to 'set-build-options'.
* tests/guix-daemon.sh: Likewise.
* tests/store.scm ("substitute query, alternating URLs"): New test.
  ("substitute query", "substitute", "substitute + build-things with output
  path", "substitute, corrupt output hash", "substitute --fallback"): Pass
  #:substitute-urls to 'set-build-options'.
This commit is contained in:
Ludovic Courtès 2015-07-13 15:46:12 +02:00
parent 895d1eda54
commit 24f5aaaf24
5 changed files with 71 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
guix/scripts/substitute.scm
View file

@ -746,12 +746,15 @@ (define (find-daemon-option option)
found."
(assoc-ref (daemon-options) option))
(define-syntax-rule (or* a b)
(let ((first a))
(if (or (not first) (string-null? first))
b
first)))
(define %cache-url
(match (and=> ;; TODO: Uncomment the following lines when multiple
;; substitute sources are supported.
;; (find-daemon-option "untrusted-substitute-urls") ;client
;; " "
(find-daemon-option "substitute-urls") ;admin
(match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client
(find-daemon-option "substitute-urls")) ;admin
string-tokenize)
((url)
url)

11
guix/tests.scm
View file

@ -36,6 +36,7 @@ (define-module (guix tests)
network-reachable?
shebang-too-long?
mock
%test-substitute-urls
%substitute-directory
with-derivation-narinfo
with-derivation-substitute
@ -49,6 +50,12 @@ (define-module (guix tests)
;;;
;;; Code:
(define %test-substitute-urls
;; URLs where to look for substitutes during tests.
(make-parameter
(or (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") list)
'())))
(define (open-connection-for-tests)
"Open a connection to the build daemon for tests purposes and return it."
(guard (c ((nix-error? c)
@ -57,7 +64,9 @@ (define (open-connection-for-tests)
#f))
(let ((store (open-connection)))
;; Make sure we build everything by ourselves.
(set-build-options store #:use-substitutes? #f)
(set-build-options store
#:use-substitutes? #f
#:substitute-urls (%test-substitute-urls))
;; Use the bootstrap Guile when running tests, so we don't end up
;; building everything in the temporary test store.

9
tests/derivations.scm
View file

@ -612,7 +612,8 @@ (define %coreutils
(output (derivation->output-path drv)))
;; Make sure substitutes are usable.
(set-build-options store #:use-substitutes? #t)
(set-build-options store #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(with-derivation-narinfo drv
(let-values (((build download)
@ -634,7 +635,8 @@ (define %coreutils
(output (derivation->output-path drv)))
;; Make sure substitutes are usable.
(set-build-options store #:use-substitutes? #t)
(set-build-options store #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(with-derivation-narinfo drv
(let-values (((build download)
@ -655,7 +657,8 @@ (define %coreutils
(output (derivation->output-path drv)))
;; Make sure substitutes are usable.
(set-build-options store #:use-substitutes? #t)
(set-build-options store #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(with-derivation-narinfo drv
(let-values (((build download)

12
tests/guix-daemon.sh
View file

@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2014 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2012, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@ -54,11 +54,12 @@ EOF
rm -f "$XDG_CACHE_HOME/guix/substitute/$hash_part"
# Make sure we see the substitute.
guile -c '
guile -c "
(use-modules (guix))
(define store (open-connection))
(set-build-options store #:use-substitutes? #t)
(exit (has-substitutes? store "'"$out"'"))'
(set-build-options store #:use-substitutes? #t
#:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\"))
(exit (has-substitutes? store \"$out\"))"
# Now, run guix-daemon --no-substitutes.
socket="$NIX_STATE_DIR/alternate-socket"
@ -72,6 +73,7 @@ guile -c "
(define store (open-connection \"$socket\"))
;; This setting MUST NOT override the daemon's --no-substitutes.
(set-build-options store #:use-substitutes? #t)
(set-build-options store #:use-substitutes? #t
#:substitute-urls (list \"$GUIX_BINARY_SUBSTITUTE_URL\"))
(exit (not (has-substitutes? store \"$out\")))"

45
tests/store.scm
View file

@ -377,7 +377,8 @@ (define (same? x y)
;; Make sure 'guix substitute' correctly communicates the above
;; data.
(set-build-options s #:use-substitutes? #t)
(set-build-options s #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(and (has-substitutes? s o)
(equal? (list o) (substitutable-paths s (list o)))
(match (pk 'spi (substitutable-path-info s (list o)))
@ -387,6 +388,34 @@ (define (same? x y)
(null? (substitutable-references s))
(equal? (substitutable-nar-size s) 1234)))))))))
(test-assert "substitute query, alternating URLs"
(let* ((d (with-store s
(package-derivation s %bootstrap-guile (%current-system))))
(o (derivation->output-path d)))
(with-derivation-narinfo d
;; Remove entry from the local cache.
(false-if-exception
(delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
"/guix/substitute")))
;; Note: We reconnect to the daemon to force a new instance of 'guix
;; substitute' to be used; otherwise the #:substitute-urls of
;; 'set-build-options' would have no effect.
(and (with-store s ;the right substitute URL
(set-build-options s #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(has-substitutes? s o))
(with-store s ;the wrong one
(set-build-options s #:use-substitutes? #t
#:substitute-urls (list
"http://does-not-exist"))
(not (has-substitutes? s o)))
(with-store s ;the right one again
(set-build-options s #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(has-substitutes? s o))))))
(test-assert "substitute"
(with-store s
(let* ((c (random-text)) ; contents of the output
@ -400,7 +429,8 @@ (define (same? x y)
(package-derivation s %bootstrap-guile (%current-system))))
(o (derivation->output-path d)))
(with-derivation-substitute d c
(set-build-options s #:use-substitutes? #t)
(set-build-options s #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(and (has-substitutes? s o)
(build-derivations s (list d))
(equal? c (call-with-input-file o get-string-all)))))))
@ -418,7 +448,8 @@ (define (same? x y)
(package-derivation s %bootstrap-guile (%current-system))))
(o (derivation->output-path d)))
(with-derivation-substitute d c
(set-build-options s #:use-substitutes? #t)
(set-build-options s #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(and (has-substitutes? s o)
(build-things s (list o)) ;give the output path
(valid-path? s o)
@ -442,7 +473,8 @@ (define (same? x y)
;; Make sure we use 'guix substitute'.
(set-build-options s
#:use-substitutes? #t
#:fallback? #f)
#:fallback? #f
#:substitute-urls (%test-substitute-urls))
(and (has-substitutes? s o)
(guard (c ((nix-protocol-error? c)
;; XXX: the daemon writes "hash mismatch in downloaded
@ -467,13 +499,16 @@ (define (same? x y)
;; Create fake substituter data, to be read by 'guix substitute'.
(with-derivation-narinfo d
;; Make sure we use 'guix substitute'.
(set-build-options s #:use-substitutes? #t)
(set-build-options s #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(and (has-substitutes? s o)
(guard (c ((nix-protocol-error? c)
;; The substituter failed as expected. Now make
;; sure that #:fallback? #t works correctly.
(set-build-options s
#:use-substitutes? #t
#:substitute-urls
(%test-substitute-urls)
#:fallback? #t)
(and (build-derivations s (list d))
(equal? t (call-with-input-file o