Break module cycle involving (guix store) and (guix ui).

Before, there was a cycle along the lines of:

  (guix store) -> (guix nar) -> (guix ui) -> (guix store)

This caused problems, as discussed at:

  http://lists.gnu.org/archive/html/guix-devel/2014-10/msg00109.html

This patch removes cycles in the (guix ...) modules.

* guix/nar.scm (&nar-error, &nar-read-error, dump, write-contents,
  read-contents, %archive-version-1, write-file, restore-file): Move to...
* guix/serialization.scm: ... here.
* guix/store.scm: Remove dependency on (guix nar).
* guix/scripts/hash.scm, guix/scripts/offload.scm,
  guix/scripts/substitute-binary.scm, tests/nar.scm, tests/store.scm,
  tests/substitute-binary.scm: Adjust accordingly.

1 files changed, 224 insertions, 1 deletions

diff --git a/guix/serialization.scm b/guix/serialization.scm
index 284b174794..64eacf974c 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -22,7 +22,10 @@
   #: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 match)
+  #:use-module (ice-9 ftw)
   #:export (write-int read-int
             write-long-long read-long-long
             write-padding
@@ -30,7 +33,19 @@
             write-string-list read-string-list
             write-string-pairs
             write-store-path read-store-path
-            write-store-path-list read-store-path-list))
+            write-store-path-list read-store-path-list
+
+            &nar-error
+            nar-error?
+            nar-error-port
+            nar-error-file
+
+            &nar-read-error
+            nar-read-error?
+            nar-read-error-token
+
+            write-file
+            restore-file))
 
 ;;; Comment:
 ;;;
@@ -121,4 +136,212 @@
 (define write-store-path-list write-string-list)
 (define read-store-path-list read-string-list)
 
+
+(define-condition-type &nar-error &error      ; XXX: inherit from &nix-error ?
+  nar-error?
+  (file  nar-error-file)                       ; file we were restoring, or #f
+  (port  nar-error-port))                      ; port from which we read
+
+(define-condition-type &nar-read-error &nar-error
+  nar-read-error?
+  (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)
+    ;; Open FILE as a binary file.  This avoids scan-for-encoding, and thus
+    ;; avoids any initial buffering.  Disable file name canonicalization to
+    ;; avoid stat'ing like crazy.
+    (with-fluids ((%file-port-name-canonicalization #f))
+      (let ((port (open-file file "rb")))
+        (dynamic-wind
+          (const #t)
+          (cut proc port)
+          (lambda ()
+            (close-port port))))))
+
+  (write-string "contents" p)
+  (write-long-long size p)
+  (call-with-binary-input-file file
+    ;; Use `sendfile' when available (Guile 2.0.8+).
+    (if (and (compile-time-value (defined? 'sendfile))
+             (file-port? p))
+        (cut sendfile p <> size 0)
+        (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 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
+                ;; NOTE: Guile 2.0.5's 'scandir' returns all subdirectories
+                ;; unconditionally, including "." and "..", regardless of the
+                ;; 'select?' predicate passed to it, so we have to filter
+                ;; those out externally.
+                (filter (negate (cut member <> '("." "..")))
+                        ;; '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 (const #t) string<?))))
+           (for-each (lambda (e)
+                       (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))
+        (else
+         (raise (condition (&message (message "unsupported file type"))
+                           (&nar-error (file f) (port port))))))
+      (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))
+    (define (read-eof-marker)
+      (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)))))))
+
+    (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))
+      (("(" "type" "symlink")
+       (match (list (read-string port) (read-string port))
+         (("target" target)
+          (symlink target file)
+          (read-eof-marker))
+         (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)))
+           (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))))))))
+
 ;;; serialization.scm ends here