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

serialization: Add 'write-file-tree'.

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

140
guix/serialization.scm
View file

@ -47,6 +47,7 @@ (define-module (guix serialization)
nar-read-error-token
write-file
write-file-tree
restore-file))
;;; Comment:
@ -211,14 +212,19 @@ (define (call-with-binary-input-file file proc)
(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 @@ (define* (write-file file port
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 @@ (define (read-eof-marker)
(&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

62
tests/nar.scm
View file

@ -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 @@ (define %test-dir
(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"))