mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
serialization: Add #:select? parameter to 'write-file'.
* guix/serialization.scm (write-file): Add #:select? parameter and honor it.
* tests/nar.scm ("write-file #:select? + restore-file"): New test.
This commit is contained in:
Ludovic Courtès
parent
31d968fbcf
commit
fe585be9aa
2 changed files with 82 additions and 38 deletions
|
|
@ -256,53 +256,57 @@ (define %archive-version-1
|
|||
;; Magic cookie for Nix archives.
|
||||
"nix-archive-1")
|
||||
|
||||
(define (write-file file port)
|
||||
(define* (write-file file port
|
||||
#:key (select? (const #t)))
|
||||
"Write the contents of FILE to PORT in Nar format, recursing into
|
||||
sub-directories of FILE as needed."
|
||||
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."
|
||||
(define p port)
|
||||
|
||||
(write-string %archive-version-1 p)
|
||||
|
||||
(let dump ((f file))
|
||||
(let ((s (lstat f)))
|
||||
(write-string "(" p)
|
||||
(case (stat:type s)
|
||||
((regular)
|
||||
(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)))
|
||||
((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<?)))
|
||||
(for-each (lambda (e)
|
||||
(let ((f (string-append f "/" e)))
|
||||
(let dump ((f file) (s (lstat file)))
|
||||
(write-string "(" p)
|
||||
(case (stat:type s)
|
||||
((regular)
|
||||
(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)))
|
||||
((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<?)))
|
||||
(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)
|
||||
(write-string ")" p)))
|
||||
entries)))
|
||||
((symlink)
|
||||
(write-string "type" p)
|
||||
(write-string "symlink" p)
|
||||
(write-string "target" p)
|
||||
(write-string (readlink f) p))
|
||||
(else
|
||||
(raise (condition (&message (message "unsupported file type"))
|
||||
(&nar-error (file f) (port port))))))
|
||||
(write-string ")" p))))
|
||||
(dump f s)
|
||||
(write-string ")" p))))
|
||||
entries)))
|
||||
((symlink)
|
||||
(write-string "type" p)
|
||||
(write-string "symlink" p)
|
||||
(write-string "target" p)
|
||||
(write-string (readlink f) p))
|
||||
(else
|
||||
(raise (condition (&message (message "unsupported file type"))
|
||||
(&nar-error (file f) (port port))))))
|
||||
(write-string ")" p)))
|
||||
|
||||
(define (restore-file port file)
|
||||
"Read a file (possibly a directory structure) in Nar format from PORT.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -241,6 +241,46 @@ (define (touch file)
|
|||
(lambda ()
|
||||
(rmdir input)))))
|
||||
|
||||
(test-assert "write-file #:select? + restore-file"
|
||||
(let ((input (string-append %test-dir ".input")))
|
||||
(mkdir input)
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(with-file-tree input
|
||||
(directory "root"
|
||||
((directory "a" (("x") ("y") ("z")))
|
||||
("b") ("c") ("d" -> "b")))
|
||||
(let* ((output %test-dir)
|
||||
(nar (string-append output ".nar")))
|
||||
(dynamic-wind
|
||||
(lambda () #t)
|
||||
(lambda ()
|
||||
(call-with-output-file nar
|
||||
(lambda (port)
|
||||
(write-file input port
|
||||
#:select?
|
||||
(lambda (file stat)
|
||||
(and (not (string=? (basename file)
|
||||
"a"))
|
||||
(not (eq? (stat:type stat)
|
||||
'symlink)))))))
|
||||
(call-with-input-file nar
|
||||
(cut restore-file <> output))
|
||||
|
||||
;; Make sure "a" and "d" have been filtered out.
|
||||
(and (not (file-exists? (string-append output "/root/a")))
|
||||
(file=? (string-append output "/root/b")
|
||||
(string-append input "/root/b"))
|
||||
(file=? (string-append output "/root/c")
|
||||
(string-append input "/root/c"))
|
||||
(not (file-exists? (string-append output "/root/d")))))
|
||||
(lambda ()
|
||||
(false-if-exception (delete-file nar))
|
||||
(false-if-exception (rm-rf output)))))))
|
||||
(lambda ()
|
||||
(rmdir input)))))
|
||||
|
||||
;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
|
||||
;; relies on a Guile 2.0.10+ feature.
|
||||
(test-skip (if (false-if-exception
|
||||
|
|
|
|||
Loading…
Reference in a new issue