From d9085c23c4503347366e54707e80025ca4526941 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 8 Jun 2012 21:31:01 +0200
Subject: Add `build-expression->derivation'.

* 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.
---
 guix/derivations.scm  | 60 +++++++++++++++++++++++++++++++++++++++++++--------
 tests/derivations.scm | 32 +++++++++++++++++++++++++++
 2 files changed, 83 insertions(+), 9 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 09f58f0fb8..7bc14586ba 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -49,7 +49,10 @@
             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 @@ known in advance, such as a file download."
           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 @@ known in advance, such as a file download."
                                (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)))))
diff --git a/tests/derivations.scm b/tests/derivations.scm
index f2a3bb2d55..ff766cf175 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -94,6 +94,38 @@
          (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)
 
 
-- 
cgit v1.2.3