[bug#32174] [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities

[bug#32174] [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities

[Ludovic Courtès]

Hello!

This patch changes some low-level machinery to allow “virtual file trees”
to be imported directly into the store.

Previously the ‘imported-files’ procedures (yeah, there’s a couple of
them…) would create a derivation that would map source files to their final
destination.  Now, it directly imports files in the right place, thereby
avoiding a derivation.  This is notably useful for (guix self), which
imports a large number of files.

Overall it can reduce the number of RPCs, too.  For example:

--8<---------------cut here---------------start------------->8---
$ GUIX_PROFILING=rpc guix system build gnu/system/examples/bare-bones.tmpl -d --no-grafts
/gnu/store/wmv4ypapmzd2ynx6njayc3k87mc1gnjz-system.drv
Remote procedure call summary: 1930 RPCs
  built-in-builders              ...     1
  add-to-store                   ...   183
  add-text-to-store              ...  1746
$ GUIX_PROFILING=rpc ./pre-inst-env guix system build gnu/system/examples/bare-bones.tmpl -d --no-grafts
/gnu/store/yy1js0wimwrdfah5n8sw14jh3dayn39k-system.drv
Remote procedure call summary: 1891 RPCs
  built-in-builders              ...     1
  add-to-store/tree              ...    15
  add-to-store                   ...   162
  add-text-to-store              ...  1713
--8<---------------cut here---------------end--------------->8---

To avoid a full rebuild, this mechanism is currently disabled for package
builds, where we’d see a more noticeably difference.  When we merge to
‘core-updates’, we’ll turn it on by default and remove the compatibility
hacks like the #:derivation? parameter.

Feedback welcome!

Ludo’.

Ludovic Courtès (6):
  serialization: Add 'write-file-tree'.
  store: Add 'add-file-tree-to-store'.
  gexp: Remove unnecessary 'mlet'.
  gexp: 'imported-files' no longer creates a derivation by default.
  gexp: 'imported-files/derivation' can copy files instead of
    symlinking.
  self: Use the new 'imported-files'.

 guix/gexp.scm          | 143 +++++++++++++++++++++++++++++++++--------
 guix/packages.scm      |   3 +
 guix/self.scm          |  57 +++++++---------
 guix/serialization.scm | 140 +++++++++++++++++++++++++++++++---------
 guix/store.scm         | 100 ++++++++++++++++++++++++++++
 tests/gexp.scm         |  31 ++++-----
 tests/nar.scm          |  62 +++++++++++++++++-
 tests/store.scm        |  46 +++++++++++++
 8 files changed, 473 insertions(+), 109 deletions(-)

-- 
2.18.0

[bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree'.

[Ludovic Courtès]

* guix/serialization.scm (write-contents-from-port): New procedure.
(write-contents): Write in terms of 'write-contents-from-port'.
(filter/sort-directory-entries, write-file-tree): New procedures.
(write-file): Rewrite in terms of 'write-file-tree'.
* tests/nar.scm ("write-file-tree + restore-file"): New test.
---
 guix/serialization.scm | 140 +++++++++++++++++++++++++++++++----------
 tests/nar.scm          |  62 +++++++++++++++++-
 2 files changed, 169 insertions(+), 33 deletions(-)

diff --git a/guix/serialization.scm b/guix/serialization.scm
index b41a0a09d..129374f54 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -47,6 +47,7 @@
             nar-read-error-token
 
             write-file
+            write-file-tree
             restore-file))
 
 ;;; Comment:
@@ -211,14 +212,19 @@ substitute invalid byte sequences with question marks.  This is a
           (lambda ()
             (close-port port))))))
 
-  (write-string "contents" p)
-  (write-long-long size p)
   (call-with-binary-input-file file
-    ;; Use 'sendfile' when P is a file port.
-    (if (file-port? p)
-        (cut sendfile p <> size 0)
-        (cut dump <> p size)))
-  (write-padding size p))
+    (lambda (input)
+      (write-contents-from-port input p size))))
+
+(define (write-contents-from-port input output size)
+  "Write SIZE bytes from port INPUT to port OUTPUT."
+  (write-string "contents" output)
+  (write-long-long size output)
+  ;; Use 'sendfile' when both OUTPUT and INPUT are file ports.
+  (if (and (file-port? output) (file-port? input))
+      (sendfile output input size 0)
+      (dump input output size))
+  (write-padding size output))
 
 (define (read-contents in out)
   "Read the contents of a file from the Nar at IN, write it to OUT, and return
@@ -263,47 +269,113 @@ the size in bytes."
 sub-directories of FILE as needed.  For each directory entry, call (SELECT?
 FILE STAT), where FILE is the entry's absolute file name and STAT is the
 result of 'lstat'; exclude entries for which SELECT? does not return true."
+  (write-file-tree file port
+                   #:file-type+size
+                   (lambda (file)
+                     (let* ((stat (lstat file))
+                            (size (stat:size stat)))
+                       (case (stat:type stat)
+                         ((directory)
+                          (values 'directory size))
+                         ((regular)
+                          (values (if (zero? (logand (stat:mode stat)
+                                                     #o100))
+                                      'regular
+                                      'executable)
+                                  size))
+                         (else
+                          (values (stat:type stat) size))))) ;bah!
+                   #:file-port (cut open-file <> "r0b")
+                   #:symlink-target readlink
+
+                   #:directory-entries
+                   (lambda (directory)
+                     ;; 'scandir' defaults to 'string-locale<?' to sort files,
+                     ;; but this happens to be case-insensitive (at least in
+                     ;; 'en_US' locale on libc 2.18.)  Conversely, we want
+                     ;; files to be sorted in a case-sensitive fashion.
+                     (define basenames
+                       (scandir directory (negate (cut member <> '("." "..")))
+                                string<?))
+
+                     (filter-map (lambda (base)
+                                   (let ((file (string-append directory
+                                                              "/" base)))
+                                     (and (not (member base '("." "..")))
+                                          (select? file (lstat file))
+                                          base)))
+                                 basenames))
+
+                   ;; The 'scandir' call above gives us filtered and sorted
+                   ;; entries, so no post-processing is needed.
+                   #:postprocess-entries identity))
+
+(define (filter/sort-directory-entries lst)
+  "Remove dot and dot-dot entries from LST, and sort it in lexicographical
+order."
+  (delete-duplicates
+   (sort (remove (cute member <> '("." "..")) lst)
+         string<?)
+   string=?))
+
+(define* (write-file-tree file port
+                          #:key
+                          file-type+size
+                          file-port
+                          symlink-target
+                          directory-entries
+                          (postprocess-entries filter/sort-directory-entries))
+  "Write the contents of FILE to PORT in Nar format, recursing into
+sub-directories of FILE as needed.
+
+This procedure does not make any file-system I/O calls.  Instead, it calls the
+user-provided FILE-TYPE+SIZE, FILE-PORT, SYMLINK-TARGET, and DIRECTORY-ENTRIES
+procedures, which roughly correspond to 'lstat', 'readlink', and 'scandir'.
+POSTPROCESS-ENTRIES ensures that directory entries are valid; leave it as-is
+unless you know that DIRECTORY-ENTRIES provide filtered and sorted entries, in
+which case you can use 'identity'."
   (define p port)
 
   (write-string %archive-version-1 p)
 
-  (let dump ((f file) (s (lstat file)))
+  (let dump ((f file))
+    (define-values (type size)
+      (file-type+size f))
+
     (write-string "(" p)
-    (case (stat:type s)
-      ((regular)
+    (case type
+      ((regular executable)
        (write-string "type" p)
        (write-string "regular" p)
-       (if (not (zero? (logand (stat:mode s) #o100)))
-           (begin
-             (write-string "executable" p)
-             (write-string "" p)))
-       (write-contents f p (stat:size s)))
+       (when (eq? 'executable type)
+         (write-string "executable" p)
+         (write-string "" p))
+       (let ((input (file-port f)))
+         (dynamic-wind
+           (const #t)
+           (lambda ()
+             (write-contents-from-port input p size))
+           (lambda ()
+             (close-port input)))))
       ((directory)
        (write-string "type" p)
        (write-string "directory" p)
-       (let ((entries
-              ;; 'scandir' defaults to 'string-locale<?' to sort files, but
-              ;; this happens to be case-insensitive (at least in 'en_US'
-              ;; locale on libc 2.18.)  Conversely, we want files to be
-              ;; sorted in a case-sensitive fashion.
-              (scandir f (negate (cut member <> '("." ".."))) string<?)))
+       (let ((entries (postprocess-entries (directory-entries f))))
          (for-each (lambda (e)
-                     (let* ((f (string-append f "/" e))
-                            (s (lstat f)))
-                       (when (select? f s)
-                         (write-string "entry" p)
-                         (write-string "(" p)
-                         (write-string "name" p)
-                         (write-string e p)
-                         (write-string "node" p)
-                         (dump f s)
-                         (write-string ")" p))))
+                     (let* ((f (string-append f "/" e)))
+                       (write-string "entry" p)
+                       (write-string "(" p)
+                       (write-string "name" p)
+                       (write-string e p)
+                       (write-string "node" p)
+                       (dump f)
+                       (write-string ")" p)))
                    entries)))
       ((symlink)
        (write-string "type" p)
        (write-string "symlink" p)
        (write-string "target" p)
-       (write-string (readlink f) p))
+       (write-string (symlink-target f) p))
       (else
        (raise (condition (&message (message "unsupported file type"))
                          (&nar-error (file f) (port port))))))
@@ -379,4 +451,8 @@ Restore it as FILE."
            (&message (message "unsupported nar entry type"))
            (&nar-read-error (port port) (file file) (token x)))))))))
 
+;;; Local Variables:
+;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
+;;; End:
+
 ;;; serialization.scm ends here
diff --git a/tests/nar.scm b/tests/nar.scm
index 61646db96..9b5fb984b 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -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.
 ;;;
@@ -152,6 +152,66 @@
 \f
 (test-begin "nar")
 
+(test-assert "write-file-tree + restore-file"
+  (let* ((file1  (search-path %load-path "guix.scm"))
+         (file2  (search-path %load-path "guix/base32.scm"))
+         (file3  "#!/bin/something")
+         (output (string-append %test-dir "/output")))
+    (dynamic-wind
+      (lambda () #t)
+      (lambda ()
+        (define-values (port get-bytevector)
+          (open-bytevector-output-port))
+        (write-file-tree "root" port
+                         #:file-type+size
+                         (match-lambda
+                           ("root"
+                            (values 'directory 0))
+                           ("root/foo"
+                            (values 'regular (stat:size (stat file1))))
+                           ("root/lnk"
+                            (values 'symlink 0))
+                           ("root/dir"
+                            (values 'directory 0))
+                           ("root/dir/bar"
+                            (values 'regular (stat:size (stat file2))))
+                           ("root/dir/exe"
+                            (values 'executable (string-length file3))))
+                         #:file-port
+                         (match-lambda
+                           ("root/foo" (open-input-file file1))
+                           ("root/dir/bar" (open-input-file file2))
+                           ("root/dir/exe" (open-input-string file3)))
+                         #:symlink-target
+                         (match-lambda
+                           ("root/lnk" "foo"))
+                         #:directory-entries
+                         (match-lambda
+                           ("root" '("foo" "dir" "lnk"))
+                           ("root/dir" '("bar" "exe"))))
+        (close-port port)
+
+        (rm-rf %test-dir)
+        (mkdir %test-dir)
+        (restore-file (open-bytevector-input-port (get-bytevector))
+                      output)
+        (and (file=? (string-append output "/foo") file1)
+             (string=? (readlink (string-append output "/lnk"))
+                       "foo")
+             (file=? (string-append output "/dir/bar") file2)
+             (string=? (call-with-input-file (string-append output "/dir/exe")
+                         get-string-all)
+                       file3)
+             (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
+                        #o100)
+                0)
+             (equal? '("." ".." "bar" "exe")
+                     (scandir (string-append output "/dir")))
+             (equal? '("." ".." "dir" "foo" "lnk")
+                     (scandir output))))
+      (lambda ()
+        (false-if-exception (rm-rf %test-dir))))))
+
 (test-assert "write-file supports non-file output ports"
   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))
-- 
2.18.0

[bug#32174] [PATCH 2/6] store: Add 'add-file-tree-to-store'.

[Ludovic Courtès]

* guix/store.scm (%not-slash): New variable.
(add-file-tree-to-store, interned-file-tree): New procedures.
* tests/store.scm ("add-file-tree-to-store"): New test.
---
 guix/store.scm  | 100 ++++++++++++++++++++++++++++++++++++++++++++++++
 tests/store.scm |  46 ++++++++++++++++++++++
 2 files changed, 146 insertions(+)

diff --git a/guix/store.scm b/guix/store.scm
index cc5c24a77..f41a1e269 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -78,6 +78,7 @@
             add-data-to-store
             add-text-to-store
             add-to-store
+            add-file-tree-to-store
             binary-file
             build-things
             build
@@ -137,6 +138,7 @@
             set-current-system
             text-file
             interned-file
+            interned-file-tree
 
             %store-prefix
             store-path
@@ -951,6 +953,101 @@ where FILE is the entry's absolute file name and STAT is the result of
               (hash-set! cache args path)
               path))))))
 
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define* (add-file-tree-to-store server tree
+                                 #:key
+                                 (hash-algo "sha256")
+                                 (recursive? #t))
+  "Add the given TREE to the store on SERVER.  TREE must be an entry such as:
+
+  (\"my-tree\" directory
+    (\"a\" regular (data \"hello\"))
+    (\"b\" symlink \"a\")
+    (\"c\" directory
+      (\"d\" executable (file \"/bin/sh\"))))
+
+This is a generalized version of 'add-to-store'.  It allows you to reproduce
+an arbitrary directory layout in the store without creating a derivation."
+
+  ;; Note: The format of TREE was chosen to allow trees to be compared with
+  ;; 'equal?', which in turn allows us to memoize things.
+
+  (define root
+    ;; TREE is a single entry.
+    (list tree))
+
+  (define basename
+    (match tree
+      ((name . _) name)))
+
+  (define (lookup file)
+    (let loop ((components (string-tokenize file %not-slash))
+               (tree root))
+      (match components
+        ((basename)
+         (assoc basename tree))
+        ((head . rest)
+         (loop rest
+               (match (assoc-ref tree head)
+                 (('directory . entries) entries)))))))
+
+  (define (file-type+size file)
+    (match (lookup file)
+      ((_ (and type (or 'directory 'symlink)) . _)
+       (values type 0))
+      ((_ type ('file file))
+       (values type (stat:size (stat file))))
+      ((_ type ('data (? string? data)))
+       (values type (string-length data)))
+      ((_ type ('data (? bytevector? data)))
+       (values type (bytevector-length data)))))
+
+  (define (file-port file)
+    (match (lookup file)
+      ((_ (or 'regular 'executable) content)
+       (match content
+         (('file (? string? file))
+          (open-file file "r0b"))
+         (('data (? string? str))
+          (open-input-string str))
+         (('data (? bytevector? bv))
+          (open-bytevector-input-port bv))))))
+
+  (define (symlink-target file)
+    (match (lookup file)
+      ((_ 'symlink target) target)))
+
+  (define (directory-entries directory)
+    (match (lookup directory)
+      ((_ 'directory (names . _) ...) names)))
+
+  (define cache
+    (nix-server-add-to-store-cache server))
+
+  (or (hash-ref cache tree)
+      (begin
+        ;; We don't use the 'operation' macro so we can use 'write-file-tree'
+        ;; instead of 'write-file'.
+        (record-operation 'add-to-store/tree)
+        (let ((port (nix-server-socket server)))
+          (write-int (operation-id add-to-store) port)
+          (write-string basename port)
+          (write-int 1 port)                      ;obsolete, must be #t
+          (write-int (if recursive? 1 0) port)
+          (write-string hash-algo port)
+          (write-file-tree basename port
+                           #:file-type+size file-type+size
+                           #:file-port file-port
+                           #:symlink-target symlink-target
+                           #:directory-entries directory-entries)
+          (let loop ((done? (process-stderr server)))
+            (or done? (loop (process-stderr server))))
+          (let ((result (read-store-path port)))
+            (hash-set! cache tree result)
+            result)))))
+
 (define build-things
   (let ((build (operation (build-things (string-list things)
                                         (integer mode))
@@ -1402,6 +1499,9 @@ where FILE is the entry's absolute file name and STAT is the result of
                           #:select? select?)
             store)))
 
+(define interned-file-tree
+  (store-lift add-file-tree-to-store))
+
 (define build
   ;; Monadic variant of 'build-things'.
   (store-lift build-things))
diff --git a/tests/store.scm b/tests/store.scm
index afecec940..47fab0df1 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -210,6 +210,52 @@
            (valid-path? store path)
            (file-exists? path)))))
 
+(test-equal "add-file-tree-to-store"
+  `(42
+    ("." directory #t)
+    ("./bar" directory #t)
+    ("./foo" directory #t)
+    ("./foo/a" regular "file a")
+    ("./foo/b" symlink "a")
+    ("./foo/c" directory #t)
+    ("./foo/c/p" regular "file p")
+    ("./foo/c/q" directory #t)
+    ("./foo/c/q/x" regular "#!/bin/sh\nexit 42")
+    ("./foo/c/q/y" symlink "..")
+    ("./foo/c/q/z" directory #t))
+  (let* ((tree  `("file-tree" directory
+                  ("foo" directory
+                   ("a" regular (data "file a"))
+                   ("b" symlink "a")
+                   ("c" directory
+                    ("p" regular (data ,(string->utf8 "file p")))
+                    ("q" directory
+                     ("x" executable
+                      (data "#!/bin/sh\nexit 42"))
+                     ("y" symlink "..")
+                     ("z" directory))))
+                  ("bar" directory)))
+         (result (add-file-tree-to-store %store tree)))
+    (cons (status:exit-val (system* (string-append result "/foo/c/q/x")))
+          (with-directory-excursion result
+            (map (lambda (file)
+                   (let ((type (stat:type (lstat file))))
+                     `(,file ,type
+                             ,(match type
+                                ((or 'regular 'executable)
+                                 (call-with-input-file file
+                                   get-string-all))
+                                ('symlink (readlink file))
+                                ('directory #t)))))
+                 (find-files "." #:directories? #t))))))
+
+(test-equal "add-file-tree-to-store, flat"
+  "Hello, world!"
+  (let* ((tree   `("flat-file" regular (data "Hello, world!")))
+         (result (add-file-tree-to-store %store tree)))
+    (and (file-exists? result)
+         (call-with-input-file result get-string-all))))
+
 (test-assert "references"
   (let* ((t1 (add-text-to-store %store "random1"
                                 (random-text)))
-- 
2.18.0

[bug#32174] [PATCH 3/6] gexp: Remove unnecessary 'mlet'.

[Ludovic Courtès]

* guix/gexp.scm (imported-modules): Use 'let' instead of 'mlet'.
---
 guix/gexp.scm | 20 ++++++++------------
 1 file changed, 8 insertions(+), 12 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index cc3613f6f..3414b81dc 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1098,18 +1098,14 @@ by an arrow followed by a file-like object.  For example:
 
 In this example, the first two modules are taken from MODULE-PATH, and the
 last one is created from the given <scheme-file> object."
-  (mlet %store-monad ((files
-                       (mapm %store-monad
-                             (match-lambda
-                               (((module ...) '=> file)
-                                (return
-                                 (cons (module->source-file-name module)
-                                       file)))
-                               ((module ...)
-                                (let ((f (module->source-file-name module)))
-                                  (return
-                                   (cons f (search-path* module-path f))))))
-                             modules)))
+  (let ((files (map (match-lambda
+                      (((module ...) '=> file)
+                       (cons (module->source-file-name module)
+                             file))
+                      ((module ...)
+                       (let ((f (module->source-file-name module)))
+                         (cons f (search-path* module-path f)))))
+                    modules)))
     (imported-files files #:name name #:system system
                     #:guile guile
                     #:deprecation-warnings deprecation-warnings)))
-- 
2.18.0

[bug#32174] [PATCH 4/6] gexp: 'imported-files' no longer creates a derivation by default.

[Ludovic Courtès]

* guix/gexp.scm (gexp->derivation): Add #:import-creates-derivation?.
Pass #:derivation? to 'imported-modules' and 'compiled-modules'.  In -L
argument, check whether MODULES is a derivation.
(%not-slash): New variable.
(file-mapping->tree): New procedure.
(imported-files): Rename to...
(imported-files/derivation): ... this.
(imported-files): New procedure.  Rewrite in terms of
'interned-file-tree' when possible; add #:derivation? parameter.
(imported-modules, compiled-modules): Add #:derivation? parameter and
pass it to 'imported-files'.
* guix/packages.scm (patch-and-repack): Pass
 #:import-creates-derivation? to 'gexp->derivation'.
* tests/gexp.scm ("imported-files"): Adjust to no longer expect a
derivation.
---
 guix/gexp.scm     | 115 ++++++++++++++++++++++++++++++++++++++++------
 guix/packages.scm |   3 ++
 tests/gexp.scm    |  20 ++++----
 3 files changed, 114 insertions(+), 24 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 3414b81dc..19d90f5ee 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -601,6 +601,12 @@ names and file names suitable for the #:allowed-references argument to
                            allowed-references disallowed-references
                            leaked-env-vars
                            local-build? (substitutable? #t)
+
+                           ;; TODO: This parameter is transitional; it's here
+                           ;; to avoid a full rebuild.  Remove it on the next
+                           ;; rebuild cycle.
+                           import-creates-derivation?
+
                            deprecation-warnings
                            (script-name (string-append name "-builder")))
   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
@@ -695,6 +701,8 @@ The other arguments are as for 'derivation'."
                                        extensions))
                        (modules  (if (pair? %modules)
                                      (imported-modules %modules
+                                                       #:derivation?
+                                                       import-creates-derivation?
                                                        #:system system
                                                        #:module-path module-path
                                                        #:guile guile-for-build
@@ -703,6 +711,8 @@ The other arguments are as for 'derivation'."
                                      (return #f)))
                        (compiled (if (pair? %modules)
                                      (compiled-modules %modules
+                                                       #:derivation?
+                                                       import-creates-derivation?
                                                        #:system system
                                                        #:module-path module-path
                                                        #:extensions extensions
@@ -735,7 +745,9 @@ The other arguments are as for 'derivation'."
                                      "/bin/guile")
                       `("--no-auto-compile"
                         ,@(if (pair? %modules)
-                              `("-L" ,(derivation->output-path modules)
+                              `("-L" ,(if (derivation? modules)
+                                          (derivation->output-path modules)
+                                          modules)
                                 "-C" ,(derivation->output-path compiled))
                               '())
                         ,@(append-map extension-flags exts)
@@ -1013,6 +1025,49 @@ execution environment."
 ;;; Module handling.
 ;;;
 
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (file-mapping->tree mapping)
+  "Convert MAPPING, an alist like:
+
+  ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
+
+to a tree suitable for 'interned-file-tree'."
+  (let ((mapping (map (match-lambda
+                        ((destination . source)
+                         (cons (string-tokenize destination
+                                                %not-slash)
+                               source)))
+                      mapping)))
+    (fold (lambda (pair result)
+            (match pair
+              ((destination . source)
+               (let loop ((destination destination)
+                          (result result))
+                 (match destination
+                   ((file)
+                    (let* ((mode (stat:mode (stat source)))
+                           (type (if (zero? (logand mode #o100))
+                                     'regular
+                                     'executable)))
+                      (alist-cons file
+                                  `(,type (file ,source))
+                                  result)))
+                   ((file rest ...)
+                    (let ((directory (assoc-ref result file)))
+                      (alist-cons file
+                                  `(directory
+                                    ,@(loop rest
+                                            (match directory
+                                              (('directory . entries) entries)
+                                              (#f '()))))
+                                  (if directory
+                                      (alist-delete file result)
+                                      result)))))))))
+          '()
+          mapping)))
+
 (define %utils-module
   ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
   ;; other primitives below.  Note: We give the file name relative to this
@@ -1021,18 +1076,18 @@ execution environment."
   (local-file "build/utils.scm"
               "build-utils.scm"))
 
-(define* (imported-files files
-                         #:key (name "file-import")
-                         (system (%current-system))
-                         (guile (%guile-for-build))
+(define* (imported-files/derivation files
+                                    #:key (name "file-import")
+                                    (system (%current-system))
+                                    (guile (%guile-for-build))
 
-                         ;; XXX: The only reason we have
-                         ;; #:deprecation-warnings is because (guix build
-                         ;; utils), which we use here, relies on _IO*, which
-                         ;; is deprecated in 2.2.  On the next full-rebuild
-                         ;; cycle, we should disable such warnings
-                         ;; unconditionally.
-                         (deprecation-warnings #f))
+                                    ;; XXX: The only reason we have
+                                    ;; #:deprecation-warnings is because (guix
+                                    ;; build utils), which we use here, relies
+                                    ;; on _IO*, which is deprecated in 2.2.  On
+                                    ;; the next full-rebuild cycle, we should
+                                    ;; disable such warnings unconditionally.
+                                    (deprecation-warnings #f))
   "Return a derivation that imports FILES into STORE.  FILES must be a list
 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
 resulting store path.  FILE can be either a file name, or a file-like object,
@@ -1081,8 +1136,38 @@ as returned by 'local-file' for example."
                         (else
                          '())))))
 
+(define* (imported-files files
+                         #:key (name "file-import")
+
+                         ;; TODO: Remove this parameter on the next rebuild
+                         ;; cycle.
+                         (derivation? #f)
+
+                         ;; The following parameters make sense when creating
+                         ;; an actual derivation.
+                         (system (%current-system))
+                         (guile (%guile-for-build))
+                         (deprecation-warnings #f))
+  "Import FILES into the store and return the resulting derivation or store
+file name (a derivation is created if and only if some elements of FILES are
+file-like objects and not local file names.)  FILES must be a list
+of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
+resulting store path.  FILE can be either a file name, or a file-like object,
+as returned by 'local-file' for example."
+  (if (or derivation?
+          (any (match-lambda
+                 ((_ . (? struct? source)) #t)
+                 (_ #f))
+               files))
+      (imported-files/derivation files #:name name
+                                 #:system system #:guile guile
+                                 #:deprecation-warnings deprecation-warnings)
+      (interned-file-tree `(,name directory
+                                  ,@(file-mapping->tree files)))))
+
 (define* (imported-modules modules
                            #:key (name "module-import")
+                           (derivation? #f)      ;TODO: remove on next rebuild
                            (system (%current-system))
                            (guile (%guile-for-build))
                            (module-path %load-path)
@@ -1106,12 +1191,15 @@ last one is created from the given <scheme-file> object."
                        (let ((f (module->source-file-name module)))
                          (cons f (search-path* module-path f)))))
                     modules)))
-    (imported-files files #:name name #:system system
+    (imported-files files #:name name
+                    #:derivation? derivation?
+                    #:system system
                     #:guile guile
                     #:deprecation-warnings deprecation-warnings)))
 
 (define* (compiled-modules modules
                            #:key (name "module-import-compiled")
+                           (derivation? #f)      ;TODO: remove on next rebuild
                            (system (%current-system))
                            (guile (%guile-for-build))
                            (module-path %load-path)
@@ -1131,6 +1219,7 @@ they can refer to each other."
          (not (equal? module-path %load-path))))
 
   (mlet %store-monad ((modules (imported-modules modules
+                                                 #:derivation? derivation?
                                                  #:system system
                                                  #:guile guile
                                                  #:module-path
diff --git a/guix/packages.scm b/guix/packages.scm
index c762fa7c3..a220b9c47 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -646,6 +646,9 @@ specifies modules in scope when evaluating SNIPPET."
 
     (let ((name (tarxz-name original-file-name)))
       (gexp->derivation name build
+                        ;; TODO: Remove this on the next rebuild cycle.
+                        #:import-creates-derivation? #t
+
                         #:graft? #f
                         #:system system
                         #:deprecation-warnings #t ;to avoid a rebuild
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 83fe81154..2a43b739c 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -635,18 +635,16 @@
                                             "guix/derivations.scm"))
                    ("p/q"   . ,(search-path %load-path "guix.scm"))
                    ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
-       (drv (imported-files files)))
+       (dir (imported-files files)))
     (mbegin %store-monad
-      (built-derivations (list drv))
-      (let ((dir (derivation->output-path drv)))
-        (return
-         (every (match-lambda
-                 ((path . source)
-                  (equal? (call-with-input-file (string-append dir "/" path)
-                            get-bytevector-all)
-                          (call-with-input-file source
-                            get-bytevector-all))))
-                files))))))
+      (return
+       (every (match-lambda
+                ((path . source)
+                 (equal? (call-with-input-file (string-append dir "/" path)
+                           get-bytevector-all)
+                         (call-with-input-file source
+                           get-bytevector-all))))
+              files)))))
 
 (test-assertm "imported-files with file-like objects"
   (mlet* %store-monad ((plain -> (plain-file "foo" "bar!"))
-- 
2.18.0

[bug#32174] [PATCH 5/6] gexp: 'imported-files/derivation' can copy files instead of symlinking.

[Ludovic Courtès]

* guix/gexp.scm (imported-files/derivation): Add #:symlink? and honor
it.
(imported-files): Pass #:symlink? to 'imported-files/derivation'.
* tests/gexp.scm ("imported-files with file-like objects"): Add 'file=?'
and use it instead of calling 'readlink'.
---
 guix/gexp.scm  |  8 ++++++--
 tests/gexp.scm | 11 +++++++----
 2 files changed, 13 insertions(+), 6 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 19d90f5ee..ffc976d61 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1078,6 +1078,7 @@ to a tree suitable for 'interned-file-tree'."
 
 (define* (imported-files/derivation files
                                     #:key (name "file-import")
+                                    (symlink? #f)
                                     (system (%current-system))
                                     (guile (%guile-for-build))
 
@@ -1091,7 +1092,8 @@ to a tree suitable for 'interned-file-tree'."
   "Return a derivation that imports FILES into STORE.  FILES must be a list
 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
 resulting store path.  FILE can be either a file name, or a file-like object,
-as returned by 'local-file' for example."
+as returned by 'local-file' for example.  If SYMLINK? is true, create symlinks
+to the source files instead of copying them."
   (define file-pair
     (match-lambda
      ((final-path . (? string? file-name))
@@ -1114,7 +1116,8 @@ as returned by 'local-file' for example."
          (for-each (match-lambda
                     ((final-path store-path)
                      (mkdir-p (dirname final-path))
-                     (symlink store-path final-path)))
+                     ((ungexp (if symlink? 'symlink 'copy-file))
+                      store-path final-path)))
                    '(ungexp files)))))
 
     ;; TODO: Pass FILES as an environment variable so that BUILD remains
@@ -1160,6 +1163,7 @@ as returned by 'local-file' for example."
                  (_ #f))
                files))
       (imported-files/derivation files #:name name
+                                 #:symlink? derivation?
                                  #:system system #:guile guile
                                  #:deprecation-warnings deprecation-warnings)
       (interned-file-tree `(,name directory
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 2a43b739c..5a547fee4 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -652,16 +652,19 @@
                        (files -> `(("a/b/c" . ,q-scm)
                                    ("p/q"   . ,plain)))
                        (drv      (imported-files files)))
+    (define (file=? file1 file2)
+      ;; Assume deduplication is in place.
+      (= (stat:ino (lstat file1))
+         (stat:ino (lstat file2))))
+
     (mbegin %store-monad
       (built-derivations (list drv))
       (mlet %store-monad ((dir -> (derivation->output-path drv))
                           (plain* (text-file "foo" "bar!"))
                           (q-scm* (interned-file q-scm "c")))
         (return
-         (and (string=? (readlink (string-append dir "/a/b/c"))
-                        q-scm*)
-              (string=? (readlink (string-append dir "/p/q"))
-                        plain*)))))))
+         (and (file=? (string-append dir "/a/b/c") q-scm*)
+              (file=? (string-append dir "/p/q") plain*)))))))
 
 (test-equal "gexp-modules & ungexp"
   '((bar) (foo))
-- 
2.18.0

[bug#32174] [PATCH 6/6] self: Use the new 'imported-files'.

[Ludovic Courtès]

That way, the source of most nodes is now a content-addressed store item
instead of a derivation.

* guix/self.scm (<file-mapping>): New record type.
(file-mapping-compiler): New procedure.
(scheme-node): Use 'file-mapping' instead of 'imported-files'.
(imported-files): Remove.
---
 guix/self.scm | 57 +++++++++++++++++++++------------------------------
 1 file changed, 23 insertions(+), 34 deletions(-)

diff --git a/guix/self.scm b/guix/self.scm
index c9c7138e6..5ad644b1d 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -112,6 +112,27 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
   (dependencies  node-dependencies)               ;list of nodes
   (compiled      node-compiled))                  ;node -> lowerable object
 
+;; File mappings are essentially an alist as passed to 'imported-files'.
+(define-record-type <file-mapping>
+  (file-mapping name alist)
+  file-mapping?
+  (name  file-mapping-name)
+  (alist file-mapping-alist))
+
+(define-gexp-compiler (file-mapping-compiler (mapping <file-mapping>)
+                                             system target)
+  ;; Here we use 'imported-files', which can arrange to directly import all
+  ;; the files instead of creating a derivation, when possible.
+  (imported-files (map (match-lambda
+                         ((destination (? local-file? file))
+                          (cons destination
+                                (local-file-absolute-file-name file)))
+                         ((destination source)
+                          (cons destination source))) ;silliness
+                       (file-mapping-alist mapping))
+                  #:name (file-mapping-name mapping)
+                  #:system system))
+
 (define (node-fold proc init nodes)
   (let loop ((nodes nodes)
              (visited (setq))
@@ -166,8 +187,8 @@ must be present in the search path."
                           (closure modules
                                    (node-modules/recursive dependencies))))
          (module-files (map module->import modules))
-         (source (imported-files (string-append name "-source")
-                                 (append module-files extra-files))))
+         (source (file-mapping (string-append name "-source")
+                               (append module-files extra-files))))
     (node name modules source dependencies
           (compiled-modules name source
                             (map car module-files)
@@ -766,38 +787,6 @@ assumed to be part of MODULES."
 ;;; Building.
 ;;;
 
-(define (imported-files name files)
-  ;; This is a non-monadic, simplified version of 'imported-files' from (guix
-  ;; gexp).
-  (define same-target?
-    (match-lambda*
-      (((file1 . _) (file2 . _))
-       (string=? file1 file2))))
-
-  (define build
-    (with-imported-modules (source-module-closure
-                            '((guix build utils)))
-      #~(begin
-          (use-modules (ice-9 match)
-                       (guix build utils))
-
-          (mkdir (ungexp output)) (chdir (ungexp output))
-          (for-each (match-lambda
-                      ((final-path store-path)
-                       (mkdir-p (dirname final-path))
-
-                       ;; Note: We need regular files to be regular files, not
-                       ;; symlinks, as this makes a difference for
-                       ;; 'add-to-store'.
-                       (copy-file store-path final-path)))
-                    '#$(delete-duplicates files same-target?)))))
-
-  ;; We're just copying files around, no need to substitute or offload it.
-  (computed-file name build
-                 #:options '(#:local-build? #t
-                             #:substitutable? #f
-                             #:env-vars (("COLUMNS" . "200")))))
-
 (define* (compiled-modules name module-tree module-files
                            #:optional
                            (dependencies '())
-- 
2.18.0

bug#32174: [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

> Ludovic Courtès (6):
>   serialization: Add 'write-file-tree'.
>   store: Add 'add-file-tree-to-store'.
>   gexp: Remove unnecessary 'mlet'.
>   gexp: 'imported-files' no longer creates a derivation by default.
>   gexp: 'imported-files/derivation' can copy files instead of
>     symlinking.
>   self: Use the new 'imported-files'.

I went ahead and merged this.

There’s a couple of XXX/TODOs that we’ll address in ‘core-updates’ next.

Ludo’.