aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-07-14 19:28:07 +0200
committerLudovic Courtès <ludo@gnu.org>2018-07-19 11:48:04 +0200
commitb94b698d4ed4bc478c56e507d53e5284d4f63073 (patch)
treeb79dc5dfca6542d9a66185f6b898e4c1f4745acb
parentec83abad858a68561959a82aa0daa41c66da31d3 (diff)
downloadguix-b94b698d4ed4bc478c56e507d53e5284d4f63073.tar
guix-b94b698d4ed4bc478c56e507d53e5284d4f63073.tar.gz
serialization: Add 'write-file-tree'.
* 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.
-rw-r--r--guix/serialization.scm140
-rw-r--r--tests/nar.scm62
2 files changed, 169 insertions, 33 deletions
diff --git a/guix/serialization.scm b/guix/serialization.scm
index b41a0a09d1..129374f541 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 61646db964..9b5fb984b4 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 @@
(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"))