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 @@ (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 '("." ".."))) string '("." ".."))) string +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; 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