ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 13:28:12 -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

98
guix/serialization.scm
View file

@ -48,6 +48,7 @@ (define-module (guix serialization)
write-file
write-file-tree
fold-archive
restore-file))
;;; Comment:
@ -226,38 +227,25 @@ (define (write-contents-from-port input output size)
(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)
(define (read-file-type port)
"Read the file type tag from PORT, and return either 'regular or
'executable."
(match (read-string port)
("contents"
#f)
'regular)
("executable"
(match (list (read-string in) (read-string in))
(("" "contents") #t)
(match (list (read-string port) (read-string port))
(("" "contents") 'executable)
(x (raise
(condition (&message
(message "unexpected executable file marker"))
(&nar-read-error (port in)
(&nar-read-error (port port)
(file #f)
(token x))))))
#t)
(token x)))))))
(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))
(&nar-read-error (port port) (file #f) (token x)))))))
(define %archive-version-1
;; Magic cookie for Nix archives.
@ -383,9 +371,14 @@ (define-values (type size)
(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 @@ (define (restore-file port 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,30 +408,39 @@ (define (read-eof-marker)
(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))
(let ((result (read (string-append dir "/" file) result)))
(match (read-string port)
(")" #t)
(")" #f)
(x
(raise
(condition
@ -446,8 +449,8 @@ (define (read-eof-marker)
(&nar-read-error (port port)
(file file)
(token x))))))
(loop (read-string port)))))
(")" #t) ; done with DIR
(loop (read-string port) result)))))
(")" result) ;done with DIR
(x
(raise
(condition
@ -459,6 +462,27 @@ (define (read-eof-marker)
(&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:

74
tests/nar.scm
View file

@ -214,6 +214,80 @@ (define-values (port get-bytevector)
(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"))