From b53be755e465be04dc05e9069178874cb9f1f44d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 1 Jun 2014 23:32:26 +0200
Subject: [PATCH] derivations: Add #:allowed-references 'derivation' parameter.

* guix/derivations.scm (derivation): Add #:allowed-references
  parameter.
  [user+system-env-vars]: Honor it.
* tests/derivations.scm ("derivation #:allowed-references, ok",
  "derivation #:allowed-references, not allowed",
  "derivation #:allowed-references, self allowed",
  "derivation #:allowed-references, self not allowed"): New tests.
* doc/guix.texi (Derivations): Document #:allowed-references.
---
 doc/guix.texi         |  5 ++++-
 guix/derivations.scm  | 17 ++++++++++++-----
 tests/derivations.scm | 37 +++++++++++++++++++++++++++++++++++++
 3 files changed, 53 insertions(+), 6 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index eeadb04d78..cfdfcd8b78 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1737,7 +1737,7 @@ a derivation is the @code{derivation} procedure:
   @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @
   [#:recursive? #f] [#:inputs '()] [#:env-vars '()] @
   [#:system (%current-system)] [#:references-graphs #f] @
-  [#:local-build? #f]
+  [#:allowed-references #f] [#:local-build? #f]
 Build a derivation with the given arguments, and return the resulting
 @code{<derivation>} object.
 
@@ -1753,6 +1753,9 @@ name/store path pairs.  In that case, the reference graph of each store
 path is exported in the build environment in the corresponding file, in
 a simple text format.
 
+When @var{allowed-references} is true, it must be a list of store items
+or outputs that the derivation's output may refer to.
+
 When @var{local-build?} is true, declare that the derivation is not a
 good candidate for offloading and should rather be built locally
 (@pxref{Daemon Offload Setup}).  This is the case for small derivations
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 09b7ec079e..8d0c9c08df 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -565,7 +565,7 @@ HASH-ALGO, of the derivation NAME.  RECURSIVE? has the same meaning as for
                      (system (%current-system)) (env-vars '())
                      (inputs '()) (outputs '("out"))
                      hash hash-algo recursive?
-                     references-graphs
+                     references-graphs allowed-references
                      local-build?)
   "Build a derivation with the given arguments, and return the resulting
 <derivation> object.  When HASH and HASH-ALGO are given, a
@@ -578,6 +578,9 @@ When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs.  In that case, the reference graph of each store path is exported in
 the build environment in the corresponding file, in a simple text format.
 
+When ALLOWED-REFERENCES is true, it must be a list of store items or outputs
+that the derivation's output may refer to.
+
 When LOCAL-BUILD? is true, declare that the derivation is not a good candidate
 for offloading and should rather be built locally.  This is the case for small
 derivations where the costs of data transfers would outweigh the benefits."
@@ -615,10 +618,14 @@ derivations where the costs of data transfers would outweigh the benefits."
     ;; Some options are passed to the build daemon via the env. vars of
     ;; derivations (urgh!).  We hide that from our API, but here is the place
     ;; where we kludgify those options.
-    (let ((env-vars (if local-build?
-                        `(("preferLocalBuild" . "1")
-                          ,@env-vars)
-                        env-vars)))
+    (let ((env-vars `(,@(if local-build?
+                            `(("preferLocalBuild" . "1"))
+                            '())
+                      ,@(if allowed-references
+                            `(("allowedReferences"
+                               . ,(string-join allowed-references)))
+                            '())
+                      ,@env-vars)))
       (match references-graphs
         (((file . path) ...)
          (let ((value (map (cut string-append <> " " <>)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 0b785029a7..87609108d6 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -390,6 +390,43 @@
                                                ((p2 . _)
                                                 (string<? p1 p2)))))))))))))))
 
+(test-assert "derivation #:allowed-references, ok"
+  (let ((drv (derivation %store "allowed" %bash
+                         '("-c" "echo hello > $out")
+                         #:inputs `((,%bash))
+                         #:allowed-references '())))
+    (build-derivations %store (list drv))))
+
+(test-assert "derivation #:allowed-references, not allowed"
+  (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
+         (drv (derivation %store "disallowed" %bash
+                          `("-c" ,(string-append "echo " txt "> $out"))
+                          #:inputs `((,%bash) (,txt))
+                          #:allowed-references '())))
+    (guard (c ((nix-protocol-error? c)
+               ;; There's no specific error message to check for.
+               #t))
+      (build-derivations %store (list drv))
+      #f)))
+
+(test-assert "derivation #:allowed-references, self allowed"
+  (let ((drv (derivation %store "allowed" %bash
+                         '("-c" "echo $out > $out")
+                         #:inputs `((,%bash))
+                         #:allowed-references '("out"))))
+    (build-derivations %store (list drv))))
+
+(test-assert "derivation #:allowed-references, self not allowed"
+  (let ((drv (derivation %store "disallowed" %bash
+                         `("-c" ,"echo $out > $out")
+                         #:inputs `((,%bash))
+                         #:allowed-references '())))
+    (guard (c ((nix-protocol-error? c)
+               ;; There's no specific error message to check for.
+               #t))
+      (build-derivations %store (list drv))
+      #f)))
+
 
 (define %coreutils
   (false-if-exception