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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 24f5aaaf24e009de7f7402f2d311a26cafbf4f4a
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jul 13 15:46:12 2015 +0200

    substitute: Honor "substitute-urls" option passed by "untrusted" clients.
    
    * 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'.
---
 guix/scripts/substitute.scm |   13 +++++++----
 guix/tests.scm              |   11 +++++++++-
 tests/derivations.scm       |    9 +++++--
 tests/guix-daemon.sh        |   12 ++++++----
 tests/store.scm             |   45 ++++++++++++++++++++++++++++++++++++++----
 5 files changed, 71 insertions(+), 19 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index df5234d..5cdda34 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -746,12 +746,15 @@ substitutes may be unavailable\n")))))
 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)
diff --git a/guix/tests.scm b/guix/tests.scm
index 16b8cc7..cd8eda2 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -36,6 +36,7 @@
             network-reachable?
             shebang-too-long?
             mock
+            %test-substitute-urls
             %substitute-directory
             with-derivation-narinfo
             with-derivation-substitute
@@ -49,6 +50,12 @@
 ;;;
 ;;; 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 @@
              #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.
diff --git a/tests/derivations.scm b/tests/derivations.scm
index f66ef5c..d2a090c 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -612,7 +612,8 @@
          (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 @@
          (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 @@
            (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)
diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh
index 87f17de..0de6f27 100644
--- a/tests/guix-daemon.sh
+++ b/tests/guix-daemon.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2014 Ludovic Courtès <address@hidden>
+# Copyright © 2012, 2014, 2015 Ludovic Courtès <address@hidden>
 #
 # 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\")))"
diff --git a/tests/store.scm b/tests/store.scm
index f2d6d51..96b6478 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -377,7 +377,8 @@
 
         ;; 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 @@
                      (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 @@
                  (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 @@
                  (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 @@
         ;; 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 @@
       ;; 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