serialization: Add 'fold-archive'.
* guix/serialization.scm (read-contents): Remove.
(read-file-type, fold-archive): New procedures.
(restore-file): Rewrite in terms of 'fold-archive'.
* tests/nar.scm ("write-file-tree + fold-archive")
("write-file-tree + fold-archive, flat file"): New tests.
master
Ludovic Courtès
parent
55e21617d6
commit
12c1afcdbd
|
|
@ -48,6 +48,7 @@
|
|||
|
||||
write-file
|
||||
write-file-tree
|
||||
fold-archive
|
||||
restore-file))
|
||||
|
||||
;;; Comment:
|
||||
|
|
@ -226,38 +227,25 @@ substitute invalid byte sequences with question marks. This is a
|
|||
(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
|
||||
the size in bytes."
|
||||
(define executable?
|
||||
(match (read-string in)
|
||||
("contents"
|
||||
#f)
|
||||
("executable"
|
||||
(match (list (read-string in) (read-string in))
|
||||
(("" "contents") #t)
|
||||
(x (raise
|
||||
(condition (&message
|
||||
(message "unexpected executable file marker"))
|
||||
(&nar-read-error (port in)
|
||||
(file #f)
|
||||
(token x))))))
|
||||
#t)
|
||||
(x
|
||||
(raise
|
||||
(condition (&message (message "unsupported nar file type"))
|
||||
(&nar-read-error (port in) (file #f) (token x)))))))
|
||||
|
||||
(let ((size (read-long-long in)))
|
||||
;; Note: `sendfile' cannot be used here because of port buffering on IN.
|
||||
(dump in out size)
|
||||
|
||||
(when executable?
|
||||
(chmod out #o755))
|
||||
(let ((m (modulo size 8)))
|
||||
(unless (zero? m)
|
||||
(get-bytevector-n* in (- 8 m))))
|
||||
size))
|
||||
(define (read-file-type port)
|
||||
"Read the file type tag from PORT, and return either 'regular or
|
||||
'executable."
|
||||
(match (read-string port)
|
||||
("contents"
|
||||
'regular)
|
||||
("executable"
|
||||
(match (list (read-string port) (read-string port))
|
||||
(("" "contents") 'executable)
|
||||
(x (raise
|
||||
(condition (&message
|
||||
(message "unexpected executable file marker"))
|
||||
(&nar-read-error (port port)
|
||||
(file #f)
|
||||
(token x)))))))
|
||||
(x
|
||||
(raise
|
||||
(condition (&message (message "unsupported nar file type"))
|
||||
(&nar-read-error (port port) (file #f) (token x)))))))
|
||||
|
||||
(define %archive-version-1
|
||||
;; Magic cookie for Nix archives.
|
||||
|
|
@ -383,9 +371,14 @@ which case you can use 'identity'."
|
|||
(define port-conversion-strategy
|
||||
(fluid->parameter %default-port-conversion-strategy))
|
||||
|
||||
(define (restore-file port file)
|
||||
"Read a file (possibly a directory structure) in Nar format from PORT.
|
||||
Restore it as FILE."
|
||||
(define (fold-archive proc seed port file)
|
||||
"Read a file (possibly a directory structure) in Nar format from PORT. Call
|
||||
PROC on each file or directory read from PORT using:
|
||||
|
||||
(PROC FILE TYPE CONTENTS RESULT)
|
||||
|
||||
using SEED as the first RESULT. TYPE is a symbol like 'regular, and CONTENTS
|
||||
depends on TYPE."
|
||||
(parameterize ((currently-restored-file file)
|
||||
|
||||
;; Error out if we can convert file names to the current
|
||||
|
|
@ -401,7 +394,8 @@ Restore it as FILE."
|
|||
(token signature)
|
||||
(file #f))))))
|
||||
|
||||
(let restore ((file file))
|
||||
(let read ((file file)
|
||||
(result seed))
|
||||
(define (read-eof-marker)
|
||||
(match (read-string port)
|
||||
(")" #t)
|
||||
|
|
@ -414,40 +408,49 @@ Restore it as FILE."
|
|||
|
||||
(match (list (read-string port) (read-string port) (read-string port))
|
||||
(("(" "type" "regular")
|
||||
(call-with-output-file file (cut read-contents port <>))
|
||||
(read-eof-marker))
|
||||
(let* ((type (read-file-type port))
|
||||
(size (read-long-long port))
|
||||
|
||||
;; The caller must read exactly SIZE bytes from PORT.
|
||||
(result (proc file type `(,port . ,size) result)))
|
||||
(let ((m (modulo size 8)))
|
||||
(unless (zero? m)
|
||||
(get-bytevector-n* port (- 8 m))))
|
||||
(read-eof-marker)
|
||||
result))
|
||||
(("(" "type" "symlink")
|
||||
(match (list (read-string port) (read-string port))
|
||||
(("target" target)
|
||||
(symlink target file)
|
||||
(read-eof-marker))
|
||||
(let ((result (proc file 'symlink target result)))
|
||||
(read-eof-marker)
|
||||
result))
|
||||
(x (raise
|
||||
(condition
|
||||
(&message (message "invalid symlink tokens"))
|
||||
(&nar-read-error (port port) (file file) (token x)))))))
|
||||
(("(" "type" "directory")
|
||||
(let ((dir file))
|
||||
(mkdir dir)
|
||||
(let loop ((prefix (read-string port)))
|
||||
(let loop ((prefix (read-string port))
|
||||
(result (proc file 'directory #f result)))
|
||||
(match prefix
|
||||
("entry"
|
||||
(match (list (read-string port)
|
||||
(read-string port) (read-string port)
|
||||
(read-string port))
|
||||
(("(" "name" file "node")
|
||||
(restore (string-append dir "/" file))
|
||||
(match (read-string port)
|
||||
(")" #t)
|
||||
(x
|
||||
(raise
|
||||
(condition
|
||||
(&message
|
||||
(message "unexpected directory entry termination"))
|
||||
(&nar-read-error (port port)
|
||||
(file file)
|
||||
(token x))))))
|
||||
(loop (read-string port)))))
|
||||
(")" #t) ; done with DIR
|
||||
(let ((result (read (string-append dir "/" file) result)))
|
||||
(match (read-string port)
|
||||
(")" #f)
|
||||
(x
|
||||
(raise
|
||||
(condition
|
||||
(&message
|
||||
(message "unexpected directory entry termination"))
|
||||
(&nar-read-error (port port)
|
||||
(file file)
|
||||
(token x))))))
|
||||
(loop (read-string port) result)))))
|
||||
(")" result) ;done with DIR
|
||||
(x
|
||||
(raise
|
||||
(condition
|
||||
|
|
@ -459,6 +462,27 @@ Restore it as FILE."
|
|||
(&message (message "unsupported nar entry type"))
|
||||
(&nar-read-error (port port) (file file) (token x)))))))))
|
||||
|
||||
(define (restore-file port file)
|
||||
"Read a file (possibly a directory structure) in Nar format from PORT.
|
||||
Restore it as FILE."
|
||||
(fold-archive (lambda (file type content result)
|
||||
(match type
|
||||
('directory
|
||||
(mkdir file))
|
||||
('symlink
|
||||
(symlink content file))
|
||||
((or 'regular 'executable)
|
||||
(match content
|
||||
((input . size)
|
||||
(call-with-output-file file
|
||||
(lambda (output)
|
||||
(dump input output size)
|
||||
(when (eq? type 'executable)
|
||||
(chmod output #o755)))))))))
|
||||
#t
|
||||
port
|
||||
file))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
|
|||
|
|
@ -214,6 +214,80 @@
|
|||
(lambda ()
|
||||
(false-if-exception (rm-rf %test-dir))))))
|
||||
|
||||
(test-equal "write-file-tree + fold-archive"
|
||||
'(("R" directory #f)
|
||||
("R/dir" directory #f)
|
||||
("R/dir/exe" executable "1234")
|
||||
("R/foo" regular "abcdefg")
|
||||
("R/lnk" symlink "foo"))
|
||||
|
||||
(let ()
|
||||
(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 7))
|
||||
("root/lnk"
|
||||
(values 'symlink 0))
|
||||
("root/dir"
|
||||
(values 'directory 0))
|
||||
("root/dir/exe"
|
||||
(values 'executable 4)))
|
||||
#:file-port
|
||||
(match-lambda
|
||||
("root/foo" (open-input-string "abcdefg"))
|
||||
("root/dir/exe" (open-input-string "1234")))
|
||||
#:symlink-target
|
||||
(match-lambda
|
||||
("root/lnk" "foo"))
|
||||
#:directory-entries
|
||||
(match-lambda
|
||||
("root" '("foo" "dir" "lnk"))
|
||||
("root/dir" '("exe"))))
|
||||
(close-port port)
|
||||
|
||||
(reverse
|
||||
(fold-archive (lambda (file type contents result)
|
||||
(let ((contents (if (memq type '(regular executable))
|
||||
(utf8->string
|
||||
(get-bytevector-n (car contents)
|
||||
(cdr contents)))
|
||||
contents)))
|
||||
(cons `(,file ,type ,contents)
|
||||
result)))
|
||||
'()
|
||||
(open-bytevector-input-port (get-bytevector))
|
||||
"R"))))
|
||||
|
||||
(test-equal "write-file-tree + fold-archive, flat file"
|
||||
'(("R" regular "abcdefg"))
|
||||
|
||||
(let ()
|
||||
(define-values (port get-bytevector)
|
||||
(open-bytevector-output-port))
|
||||
(write-file-tree "root" port
|
||||
#:file-type+size
|
||||
(match-lambda
|
||||
("root" (values 'regular 7)))
|
||||
#:file-port
|
||||
(match-lambda
|
||||
("root" (open-input-string "abcdefg"))))
|
||||
(close-port port)
|
||||
|
||||
(reverse
|
||||
(fold-archive (lambda (file type contents result)
|
||||
(let ((contents (utf8->string
|
||||
(get-bytevector-n (car contents)
|
||||
(cdr contents)))))
|
||||
(cons `(,file ,type ,contents) result)))
|
||||
'()
|
||||
(open-bytevector-input-port (get-bytevector))
|
||||
"R"))))
|
||||
|
||||
(test-assert "write-file supports non-file output ports"
|
||||
(let ((input (string-append (dirname (search-path %load-path "guix.scm"))
|
||||
"/guix"))
|
||||
|
|
|
|||
Reference in New Issue