gexp: Add #:allowed-references parameter to 'gexp->derivation'.

* guix/gexp.scm (lower-references): New procedure.
  (gexp->derivation): Add #:allowed-references and honor it.
* tests/gexp.scm ("gexp->derivation #:allowed-references",
  "gexp->derivation #:allowed-references, disallowed"): New tests.
* doc/guix.texi (G-Expressions): Update 'gexp->derivation' doc.

3 files changed, 64 insertions, 4 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index f292182231..0c6b1e4384 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2583,8 +2583,8 @@ information about monads.)
        [#:hash #f] [#:hash-algo #f] @
        [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
        [#:module-path @var{%load-path}] @
-       [#:references-graphs #f] [#:local-build? #f] @
-       [#:guile-for-build #f]
+       [#:references-graphs #f] [#:allowed-references #f] @
+       [#:local-build? #f] [#:guile-for-build #f]
 Return a derivation @var{name} that runs @var{exp} (a gexp) with
 @var{guile-for-build} (a derivation) on @var{system}.  When @var{target}
 is true, it is used as the cross-compilation target triplet for packages
@@ -2612,6 +2612,10 @@ an input of the build process of @var{exp}.  In the build environment, each
 @var{file-name} contains the reference graph of the corresponding item, in a simple
 text format.
 
+@var{allowed-references} must be either @code{#f} or a list of output names and packages.
+In the latter case, the list denotes store items that the result is allowed to
+refer to.  Any reference to another store item will lead to a build error.
+
 The other arguments are as for @code{derivation} (@pxref{Derivations}).
 @end deffn
 
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 4e8f91df1d..fa712a8b9b 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -118,6 +118,29 @@ corresponding derivation."
                                                #:target target)))
        (return (map cons file-names inputs))))))
 
+(define* (lower-references lst #:key system target)
+  "Based on LST, a list of output names and packages, return a list of output
+names and file names suitable for the #:allowed-references argument to
+'derivation'."
+  ;; XXX: Currently outputs other than "out" are not supported, and things
+  ;; other than packages aren't either.
+  (with-monad %store-monad
+    (define lower
+      (match-lambda
+       ((? string? output)
+        (return output))
+       ((? package? package)
+        (mlet %store-monad ((drv
+                             (if target
+                                 (package->cross-derivation package target
+                                                            #:system system
+                                                            #:graft? #f)
+                                 (package->derivation package system
+                                                      #:graft? #f))))
+          (return (derivation->output-path drv))))))
+
+    (sequence %store-monad (map lower lst))))
+
 (define* (gexp->derivation name exp
                            #:key
                            system (target 'current)
@@ -127,6 +150,7 @@ corresponding derivation."
                            (module-path %load-path)
                            (guile-for-build (%guile-for-build))
                            references-graphs
+                           allowed-references
                            local-build?)
   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 derivation) on SYSTEM.  When TARGET is true, it is used as the
@@ -151,8 +175,9 @@ an input of the build process of EXP.  In the build environment, each
 FILE-NAME contains the reference graph of the corresponding item, in a simple
 text format.
 
-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.
+ALLOWED-REFERENCES must be either #f or a list of output names and packages.
+In the latter case, the list denotes store items that the result is allowed to
+refer to.  Any reference to another store item will lead to a build error.
 
 The other arguments are as for 'derivation'."
   (define %modules modules)
@@ -207,6 +232,11 @@ The other arguments are as for 'derivation'."
                                                              #:system system
                                                              #:target target)
                                      (return #f)))
+                       (allowed  (if allowed-references
+                                     (lower-references allowed-references
+                                                       #:system system
+                                                       #:target target)
+                                     (return #f)))
                        (guile    (if guile-for-build
                                      (return guile-for-build)
                                      (package->derivation (default-guile)
@@ -233,6 +263,7 @@ The other arguments are as for 'derivation'."
                                    (_ '())))
                     #:hash hash #:hash-algo hash-algo #:recursive? recursive?
                     #:references-graphs (and=> graphs graphs-file-names)
+                    #:allowed-references allowed
                     #:local-build? local-build?)))
 
 (define* (gexp-inputs exp #:optional (references gexp-references))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index d80f14344d..03722e4669 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -27,6 +27,7 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)
@@ -396,6 +397,30 @@
                  (equal? (call-with-input-file g-guile read)
                          (list (derivation->output-path guile-drv)))))))
 
+(test-assertm "gexp->derivation #:allowed-references"
+  (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
+                                             #~(begin
+                                                 (mkdir #$output)
+                                                 (chdir #$output)
+                                                 (symlink #$output "self")
+                                                 (symlink #$%bootstrap-guile
+                                                          "guile"))
+                                             #:allowed-references
+                                             (list "out" %bootstrap-guile))))
+    (built-derivations (list drv))))
+
+(test-assert "gexp->derivation #:allowed-references, disallowed"
+  (let ((drv (run-with-store %store
+               (gexp->derivation "allowed-refs"
+                                 #~(begin
+                                     (mkdir #$output)
+                                     (chdir #$output)
+                                     (symlink #$%bootstrap-guile "guile"))
+                                 #:allowed-references '()))))
+    (guard (c ((nix-protocol-error? c) #t))
+      (build-derivations %store (list drv))
+      #f)))
+
 (define shebang
   (string-append "#!" (derivation->output-path (%guile-for-build))
                  "/bin/guile --no-auto-compile"))