ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

serialization: Add 'fold-archive'.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2019-12-04 22:05:31 +01:00
parent 55e21617d6
commit 12c1afcdbd
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 153 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

134
guix/serialization.scm
View file

@ -48,6 +48,7 @@ (define-module (guix serialization)
write-file write-file
write-file-tree write-file-tree
fold-archive
restore-file)) restore-file))
;;; Comment: ;;; Comment:
@ -226,38 +227,25 @@ (define (write-contents-from-port input output size)
(dump input output size)) (dump input output size))
(write-padding size output)) (write-padding size output))
(define (read-contents in out) (define (read-file-type port)
"Read the contents of a file from the Nar at IN, write it to OUT, and return "Read the file type tag from PORT, and return either 'regular or
the size in bytes." 'executable."
(define executable? (match (read-string port)
(match (read-string in) ("contents"
("contents" 'regular)
#f) ("executable"
("executable" (match (list (read-string port) (read-string port))
(match (list (read-string in) (read-string in)) (("" "contents") 'executable)
(("" "contents") #t) (x (raise
(x (raise (condition (&message
(condition (&message (message "unexpected executable file marker"))
(message "unexpected executable file marker")) (&nar-read-error (port port)
(&nar-read-error (port in) (file #f)
(file #f) (token x)))))))
(token x)))))) (x
#t) (raise
(x (condition (&message (message "unsupported nar file type"))
(raise (&nar-read-error (port port) (file #f) (token x)))))))
(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 %archive-version-1 (define %archive-version-1
;; Magic cookie for Nix archives. ;; Magic cookie for Nix archives.
@ -383,9 +371,14 @@ (define-values (type size)
(define port-conversion-strategy (define port-conversion-strategy
(fluid->parameter %default-port-conversion-strategy)) (fluid->parameter %default-port-conversion-strategy))
(define (restore-file port file) (define (fold-archive proc seed port file)
"Read a file (possibly a directory structure) in Nar format from PORT. "Read a file (possibly a directory structure) in Nar format from PORT. Call
Restore it as FILE." 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) (parameterize ((currently-restored-file file)
;; Error out if we can convert file names to the current ;; Error out if we can convert file names to the current
@ -401,7 +394,8 @@ (define (restore-file port file)
(token signature) (token signature)
(file #f)))))) (file #f))))))
(let restore ((file file)) (let read ((file file)
(result seed))
(define (read-eof-marker) (define (read-eof-marker)
(match (read-string port) (match (read-string port)
(")" #t) (")" #t)
@ -414,40 +408,49 @@ (define (read-eof-marker)
(match (list (read-string port) (read-string port) (read-string port)) (match (list (read-string port) (read-string port) (read-string port))
(("(" "type" "regular") (("(" "type" "regular")
(call-with-output-file file (cut read-contents port <>)) (let* ((type (read-file-type port))
(read-eof-marker)) (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") (("(" "type" "symlink")
(match (list (read-string port) (read-string port)) (match (list (read-string port) (read-string port))
(("target" target) (("target" target)
(symlink target file) (let ((result (proc file 'symlink target result)))
(read-eof-marker)) (read-eof-marker)
result))
(x (raise (x (raise
(condition (condition
(&message (message "invalid symlink tokens")) (&message (message "invalid symlink tokens"))
(&nar-read-error (port port) (file file) (token x))))))) (&nar-read-error (port port) (file file) (token x)))))))
(("(" "type" "directory") (("(" "type" "directory")
(let ((dir file)) (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 (match prefix
("entry" ("entry"
(match (list (read-string port) (match (list (read-string port)
(read-string port) (read-string port) (read-string port) (read-string port)
(read-string port)) (read-string port))
(("(" "name" file "node") (("(" "name" file "node")
(restore (string-append dir "/" file)) (let ((result (read (string-append dir "/" file) result)))
(match (read-string port) (match (read-string port)
(")" #t) (")" #f)
(x (x
(raise (raise
(condition (condition
(&message (&message
(message "unexpected directory entry termination")) (message "unexpected directory entry termination"))
(&nar-read-error (port port) (&nar-read-error (port port)
(file file) (file file)
(token x)))))) (token x))))))
(loop (read-string port))))) (loop (read-string port) result)))))
(")" #t) ; done with DIR (")" result) ;done with DIR
(x (x
(raise (raise
(condition (condition
@ -459,6 +462,27 @@ (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)))))))))
(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: ;;; Local Variables:
;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1) ;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
;;; End: ;;; End:

74
tests/nar.scm
View file

@ -214,6 +214,80 @@ (define-values (port get-bytevector)
(lambda () (lambda ()
(false-if-exception (rm-rf %test-dir)))))) (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" (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"))