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

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 32174 in the body.
You can then email your comments to 32174 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: guix-patches <at> gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities
Date: Mon, 16 Jul 2018 15:30:49 +0200

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

Message #8 received at 32174 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 32174 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 3/6] gexp: Remove unnecessary 'mlet'.
Date: Mon, 16 Jul 2018 15:33:24 +0200

* 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

Message #11 received at 32174 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 32174 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 2/6] store: Add 'add-file-tree-to-store'.
Date: Mon, 16 Jul 2018 15:33:23 +0200

* 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

Message #14 received at 32174 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 32174 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 1/6] serialization: Add 'write-file-tree'.
Date: Mon, 16 Jul 2018 15:33:22 +0200

* 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 <at> gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -152,6 +152,66 @@
 
 (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

Message #17 received at 32174 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 32174 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 5/6] gexp: 'imported-files/derivation' can copy files instead
 of symlinking.
Date: Mon, 16 Jul 2018 15:33:26 +0200

* 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

Message #20 received at 32174 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 32174 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 4/6] gexp: 'imported-files' no longer creates a derivation by
 default.
Date: Mon, 16 Jul 2018 15:33:25 +0200

* 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

Message #23 received at 32174 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 32174 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 6/6] self: Use the new 'imported-files'.
Date: Mon, 16 Jul 2018 15:33:27 +0200

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

Message #28 received at 32174-done <at> debbugs.gnu.org (full text, mbox):

From: ludo <at> gnu.org (Ludovic Courtès)
To: 32174-done <at> debbugs.gnu.org
Subject: Re: [bug#32174] [PATCH 0/6] Add 'add-file-tree-to-store' and related
 facilities
Date: Thu, 19 Jul 2018 11:57:11 +0200

Ludovic Courtès <ludo <at> 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’.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.