* [bug#32174] [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities
@ 2018-07-16 13:30 Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
2018-07-19 9:57 ` bug#32174: [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities Ludovic Courtès
0 siblings, 2 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-16 13:30 UTC (permalink / raw)
To: 32174
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
^ permalink raw reply [flat|nested] 8+ messages in thread
* [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree'.
2018-07-16 13:30 [bug#32174] [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities Ludovic Courtès
@ 2018-07-16 13:33 ` Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 2/6] store: Add 'add-file-tree-to-store' Ludovic Courtès
` (4 more replies)
2018-07-19 9:57 ` bug#32174: [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities Ludovic Courtès
1 sibling, 5 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-16 13:33 UTC (permalink / raw)
To: 32174
* 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
^ permalink raw reply related [flat|nested] 8+ messages in thread
* [bug#32174] [PATCH 2/6] store: Add 'add-file-tree-to-store'.
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
@ 2018-07-16 13:33 ` Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 3/6] gexp: Remove unnecessary 'mlet' Ludovic Courtès
` (3 subsequent siblings)
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-16 13:33 UTC (permalink / raw)
To: 32174
* 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
^ permalink raw reply related [flat|nested] 8+ messages in thread
* [bug#32174] [PATCH 3/6] gexp: Remove unnecessary 'mlet'.
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 2/6] store: Add 'add-file-tree-to-store' Ludovic Courtès
@ 2018-07-16 13:33 ` Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 4/6] gexp: 'imported-files' no longer creates a derivation by default Ludovic Courtès
` (2 subsequent siblings)
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-16 13:33 UTC (permalink / raw)
To: 32174
* 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
^ permalink raw reply related [flat|nested] 8+ messages in thread
* [bug#32174] [PATCH 4/6] gexp: 'imported-files' no longer creates a derivation by default.
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 2/6] store: Add 'add-file-tree-to-store' Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 3/6] gexp: Remove unnecessary 'mlet' Ludovic Courtès
@ 2018-07-16 13:33 ` Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 5/6] gexp: 'imported-files/derivation' can copy files instead of symlinking Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 6/6] self: Use the new 'imported-files' Ludovic Courtès
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-16 13:33 UTC (permalink / raw)
To: 32174
* 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
^ permalink raw reply related [flat|nested] 8+ messages in thread
* [bug#32174] [PATCH 5/6] gexp: 'imported-files/derivation' can copy files instead of symlinking.
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
` (2 preceding siblings ...)
2018-07-16 13:33 ` [bug#32174] [PATCH 4/6] gexp: 'imported-files' no longer creates a derivation by default Ludovic Courtès
@ 2018-07-16 13:33 ` Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 6/6] self: Use the new 'imported-files' Ludovic Courtès
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-16 13:33 UTC (permalink / raw)
To: 32174
* 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
^ permalink raw reply related [flat|nested] 8+ messages in thread
* [bug#32174] [PATCH 6/6] self: Use the new 'imported-files'.
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
` (3 preceding siblings ...)
2018-07-16 13:33 ` [bug#32174] [PATCH 5/6] gexp: 'imported-files/derivation' can copy files instead of symlinking Ludovic Courtès
@ 2018-07-16 13:33 ` Ludovic Courtès
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-16 13:33 UTC (permalink / raw)
To: 32174
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
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#32174: [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities
2018-07-16 13:30 [bug#32174] [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
@ 2018-07-19 9:57 ` Ludovic Courtès
1 sibling, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2018-07-19 9:57 UTC (permalink / raw)
To: 32174-done
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’.
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2018-07-19 9:58 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2018-07-16 13:30 [bug#32174] [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 1/6] serialization: Add 'write-file-tree' Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 2/6] store: Add 'add-file-tree-to-store' Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 3/6] gexp: Remove unnecessary 'mlet' Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 4/6] gexp: 'imported-files' no longer creates a derivation by default Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 5/6] gexp: 'imported-files/derivation' can copy files instead of symlinking Ludovic Courtès
2018-07-16 13:33 ` [bug#32174] [PATCH 6/6] self: Use the new 'imported-files' Ludovic Courtès
2018-07-19 9:57 ` bug#32174: [PATCH 0/6] Add 'add-file-tree-to-store' and related facilities Ludovic Courtès
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.