[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: gexp: Add #:allowed-references parameter to 'gexp->derivation'.
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: gexp: Add #:allowed-references parameter to 'gexp->derivation'. |
|
Date: |
Wed, 11 Feb 2015 21:12:30 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit c8351d9a409879b3d948db3713ce4fe4b787bcd0
Author: Ludovic Courtès <address@hidden>
Date: Wed Feb 11 22:10:14 2015 +0100
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.
---
doc/guix.texi | 8 ++++++--
guix/gexp.scm | 35 +++++++++++++++++++++++++++++++++--
tests/gexp.scm | 25 +++++++++++++++++++++++++
3 files changed, 64 insertions(+), 4 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index f292182..0c6b1e4 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.
address@hidden 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 4e8f91d..fa712a8 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 d80f143..03722e4 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"))