diff options
| -rw-r--r-- | guix/serialization.scm | 78 | ||||
| -rw-r--r-- | tests/nar.scm | 42 |
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 |