01/05: build-system/trivial: Add support for #:allowed-references.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 297602513bf023e485a496bbb813cb9cafdf7475
Author: Ludovic Courtès <address@hidden>
Date:   Wed Feb 28 16:42:34 2018 +0100

    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.
---
 guix/build-system/trivial.scm | 42 +++++++++++++++++++++++++++++++++++++-----
 tests/packages.scm            | 20 +++++++++++++++++++-
 2 files changed, 56 insertions(+), 6 deletions(-)

diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index 350b1df..b50ef7c 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 <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2018 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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 930374d..b2fa21a 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 
<address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; 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