02/09: serialization: Add 'fold-archive'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 12c1afcdbdc984c760d00932bce64288b385bbc9
Author: Ludovic Courtès <address@hidden>
Date:   Wed Dec 4 22:05:31 2019 +0100

    serialization: Add 'fold-archive'.
    
    * guix/serialization.scm (read-contents): Remove.
    (read-file-type, fold-archive): New procedures.
    (restore-file): Rewrite in terms of 'fold-archive'.
    * tests/nar.scm ("write-file-tree + fold-archive")
    ("write-file-tree + fold-archive, flat file"): New tests.
---
 guix/serialization.scm | 134 +++++++++++++++++++++++++++++--------------------
 tests/nar.scm          |  74 +++++++++++++++++++++++++++
 2 files changed, 153 insertions(+), 55 deletions(-)

diff --git a/guix/serialization.scm b/guix/serialization.scm
index e14b7d1..cf263d3 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -48,6 +48,7 @@
 
             write-file
             write-file-tree
+            fold-archive
             restore-file))
 
 ;;; Comment:
@@ -226,38 +227,25 @@ substitute invalid byte sequences with question marks.  
This is a
       (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
-the size in bytes."
-  (define executable?
-    (match (read-string in)
-      ("contents"
-       #f)
-      ("executable"
-       (match (list (read-string in) (read-string in))
-         (("" "contents") #t)
-         (x (raise
-             (condition (&message
-                         (message "unexpected executable file marker"))
-                        (&nar-read-error (port in)
-                                         (file #f)
-                                         (token x))))))
-       #t)
-      (x
-       (raise
-        (condition (&message (message "unsupported nar file type"))
-                   (&nar-read-error (port in) (file #f) (token x)))))))
-
-  (let ((size (read-long-long in)))
-    ;; Note: `sendfile' cannot be used here because of port buffering on IN.
-    (dump in out size)
-
-    (when executable?
-      (chmod out #o755))
-    (let ((m (modulo size 8)))
-      (unless (zero? m)
-        (get-bytevector-n* in (- 8 m))))
-    size))
+(define (read-file-type port)
+  "Read the file type tag from PORT, and return either 'regular or
+'executable."
+  (match (read-string port)
+    ("contents"
+     'regular)
+    ("executable"
+     (match (list (read-string port) (read-string port))
+       (("" "contents") 'executable)
+       (x (raise
+           (condition (&message
+                       (message "unexpected executable file marker"))
+                      (&nar-read-error (port port)
+                                       (file #f)
+                                       (token x)))))))
+    (x
+     (raise
+      (condition (&message (message "unsupported nar file type"))
+                 (&nar-read-error (port port) (file #f) (token x)))))))
 
 (define %archive-version-1
   ;; Magic cookie for Nix archives.
@@ -383,9 +371,14 @@ which case you can use 'identity'."
 (define port-conversion-strategy
   (fluid->parameter %default-port-conversion-strategy))
 
-(define (restore-file port file)
-  "Read a file (possibly a directory structure) in Nar format from PORT.
-Restore it as FILE."
+(define (fold-archive proc seed port file)
+  "Read a file (possibly a directory structure) in Nar format from PORT.  Call
+PROC on each file or directory read from PORT using:
+
+  (PROC FILE TYPE CONTENTS RESULT)
+
+using SEED as the first RESULT.  TYPE is a symbol like 'regular, and CONTENTS
+depends on TYPE."
   (parameterize ((currently-restored-file file)
 
                  ;; Error out if we can convert file names to the current
@@ -401,7 +394,8 @@ Restore it as FILE."
                                      (token signature)
                                      (file #f))))))
 
-    (let restore ((file file))
+    (let read ((file file)
+               (result seed))
       (define (read-eof-marker)
         (match (read-string port)
           (")" #t)
@@ -414,40 +408,49 @@ Restore it as FILE."
 
       (match (list (read-string port) (read-string port) (read-string port))
         (("(" "type" "regular")
-         (call-with-output-file file (cut read-contents port <>))
-         (read-eof-marker))
+         (let* ((type   (read-file-type port))
+                (size   (read-long-long port))
+
+                ;; The caller must read exactly SIZE bytes from PORT.
+                (result (proc file type `(,port . ,size) result)))
+           (let ((m (modulo size 8)))
+             (unless (zero? m)
+               (get-bytevector-n* port (- 8 m))))
+           (read-eof-marker)
+           result))
         (("(" "type" "symlink")
          (match (list (read-string port) (read-string port))
            (("target" target)
-            (symlink target file)
-            (read-eof-marker))
+            (let ((result (proc file 'symlink target result)))
+              (read-eof-marker)
+              result))
            (x (raise
                (condition
                 (&message (message "invalid symlink tokens"))
                 (&nar-read-error (port port) (file file) (token x)))))))
         (("(" "type" "directory")
          (let ((dir file))
-           (mkdir dir)
-           (let loop ((prefix (read-string port)))
+           (let loop ((prefix (read-string port))
+                      (result (proc file 'directory #f result)))
              (match prefix
                ("entry"
                 (match (list (read-string port)
                              (read-string port) (read-string port)
                              (read-string port))
                   (("(" "name" file "node")
-                   (restore (string-append dir "/" file))
-                   (match (read-string port)
-                     (")" #t)
-                     (x
-                      (raise
-                       (condition
-                        (&message
-                         (message "unexpected directory entry termination"))
-                        (&nar-read-error (port port)
-                                         (file file)
-                                         (token x))))))
-                   (loop (read-string port)))))
-               (")" #t)                            ; done with DIR
+                   (let ((result (read (string-append dir "/" file) result)))
+                     (match (read-string port)
+                       (")" #f)
+                       (x
+                        (raise
+                         (condition
+                          (&message
+                           (message "unexpected directory entry termination"))
+                          (&nar-read-error (port port)
+                                           (file file)
+                                           (token x))))))
+                     (loop (read-string port) result)))))
+               (")" result)                       ;done with DIR
                (x
                 (raise
                  (condition
@@ -459,6 +462,27 @@ Restore it as FILE."
            (&message (message "unsupported nar entry type"))
            (&nar-read-error (port port) (file file) (token x)))))))))
 
+(define (restore-file port file)
+  "Read a file (possibly a directory structure) in Nar format from PORT.
+Restore it as FILE."
+  (fold-archive (lambda (file type content result)
+                  (match type
+                    ('directory
+                     (mkdir file))
+                    ('symlink
+                     (symlink content file))
+                    ((or 'regular 'executable)
+                     (match content
+                       ((input . size)
+                        (call-with-output-file file
+                          (lambda (output)
+                            (dump input output size)
+                            (when (eq? type 'executable)
+                              (chmod output #o755)))))))))
+                #t
+                port
+                file))
+
 ;;; Local Variables:
 ;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
 ;;; End:
diff --git a/tests/nar.scm b/tests/nar.scm
index bfc71c6..aeff3d3 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -214,6 +214,80 @@
       (lambda ()
         (false-if-exception (rm-rf %test-dir))))))
 
+(test-equal "write-file-tree + fold-archive"
+  '(("R" directory #f)
+    ("R/dir" directory #f)
+    ("R/dir/exe" executable "1234")
+    ("R/foo" regular "abcdefg")
+    ("R/lnk" symlink "foo"))
+
+  (let ()
+    (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 7))
+                       ("root/lnk"
+                        (values 'symlink 0))
+                       ("root/dir"
+                        (values 'directory 0))
+                       ("root/dir/exe"
+                        (values 'executable 4)))
+                     #:file-port
+                     (match-lambda
+                       ("root/foo" (open-input-string "abcdefg"))
+                       ("root/dir/exe" (open-input-string "1234")))
+                     #:symlink-target
+                     (match-lambda
+                       ("root/lnk" "foo"))
+                     #:directory-entries
+                     (match-lambda
+                       ("root" '("foo" "dir" "lnk"))
+                       ("root/dir" '("exe"))))
+    (close-port port)
+
+    (reverse
+     (fold-archive (lambda (file type contents result)
+                     (let ((contents (if (memq type '(regular executable))
+                                         (utf8->string
+                                          (get-bytevector-n (car contents)
+                                                            (cdr contents)))
+                                         contents)))
+                       (cons `(,file ,type ,contents)
+                             result)))
+                   '()
+                   (open-bytevector-input-port (get-bytevector))
+                   "R"))))
+
+(test-equal "write-file-tree + fold-archive, flat file"
+  '(("R" regular "abcdefg"))
+
+  (let ()
+    (define-values (port get-bytevector)
+      (open-bytevector-output-port))
+    (write-file-tree "root" port
+                     #:file-type+size
+                     (match-lambda
+                       ("root" (values 'regular 7)))
+                     #:file-port
+                     (match-lambda
+                       ("root" (open-input-string "abcdefg"))))
+    (close-port port)
+
+    (reverse
+     (fold-archive (lambda (file type contents result)
+                     (let ((contents (utf8->string
+                                      (get-bytevector-n (car contents)
+                                                        (cdr contents)))))
+                       (cons `(,file ,type ,contents) result)))
+                   '()
+                   (open-bytevector-input-port (get-bytevector))
+                   "R"))))
+
 (test-assert "write-file supports non-file output ports"
   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))