summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-07-16 09:55:49 +0200
committerLudovic Courtès <ludo@gnu.org>2018-07-19 11:48:04 +0200
commit7f11efbac7a13898bd925d2ef1e9d26cb0e22ade (patch)
treeade6ad9bd46bc3a989b7bd35d7b04548b853ef9a
parentb94b698d4ed4bc478c56e507d53e5284d4f63073 (diff)
store: Add 'add-file-tree-to-store'.
* 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.
-rw-r--r--guix/store.scm100
-rw-r--r--tests/store.scm46
2 files changed, 146 insertions, 0 deletions
diff --git a/guix/store.scm b/guix/store.scm
index cc5c24a77d..f41a1e2690 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 afecec940a..47fab0df18 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)))