nar: Implement restoration from Nar.

* guix/nar.scm (&nar-error, &nar-read-error): New condition types.
  (dump): New procedure.
  (write-contents)[dump]: Remove.  Use the one above instead.
  (read-contents, write-file, restore-file): New procedures.
  (%archive-version-1): New variable.

Makefile.am

@@ -296,6 +296,7 @@ TESTS =						\
   tests/packages.scm				\
   tests/snix.scm				\
   tests/store.scm				\
+  tests/nar.scm					\
   tests/union.scm				\
   tests/guix-build.sh				\
   tests/guix-download.sh			\

guix/nar.scm

@@ -19,12 +19,23 @@
 (define-module (guix nar)
   #:use-module (guix utils)
   #:use-module (guix serialization)
+  #:use-module ((guix build utils) #:select (with-directory-excursion))
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 ftw)
-  #:export (write-file))
+  #:use-module (ice-9 match)
+  #:export (nar-error?
+            nar-read-error?
+            nar-read-error-file
+            nar-read-error-port
+            nar-read-error-token
+
+            write-file
+            restore-file))
 
 ;;; Comment:
 ;;;
@@ -32,6 +43,31 @@
 ;;;
 ;;; Code:
 
+(define-condition-type &nar-error &error      ; XXX: inherit from &nix-error ?
+  nar-error?)
+
+(define-condition-type &nar-read-error &nar-error
+  nar-read-error?
+  (port  nar-read-error-port)                   ; port from which we read
+  (file  nar-read-error-file)                   ; file we were restoring, or #f
+  (token nar-read-error-token))                 ; faulty token, or #f
+
+
+(define (dump in out size)
+  "Copy SIZE bytes from IN to OUT."
+  (define buf-size 65536)
+  (define buf (make-bytevector buf-size))
+
+  (let loop ((left size))
+    (if (<= left 0)
+        0
+        (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
+          (if (eof-object? read)
+              left
+              (begin
+                (put-bytevector out buf 0 read)
+                (loop (- left read))))))))
+
 (define (write-contents file p size)
   "Write SIZE bytes from FILE to output port P."
   (define (call-with-binary-input-file file proc)
@@ -45,33 +81,55 @@
             (close-port port)
             (apply throw args))))))
 
-  (define (dump in size)
-    (define buf-size 65536)
-    (define buf (make-bytevector buf-size))
-
-    (let loop ((left size))
-      (if (<= left 0)
-          0
-          (let ((read (get-bytevector-n! in buf 0 buf-size)))
-            (if (eof-object? read)
-                left
-                (begin
-                  (put-bytevector p buf 0 read)
-                  (loop (- left read))))))))
-
   (write-string "contents" p)
   (write-long-long size p)
   (call-with-binary-input-file file
     ;; Use `sendfile' when available (Guile 2.0.8+).
     (if (compile-time-value (defined? 'sendfile))
         (cut sendfile p <> size 0)
-        (cut dump <> size)))
+        (cut dump <> p size)))
   (write-padding size p))
 
+(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 %archive-version-1
+  ;; Magic cookie for Nix archives.
+  "nix-archive-1")
+
 (define (write-file file port)
   "Write the contents of FILE to PORT in Nar format, recursing into
 sub-directories of FILE as needed."
-  (define %archive-version-1 "nix-archive-1")
   (define p port)
 
   (write-string %archive-version-1 p)
@@ -104,7 +162,63 @@ sub-directories of FILE as needed."
                          (write-string ")" p)))
                      entries)))
         (else
-         (error "ENOSYS")))
+         (raise (condition (&message (message "ENOSYS"))
+                           (&nar-error)))))
       (write-string ")" p))))
 
+(define (restore-file port file)
+  "Read a file (possibly a directory structure) in Nar format from PORT.
+Restore it as FILE."
+  (let ((signature (read-string port)))
+    (unless (equal? signature %archive-version-1)
+      (raise
+       (condition (&message (message "invalid nar signature"))
+                  (&nar-read-error (port port)
+                                   (token signature)
+                                   (file #f))))))
+
+  (let restore ((file file))
+    (match (list (read-string port) (read-string port) (read-string port))
+      (("(" "type" "regular")
+       (call-with-output-file file (cut read-contents port <>))
+       (match (read-string port)
+         (")" #t)
+         (x (raise
+             (condition
+              (&message (message "invalid nar end-of-file marker"))
+              (&nar-read-error (port port) (file file) (token x)))))))
+      (("(" "type" "directory")
+       (let ((dir file))
+         (mkdir dir)
+         (let loop ((prefix (read-string port)))
+           (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
+             (x
+              (raise
+               (condition
+                (&message (message "unexpected directory inter-entry marker"))
+                (&nar-read-error (port port) (file file) (token x)))))))))
+      (x
+       (raise
+        (condition
+         (&message (message "unsupported nar entry type"))
+         (&nar-read-error (port port) (file file) (token x))))))))
+
 ;;; nar.scm ends here

tests/nar.scm

@@ -0,0 +1,95 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-nar)
+  #:use-module (guix nar)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 ftw))
+
+;; Test the (guix nar) module.
+
+(define (rm-rf dir)
+  (file-system-fold (const #t)                    ; enter?
+                    (lambda (file stat result)    ; leaf
+                      (delete-file file))
+                    (const #t)                    ; down
+                    (lambda (dir stat result)     ; up
+                      (rmdir dir))
+                    (const #t)                    ; skip
+                    (const #t)                    ; error
+                    #t
+                    dir
+                    lstat))
+
+
+(test-begin "nar")
+
+(test-assert "write-file + restore-file"
+  (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
+                                "/guix"))
+         (output (string-append (dirname input)
+                                "/test-nar-"
+                                (number->string (getpid))))
+         (nar    (string-append output ".nar")))
+    (dynamic-wind
+      (lambda () #t)
+      (lambda ()
+        (call-with-output-file nar
+          (cut write-file input <>))
+        (call-with-input-file nar
+          (cut restore-file <> output))
+        (let* ((strip   (cute string-drop <> (string-length input)))
+               (sibling (compose (cut string-append output <>) strip))
+               (file=?  (lambda (a b)
+                          (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
+                               (case (stat:type (lstat a))
+                                 ((regular)
+                                  (equal?
+                                   (call-with-input-file a get-bytevector-all)
+                                   (call-with-input-file b get-bytevector-all)))
+                                 ((symlink)
+                                  (string=? (readlink a) (readlink b)))
+                                 (else
+                                  (error "what?" (lstat a))))))))
+          (file-system-fold (const #t)
+                            (lambda (name stat result) ; leaf
+                              (and result
+                                   (file=? name (sibling name))))
+                            (lambda (name stat result) ; down
+                              result)
+                            (lambda (name stat result) ; up
+                              result)
+                            (const #f)                 ; skip
+                            (lambda (name stat errno result)
+                              (pk 'error name stat errno)
+                              #f)
+                            (> (stat:nlink (stat output)) 2)
+                            input
+                            lstat)))
+      (lambda ()
+        (false-if-exception (delete-file nar))
+        (false-if-exception (rm-rf output))
+        ))))
+
+(test-end "nar")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))