ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2018-02-28 16:42:34 +01:00
parent bcc6551083
commit 297602513b
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 56 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
guix/build-system/trivial.scm
View file

@ -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 (guile-for-build store guile system)
(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 @@ (define* (lower name
(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 @@ (define* (trivial-cross-build store name
#: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)))

20
tests/packages.scm
View file

@ -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 @@ (define read-at
(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