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

Add `build-expression->derivation'.

Browse source 
* guix/derivations.scm (%guile-for-build): New parameter.
  (build-expression->derivation): New procedure.

* tests/derivations.scm ("build-expression->derivation without inputs",
  "build-expression->derivation with one input"): New tests.
This commit is contained in:
Ludovic Courtès 2012-06-08 21:31:01 +02:00
parent de4c3f26cb
commit d9085c23c4
2 changed files with 83 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
guix/derivations.scm
View file

@ -49,7 +49,10 @@ (define-module (guix derivations)
read-derivation
write-derivation
derivation-path->output-path
derivation))
derivation
%guile-for-build
build-expression->derivation))
;;;
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
@ -282,14 +285,14 @@ (define (add-output-paths drv)
system builder args env-vars)
(let* ((drv-hash (derivation-hash drv))
(outputs (map (match-lambda
((output-name . ($ <derivation-output>
_ algo hash))
(let ((path (output-path output-name
drv-hash name)))
(cons output-name
(make-derivation-output path algo
hash)))))
outputs)))
((output-name . ($ <derivation-output>
_ algo hash))
(let ((path (output-path output-name
drv-hash name)))
(cons output-name
(make-derivation-output path algo
hash)))))
outputs)))
(make-derivation outputs inputs sources system builder args
(map (match-lambda
((name . value)
@ -351,3 +354,42 @@ (define (env-vars-with-empty-outputs)
(map derivation-input-path
inputs))
drv)))
;;;
;;; Guile-based builders.
;;;
(define %guile-for-build
;; The derivation of the Guile to be used within the build environment,
;; when using `build-expression->derivation'.
(make-parameter (false-if-exception (nixpkgs-derivation "guile"))))
(define* (build-expression->derivation store name system exp inputs
#:key hash hash-algo)
"Return a derivation that executes Scheme expression EXP as a builder for
derivation NAME. INPUTS must be a list of string/derivation-path pairs. EXP
is evaluated in an environment where %OUTPUT is bound to the output path, and
where %BUILD-INPUTS is bound to an alist of string/output-path pairs made
from INPUTS."
(define guile
(string-append (derivation-path->output-path (%guile-for-build))
"/bin/guile"))
(let* ((prologue `(begin
(define %output (getenv "out"))
(define %build-inputs
',(map (match-lambda
((name . drv)
(cons name
(derivation-path->output-path drv))))
inputs))) )
(builder (add-text-to-store store
(string-append name "-guile-builder")
(string-append (object->string prologue)
(object->string exp))
(map cdr inputs))))
(derivation store name system guile `("--no-auto-compile" ,builder)
'(("HOME" . "/homeless"))
`((,(%guile-for-build))
(,builder)))))

32
tests/derivations.scm
View file

@ -94,6 +94,38 @@ (define %coreutils
(let ((p (derivation-path->output-path drv-path)))
(file-exists? (string-append p "/good"))))))
(test-skip (if (%guile-for-build) 0 2))
(test-assert "build-expression->derivation without inputs"
(let* ((builder '(begin
(mkdir %output)
(call-with-output-file (string-append %output "/test")
(lambda (p)
(display '(hello guix) p)))))
(drv-path (build-expression->derivation %store "goo" "x86_64-linux"
builder '()))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(equal? '(hello guix)
(call-with-input-file (string-append p "/test") read))))))
(test-assert "build-expression->derivation with one input"
(let* ((builder '(call-with-output-file %output
(lambda (p)
(let ((cu (assoc-ref %build-inputs "cu")))
(close 1)
(dup2 (port->fdes p) 1)
(execl (string-append cu "/bin/uname")
"uname" "-a")))))
(drv-path (build-expression->derivation %store "uname" "x86_64-linux"
builder
`(("cu" . ,%coreutils))))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(string-contains (call-with-input-file p read-line) "GNU")))))
(test-end)