03/04: gexp: 'file-union' accepts directory names.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 5dec93bb8ba89605bce2f9a5ee9c4dbadeee3b58
Author: Ludovic Courtès <address@hidden>
Date:   Sat Sep 8 22:56:40 2018 +0200

    gexp: 'file-union' accepts directory names.
    
    * guix/gexp.scm (file-union): Import (guix build utils).  Make the
    parent directories of TARGET.
    * tests/gexp.scm ("file-union"): New test.
---
 guix/gexp.scm  | 39 ++++++++++++++++++++++-----------------
 tests/gexp.scm | 18 ++++++++++++++++++
 2 files changed, 40 insertions(+), 17 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index ffc976d..f7a23db 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1479,26 +1479,31 @@ denoting the target file.  Here's an example:
               `((\"hosts\" ,(plain-file \"hosts\"
                                         \"127.0.0.1 localhost\"))
                 (\"bashrc\" ,(plain-file \"bashrc\"
-                                         \"alias ls='ls --color'\"))))
+                                         \"alias ls='ls --color'\"))
+                (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\"))))
 
 This yields an 'etc' directory containing these two files."
   (computed-file name
-                 (gexp
-                  (begin
-                    (mkdir (ungexp output))
-                    (chdir (ungexp output))
-                    (ungexp-splicing
-                     (map (match-lambda
-                            ((target source)
-                             (gexp
-                              (begin
-                                ;; Stat the source to abort early if it does
-                                ;; not exist.
-                                (stat (ungexp source))
-
-                                (symlink (ungexp source)
-                                         (ungexp target))))))
-                          files))))))
+                 (with-imported-modules '((guix build utils))
+                   (gexp
+                    (begin
+                      (use-modules (guix build utils))
+
+                      (mkdir (ungexp output))
+                      (chdir (ungexp output))
+                      (ungexp-splicing
+                       (map (match-lambda
+                              ((target source)
+                               (gexp
+                                (begin
+                                  ;; Stat the source to abort early if it does
+                                  ;; not exist.
+                                  (stat (ungexp source))
+
+                                  (mkdir-p (dirname (ungexp target)))
+                                  (symlink (ungexp source)
+                                           (ungexp target))))))
+                            files)))))))
 
 (define* (directory-union name things
                           #:key (copy? #f) (quiet? #f)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index b22e635..5d049cd 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1093,6 +1093,24 @@
                                (call-with-input-file out get-string-all))
                      (equal? refs (list guile))))))))
 
+(test-assertm "file-union"
+  (mlet* %store-monad ((union -> (file-union "union"
+                                             `(("a" ,(plain-file "a" "1"))
+                                               ("b/c/d" ,(plain-file "d" "2"))
+                                               ("e" ,(plain-file "e" "3")))))
+                       (drv      (lower-object union))
+                       (out ->   (derivation->output-path drv)))
+    (define (contents=? file str)
+      (string=? (call-with-input-file (string-append out "/" file)
+                  get-string-all)
+                str))
+
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (return (and (contents=? "a" "1")
+                   (contents=? "b/c/d" "2")
+                   (contents=? "e" "3"))))))
+
 (test-assert "gexp->derivation vs. %current-target-system"
   (let ((mval (gexp->derivation "foo"
                                 #~(begin