From b94b698d4ed4bc478c56e507d53e5284d4f63073 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 14 Jul 2018 19:28:07 +0200
Subject: [PATCH] serialization: Add 'write-file-tree'.

* guix/serialization.scm (write-contents-from-port): New procedure.
(write-contents): Write in terms of 'write-contents-from-port'.
(filter/sort-directory-entries, write-file-tree): New procedures.
(write-file): Rewrite in terms of 'write-file-tree'.
* tests/nar.scm ("write-file-tree + restore-file"): New test.
---
 guix/serialization.scm | 140 +++++++++++++++++++++++++++++++----------
 tests/nar.scm          |  62 +++++++++++++++++-
 2 files changed, 169 insertions(+), 33 deletions(-)

diff --git a/guix/serialization.scm b/guix/serialization.scm
index b41a0a09d1..129374f541 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -47,6 +47,7 @@
             nar-read-error-token
 
             write-file
+            write-file-tree
             restore-file))
 
 ;;; Comment:
@@ -211,14 +212,19 @@ substitute invalid byte sequences with question marks.  This is a
           (lambda ()
             (close-port port))))))
 
-  (write-string "contents" p)
-  (write-long-long size p)
   (call-with-binary-input-file file
-    ;; Use 'sendfile' when P is a file port.
-    (if (file-port? p)
-        (cut sendfile p <> size 0)
-        (cut dump <> p size)))
-  (write-padding size p))
+    (lambda (input)
+      (write-contents-from-port input p size))))
+
+(define (write-contents-from-port input output size)
+  "Write SIZE bytes from port INPUT to port OUTPUT."
+  (write-string "contents" output)
+  (write-long-long size output)
+  ;; Use 'sendfile' when both OUTPUT and INPUT are file ports.
+  (if (and (file-port? output) (file-port? input))
+      (sendfile output input size 0)
+      (dump input output size))
+  (write-padding size output))
 
 (define (read-contents in out)
   "Read the contents of a file from the Nar at IN, write it to OUT, and return
@@ -263,47 +269,113 @@ the size in bytes."
 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."
+  (write-file-tree file port
+                   #:file-type+size
+                   (lambda (file)
+                     (let* ((stat (lstat file))
+                            (size (stat:size stat)))
+                       (case (stat:type stat)
+                         ((directory)
+                          (values 'directory size))
+                         ((regular)
+                          (values (if (zero? (logand (stat:mode stat)
+                                                     #o100))
+                                      'regular
+                                      'executable)
+                                  size))
+                         (else
+                          (values (stat:type stat) size))))) ;bah!
+                   #:file-port (cut open-file <> "r0b")
+                   #:symlink-target readlink
+
+                   #:directory-entries
+                   (lambda (directory)
+                     ;; '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.
+                     (define basenames
+                       (scandir directory (negate (cut member <> '("." "..")))
+                                string<?))
+
+                     (filter-map (lambda (base)
+                                   (let ((file (string-append directory
+                                                              "/" base)))
+                                     (and (not (member base '("." "..")))
+                                          (select? file (lstat file))
+                                          base)))
+                                 basenames))
+
+                   ;; The 'scandir' call above gives us filtered and sorted
+                   ;; entries, so no post-processing is needed.
+                   #:postprocess-entries identity))
+
+(define (filter/sort-directory-entries lst)
+  "Remove dot and dot-dot entries from LST, and sort it in lexicographical
+order."
+  (delete-duplicates
+   (sort (remove (cute member <> '("." "..")) lst)
+         string<?)
+   string=?))
+
+(define* (write-file-tree file port
+                          #:key
+                          file-type+size
+                          file-port
+                          symlink-target
+                          directory-entries
+                          (postprocess-entries filter/sort-directory-entries))
+  "Write the contents of FILE to PORT in Nar format, recursing into
+sub-directories of FILE as needed.
+
+This procedure does not make any file-system I/O calls.  Instead, it calls the
+user-provided FILE-TYPE+SIZE, FILE-PORT, SYMLINK-TARGET, and DIRECTORY-ENTRIES
+procedures, which roughly correspond to 'lstat', 'readlink', and 'scandir'.
+POSTPROCESS-ENTRIES ensures that directory entries are valid; leave it as-is
+unless you know that DIRECTORY-ENTRIES provide filtered and sorted entries, in
+which case you can use 'identity'."
   (define p port)
 
   (write-string %archive-version-1 p)
 
-  (let dump ((f file) (s (lstat file)))
+  (let dump ((f file))
+    (define-values (type size)
+      (file-type+size f))
+
     (write-string "(" p)
-    (case (stat:type s)
-      ((regular)
+    (case type
+      ((regular executable)
        (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)))
+       (when (eq? 'executable type)
+         (write-string "executable" p)
+         (write-string "" p))
+       (let ((input (file-port f)))
+         (dynamic-wind
+           (const #t)
+           (lambda ()
+             (write-contents-from-port input p size))
+           (lambda ()
+             (close-port input)))))
       ((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<?)))
+       (let ((entries (postprocess-entries (directory-entries f))))
          (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 s)
-                         (write-string ")" p))))
+                     (let* ((f (string-append f "/" e)))
+                       (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))
+       (write-string (symlink-target f) p))
       (else
        (raise (condition (&message (message "unsupported file type"))
                          (&nar-error (file f) (port port))))))
@@ -379,4 +451,8 @@ Restore it as FILE."
            (&message (message "unsupported nar entry type"))
            (&nar-read-error (port port) (file file) (token x)))))))))
 
+;;; Local Variables:
+;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
+;;; End:
+
 ;;; serialization.scm ends here
diff --git a/tests/nar.scm b/tests/nar.scm
index 61646db964..9b5fb984b4 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, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -152,6 +152,66 @@
 
 (test-begin "nar")
 
+(test-assert "write-file-tree + restore-file"
+  (let* ((file1  (search-path %load-path "guix.scm"))
+         (file2  (search-path %load-path "guix/base32.scm"))
+         (file3  "#!/bin/something")
+         (output (string-append %test-dir "/output")))
+    (dynamic-wind
+      (lambda () #t)
+      (lambda ()
+        (define-values (port get-bytevector)
+          (open-bytevector-output-port))
+        (write-file-tree "root" port
+                         #:file-type+size
+                         (match-lambda
+                           ("root"
+                            (values 'directory 0))
+                           ("root/foo"
+                            (values 'regular (stat:size (stat file1))))
+                           ("root/lnk"
+                            (values 'symlink 0))
+                           ("root/dir"
+                            (values 'directory 0))
+                           ("root/dir/bar"
+                            (values 'regular (stat:size (stat file2))))
+                           ("root/dir/exe"
+                            (values 'executable (string-length file3))))
+                         #:file-port
+                         (match-lambda
+                           ("root/foo" (open-input-file file1))
+                           ("root/dir/bar" (open-input-file file2))
+                           ("root/dir/exe" (open-input-string file3)))
+                         #:symlink-target
+                         (match-lambda
+                           ("root/lnk" "foo"))
+                         #:directory-entries
+                         (match-lambda
+                           ("root" '("foo" "dir" "lnk"))
+                           ("root/dir" '("bar" "exe"))))
+        (close-port port)
+
+        (rm-rf %test-dir)
+        (mkdir %test-dir)
+        (restore-file (open-bytevector-input-port (get-bytevector))
+                      output)
+        (and (file=? (string-append output "/foo") file1)
+             (string=? (readlink (string-append output "/lnk"))
+                       "foo")
+             (file=? (string-append output "/dir/bar") file2)
+             (string=? (call-with-input-file (string-append output "/dir/exe")
+                         get-string-all)
+                       file3)
+             (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
+                        #o100)
+                0)
+             (equal? '("." ".." "bar" "exe")
+                     (scandir (string-append output "/dir")))
+             (equal? '("." ".." "dir" "foo" "lnk")
+                     (scandir output))))
+      (lambda ()
+        (false-if-exception (rm-rf %test-dir))))))
+
 (test-assert "write-file supports non-file output ports"
   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))