aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-02-28 16:42:34 +0100
committerLudovic Courtès <ludo@gnu.org>2018-02-28 22:47:42 +0100
commit297602513bf023e485a496bbb813cb9cafdf7475 (patch)
tree805f022d6ef1f61d88cfaedda83835e85fa9d8c7
parentbcc65510839d1b1800e0fd93b7e4c4d8f79a754c (diff)
downloadguix-297602513bf023e485a496bbb813cb9cafdf7475.tar
guix-297602513bf023e485a496bbb813cb9cafdf7475.tar.gz
build-system/trivial: Add support for #:allowed-references.
* guix/build-system/trivial.scm (lower): Add #:allowed-references and keep it in the 'arguments' field. (trivial-build): Add #:allowed-references. Add 'canonicalize-reference'. Pass #:allowed-references to 'build-expression->derivation'. (trivial-cross-build): Likewise. * tests/packages.scm ("trivial with #:allowed-references"): New test.
-rw-r--r--guix/build-system/trivial.scm42
-rw-r--r--tests/packages.scm20
2 files changed, 56 insertions, 6 deletions
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index 350b1df553..b50ef7cd92 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -36,7 +36,7 @@
(define* (lower name
#:key source inputs native-inputs outputs system target
- guile builder modules)
+ guile builder modules allowed-references)
"Return a bag for NAME."
(bag
(name name)
@@ -51,19 +51,36 @@
(build (if target trivial-cross-build trivial-build))
(arguments `(#:guile ,guile
#:builder ,builder
- #:modules ,modules))))
+ #:modules ,modules
+ #:allowed-references ,allowed-references))))
(define* (trivial-build store name inputs
#:key
outputs guile system builder (modules '())
- search-paths)
+ search-paths allowed-references)
"Run build expression BUILDER, an expression, for SYSTEM. SOURCE is
ignored."
+ (define canonicalize-reference
+ (match-lambda
+ ((? package? p)
+ (derivation->output-path (package-derivation store p system
+ #:graft? #f)))
+ (((? package? p) output)
+ (derivation->output-path (package-derivation store p system
+ #:graft? #f)
+ output))
+ ((? string? output)
+ output)))
+
(build-expression->derivation store name builder
#:inputs inputs
#:system system
#:outputs outputs
#:modules modules
+ #:allowed-references
+ (and allowed-references
+ (map canonicalize-reference
+ allowed-references))
#:guile-for-build
(guile-for-build store guile system)))
@@ -71,14 +88,29 @@ ignored."
#:key
target native-drvs target-drvs
outputs guile system builder (modules '())
- search-paths native-search-paths)
+ search-paths native-search-paths
+ allowed-references)
"Run build expression BUILDER, an expression, for SYSTEM. SOURCE is
ignored."
+ (define canonicalize-reference
+ (match-lambda
+ ((? package? p)
+ (derivation->output-path (package-cross-derivation store p system)))
+ (((? package? p) output)
+ (derivation->output-path (package-cross-derivation store p system)
+ output))
+ ((? string? output)
+ output)))
+
(build-expression->derivation store name builder
#:inputs (append native-drvs target-drvs)
#:system system
#:outputs outputs
#:modules modules
+ #:allowed-references
+ (and allowed-references
+ (map canonicalize-reference
+ allowed-references))
#:guile-for-build
(guile-for-build store guile system)))
diff --git a/tests/packages.scm b/tests/packages.scm
index 930374dabf..b2fa21a874 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -557,6 +557,24 @@
(let ((p (pk 'drv d (derivation->output-path d))))
(eq? 'hello (call-with-input-file p read))))))
+(test-assert "trivial with #:allowed-references"
+ (let* ((p (package
+ (inherit (dummy-package "trivial"))
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:allowed-references (,%bootstrap-guile)
+ #:builder
+ (begin
+ (mkdir %output)
+ ;; The reference to itself isn't allowed so building it
+ ;; should fail.
+ (symlink %output (string-append %output "/self")))))))
+ (d (package-derivation %store p)))
+ (guard (c ((nix-protocol-error? c) #t))
+ (build-derivations %store (list d))
+ #f)))
+
(test-assert "search paths"
(let* ((p (make-prompt-tag "return-search-paths"))
(s (build-system