2 files changed, 56 insertions(+), 6 deletions(-)

M guix/build-system/trivial.scm
M tests/packages.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)))
 

@@ 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