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.

guix/serialization.scm

@@ -256,15 +256,17 @@ 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 dump ((f file) (s (lstat file)))
-    (let ((s (lstat f)))
     (write-string "(" p)
     (case (stat:type s)
       ((regular)
@@ -285,14 +287,16 @@ sub-directories of FILE as needed."
               ;; sorted in a case-sensitive fashion.
               (scandir f (negate (cut member <> '("." ".."))) string<?)))
          (for-each (lambda (e)
-                       (let ((f (string-append f "/" 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)
+                         (dump f s)
-                         (write-string ")" p)))
+                         (write-string ")" p))))
                    entries)))
       ((symlink)
        (write-string "type" p)
@@ -302,7 +306,7 @@ sub-directories of FILE as needed."
       (else
        (raise (condition (&message (message "unsupported file type"))
                          (&nar-error (file f) (port port))))))
-      (write-string ")" p))))
+    (write-string ")" p)))
 
 (define (restore-file port file)
   "Read a file (possibly a directory structure) in Nar format from PORT.

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