From f0cd71f21e41d5a638b69ecee0fa3939f27a4502 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 4 Apr 2013 22:29:08 +0200
Subject: Add (guix nar) and (guix serialization).

* guix/store.scm (write-int, read-int, write-long-long, read-long-long,
  write-padding, write-string, read-string, read-latin1-string,
  write-string-list, read-string-list, write-store-path,
  read-store-path, write-store-path-list, read-store-path-list): Move to
  serialization.scm.
  (write-contents, write-file): Move to nar.scm.
* guix/nar.scm, guix/serialization.scm: New files.
* Makefile.am (MODULES): Add them.
---
 Makefile.am            |   2 +
 guix/nar.scm           | 110 ++++++++++++++++++++++++++++++++++++
 guix/serialization.scm | 114 +++++++++++++++++++++++++++++++++++++
 guix/store.scm         | 149 +------------------------------------------------
 4 files changed, 228 insertions(+), 147 deletions(-)
 create mode 100644 guix/nar.scm
 create mode 100644 guix/serialization.scm

diff --git a/Makefile.am b/Makefile.am
index 8b3057fd0b..e4afb74310 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,6 +34,8 @@ MODULES =					\
   guix/scripts/substitute-binary.scm		\
   guix/base32.scm				\
   guix/utils.scm				\
+  guix/serialization.scm			\
+  guix/nar.scm					\
   guix/derivations.scm				\
   guix/download.scm				\
   guix/gnu-maintenance.scm			\
diff --git a/guix/nar.scm b/guix/nar.scm
new file mode 100644
index 0000000000..b42f03c514
--- /dev/null
+++ b/guix/nar.scm
@@ -0,0 +1,110 @@
+;;; 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 (guix nar)
+  #:use-module (guix utils)
+  #:use-module (guix serialization)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 ftw)
+  #:export (write-file))
+
+;;; Comment:
+;;;
+;;; Read and write Nix archives, aka. ‘nar’.
+;;;
+;;; Code:
+
+(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")))
+        (catch #t (cut proc port)
+          (lambda args
+            (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)))
+  (write-padding size p))
+
+(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)
+
+  (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 (remove (cut member <> '("." ".."))
+                                (scandir f))))
+           (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)))
+        (else
+         (error "ENOSYS")))
+      (write-string ")" p))))
+
+;;; nar.scm ends here
diff --git a/guix/serialization.scm b/guix/serialization.scm
new file mode 100644
index 0000000000..474dc69de5
--- /dev/null
+++ b/guix/serialization.scm
@@ -0,0 +1,114 @@
+;;; 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 (guix serialization)
+  #:use-module (guix utils)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (write-int read-int
+            write-long-long read-long-long
+            write-padding
+            write-string read-string read-latin1-string
+            write-string-list read-string-list
+            write-store-path read-store-path
+            write-store-path-list read-store-path-list))
+
+;;; Comment:
+;;;
+;;; Serialization procedures used by the RPCs and the Nar format.  This module
+;;; is for internal consumption.
+;;;
+;;; Code:
+
+;; Similar to serialize.cc in Nix.
+
+(define (write-int n p)
+  (let ((b (make-bytevector 8 0)))
+    (bytevector-u32-set! b 0 n (endianness little))
+    (put-bytevector p b)))
+
+(define (read-int p)
+  (let ((b (get-bytevector-n p 8)))
+    (bytevector-u32-ref b 0 (endianness little))))
+
+(define (write-long-long n p)
+  (let ((b (make-bytevector 8 0)))
+    (bytevector-u64-set! b 0 n (endianness little))
+    (put-bytevector p b)))
+
+(define (read-long-long p)
+  (let ((b (get-bytevector-n p 8)))
+    (bytevector-u64-ref b 0 (endianness little))))
+
+(define write-padding
+  (let ((zero (make-bytevector 8 0)))
+    (lambda (n p)
+      (let ((m (modulo n 8)))
+        (or (zero? m)
+            (put-bytevector p zero 0 (- 8 m)))))))
+
+(define (write-string s p)
+  (let* ((s (string->utf8 s))
+         (l (bytevector-length s))
+         (m (modulo l 8))
+         (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
+    (bytevector-u32-set! b 0 l (endianness little))
+    (bytevector-copy! s 0 b 8 l)
+    (put-bytevector p b)))
+
+(define (read-string p)
+  (let* ((len (read-int p))
+         (m   (modulo len 8))
+         (bv  (get-bytevector-n p len))
+         (str (utf8->string bv)))
+    (or (zero? m)
+        (get-bytevector-n p (- 8 m)))
+    str))
+
+(define (read-latin1-string p)
+  (let* ((len (read-int p))
+         (m   (modulo len 8))
+         (str (get-string-n p len)))
+    (or (zero? m)
+        (get-bytevector-n p (- 8 m)))
+    str))
+
+(define (write-string-list l p)
+  (write-int (length l) p)
+  (for-each (cut write-string <> p) l))
+
+(define (read-string-list p)
+  (let ((len (read-int p)))
+    (unfold (cut >= <> len)
+            (lambda (i)
+              (read-string p))
+            1+
+            0)))
+
+(define (write-store-path f p)
+  (write-string f p))                             ; TODO: assert path
+
+(define (read-store-path p)
+  (read-string p))                                ; TODO: assert path
+
+(define write-store-path-list write-string-list)
+(define read-store-path-list read-string-list)
+
+;;; serialization.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index de9785c835..cc21af84e4 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -17,8 +17,10 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix store)
+  #:use-module (guix nar)
   #:use-module (guix utils)
   #:use-module (guix config)
+  #:use-module (guix serialization)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
@@ -29,7 +31,6 @@
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 ftw)
   #:use-module (ice-9 regex)
   #:export (%daemon-socket-file
 
@@ -161,152 +162,6 @@
 
 
 
-;; serialize.cc
-
-(define (write-int n p)
-  (let ((b (make-bytevector 8 0)))
-    (bytevector-u32-set! b 0 n (endianness little))
-    (put-bytevector p b)))
-
-(define (read-int p)
-  (let ((b (get-bytevector-n p 8)))
-    (bytevector-u32-ref b 0 (endianness little))))
-
-(define (write-long-long n p)
-  (let ((b (make-bytevector 8 0)))
-    (bytevector-u64-set! b 0 n (endianness little))
-    (put-bytevector p b)))
-
-(define (read-long-long p)
-  (let ((b (get-bytevector-n p 8)))
-    (bytevector-u64-ref b 0 (endianness little))))
-
-(define write-padding
-  (let ((zero (make-bytevector 8 0)))
-    (lambda (n p)
-      (let ((m (modulo n 8)))
-        (or (zero? m)
-            (put-bytevector p zero 0 (- 8 m)))))))
-
-(define (write-string s p)
-  (let* ((s (string->utf8 s))
-         (l (bytevector-length s))
-         (m (modulo l 8))
-         (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m))))))
-    (bytevector-u32-set! b 0 l (endianness little))
-    (bytevector-copy! s 0 b 8 l)
-    (put-bytevector p b)))
-
-(define (read-string p)
-  (let* ((len (read-int p))
-         (m   (modulo len 8))
-         (bv  (get-bytevector-n p len))
-         (str (utf8->string bv)))
-    (or (zero? m)
-        (get-bytevector-n p (- 8 m)))
-    str))
-
-(define (read-latin1-string p)
-  (let* ((len (read-int p))
-         (m   (modulo len 8))
-         (str (get-string-n p len)))
-    (or (zero? m)
-        (get-bytevector-n p (- 8 m)))
-    str))
-
-(define (write-string-list l p)
-  (write-int (length l) p)
-  (for-each (cut write-string <> p) l))
-
-(define (read-string-list p)
-  (let ((len (read-int p)))
-    (unfold (cut >= <> len)
-            (lambda (i)
-              (read-string p))
-            1+
-            0)))
-
-(define (write-store-path f p)
-  (write-string f p))                             ; TODO: assert path
-
-(define (read-store-path p)
-  (read-string p))                                ; TODO: assert path
-
-(define write-store-path-list write-string-list)
-(define read-store-path-list read-string-list)
-
-(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")))
-        (catch #t (cut proc port)
-          (lambda args
-            (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)))
-  (write-padding size p))
-
-(define (write-file f p)
-  (define %archive-version-1 "nix-archive-1")
-
-  (write-string %archive-version-1 p)
-
-  (let dump ((f f))
-    (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 (remove (cut member <> '("." ".."))
-                                (scandir f))))
-           (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)))
-        (else
-         (error "ENOSYS")))
-      (write-string ")" p))))
-
 ;; Information about a substitutable store path.
 (define-record-type <substitutable>
   (substitutable path deriver refs dl-size nar-size)
-- 
cgit 1.4.1