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.
This commit is contained in:
Ludovic Courtès 2018-07-14 19:28:07 +02:00
parent ec83abad85
commit b94b698d4e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 169 additions and 33 deletions

View file

@ -47,6 +47,7 @@ (define-module (guix serialization)
nar-read-error-token nar-read-error-token
write-file write-file
write-file-tree
restore-file)) restore-file))
;;; Comment: ;;; Comment:
@ -211,14 +212,19 @@ (define (call-with-binary-input-file file proc)
(lambda () (lambda ()
(close-port port)))))) (close-port port))))))
(write-string "contents" p)
(write-long-long size p)
(call-with-binary-input-file file (call-with-binary-input-file file
;; Use 'sendfile' when P is a file port. (lambda (input)
(if (file-port? p) (write-contents-from-port input p size))))
(cut sendfile p <> size 0)
(cut dump <> p size))) (define (write-contents-from-port input output size)
(write-padding size p)) "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) (define (read-contents in out)
"Read the contents of a file from the Nar at IN, write it to OUT, and return "Read the contents of a file from the Nar at IN, write it to OUT, and return
@ -263,47 +269,113 @@ (define* (write-file file port
sub-directories of FILE as needed. For each directory entry, call (SELECT? 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 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." 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) (define p port)
(write-string %archive-version-1 p) (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) (write-string "(" p)
(case (stat:type s) (case type
((regular) ((regular executable)
(write-string "type" p) (write-string "type" p)
(write-string "regular" p) (write-string "regular" p)
(if (not (zero? (logand (stat:mode s) #o100))) (when (eq? 'executable type)
(begin (write-string "executable" p)
(write-string "executable" p) (write-string "" p))
(write-string "" p))) (let ((input (file-port f)))
(write-contents f p (stat:size s))) (dynamic-wind
(const #t)
(lambda ()
(write-contents-from-port input p size))
(lambda ()
(close-port input)))))
((directory) ((directory)
(write-string "type" p) (write-string "type" p)
(write-string "directory" p) (write-string "directory" p)
(let ((entries (let ((entries (postprocess-entries (directory-entries f))))
;; '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<?)))
(for-each (lambda (e) (for-each (lambda (e)
(let* ((f (string-append f "/" e)) (let* ((f (string-append f "/" e)))
(s (lstat f))) (write-string "entry" p)
(when (select? f s) (write-string "(" p)
(write-string "entry" p) (write-string "name" p)
(write-string "(" p) (write-string e p)
(write-string "name" p) (write-string "node" p)
(write-string e p) (dump f)
(write-string "node" p) (write-string ")" p)))
(dump f s)
(write-string ")" p))))
entries))) entries)))
((symlink) ((symlink)
(write-string "type" p) (write-string "type" p)
(write-string "symlink" p) (write-string "symlink" p)
(write-string "target" p) (write-string "target" p)
(write-string (readlink f) p)) (write-string (symlink-target f) p))
(else (else
(raise (condition (&message (message "unsupported file type")) (raise (condition (&message (message "unsupported file type"))
(&nar-error (file f) (port port)))))) (&nar-error (file f) (port port))))))
@ -379,4 +451,8 @@ (define (read-eof-marker)
(&message (message "unsupported nar entry type")) (&message (message "unsupported nar entry type"))
(&nar-read-error (port port) (file file) (token x))))))))) (&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 ;;; serialization.scm ends here

View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -152,6 +152,66 @@ (define %test-dir
(test-begin "nar") (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" (test-assert "write-file supports non-file output ports"
(let ((input (string-append (dirname (search-path %load-path "guix.scm")) (let ((input (string-append (dirname (search-path %load-path "guix.scm"))
"/guix")) "/guix"))