aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-06-12 23:22:54 +0200
committerLudovic Courtès <ludo@gnu.org>2016-06-12 23:55:22 +0200
commitfe585be9aa8f5158a7dfb6477d19ece3d643dec3 (patch)
tree855b01af0646dee9186ae539fd9f561e47777649
parent31d968fbcfa78b52c5280503417b67943f8a9660 (diff)
downloadguix-fe585be9aa8f5158a7dfb6477d19ece3d643dec3.tar
guix-fe585be9aa8f5158a7dfb6477d19ece3d643dec3.tar.gz
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.
-rw-r--r--guix/serialization.scm78
-rw-r--r--tests/nar.scm42
2 files changed, 82 insertions, 38 deletions
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 286b4cbf30..f17f516c09 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -256,53 +256,57 @@ the size in bytes."
;; 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.
diff --git a/tests/nar.scm b/tests/nar.scm
index 9796980e35..4f4b304b1d 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -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 @@
(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