From b37eb5ede67f8f26dcbbb0d9c60050db10b63d00 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 10 Jun 2012 22:43:02 +0200
Subject: [PATCH] Add `add-to-store' with recursive directory storage.

* guix/store.scm (write-file): Implement directory recursive dump.
  (add-to-store): Fix the parameter list.

* tests/derivations.scm (directory-contents): New procedure.
  ("add-to-store, recursive"): New test.
---
 guix/store.scm        | 56 +++++++++++++++++++++++++++----------------
 tests/derivations.scm | 31 ++++++++++++++++++++++--
 2 files changed, 64 insertions(+), 23 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index 1ea4d16894..1e36657d05 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -27,6 +27,7 @@
   #:use-module (srfi srfi-39)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 ftw)
   #:export (nix-server?
             nix-server-major-version
             nix-server-minor-version
@@ -178,25 +179,38 @@
 (define (write-file f p)
   (define %archive-version-1 "nix-archive-1")
 
-  (let ((s (lstat f)))
-    (write-string %archive-version-1 p)
-    (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)
-       (write-string ")" p))
-      ((directory)
-       (write-string "type" p)
-       (write-string "directory" p)
-       (error "ENOSYS"))
-      (else
-       (error "ENOSYS")))))
+  (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))
+        ((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))))
 
 (define-syntax write-arg
   (syntax-rules (integer boolean file string string-list)
@@ -349,9 +363,9 @@
   store-path)
 
 (define-operation (add-to-store (string basename)
-                                (integer algo)
-                                (boolean sha256-and-recursive?)
+                                (boolean fixed?)  ; obsolete, must be #t
                                 (boolean recursive?)
+                                (string hash-algo)
                                 (file file-name))
   "Add the contents of FILE-NAME under BASENAME to the store."
   store-path)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index e2e82e54b3..eb2f360b2a 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -21,12 +21,14 @@
   #:use-module (guix derivations)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
-  #:use-module (ice-9 rdelim))
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 ftw))
 
 (define %current-system
   ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
@@ -35,6 +37,24 @@
 (define %store
   (false-if-exception (open-connection)))
 
+(define (directory-contents dir)
+  "Return an alist representing the contents of DIR."
+  (define prefix-len (string-length dir))
+  (sort (file-system-fold (const #t)                   ; enter?
+                          (lambda (path stat result)   ; leaf
+                            (alist-cons (string-drop path prefix-len)
+                                        (call-with-input-file path
+                                          get-bytevector-all)
+                                        result))
+                          (lambda (path stat result) result)      ; down
+                          (lambda (path stat result) result)      ; up
+                          (lambda (path stat result) result)      ; skip
+                          (lambda (path stat errno result) result) ; error
+                          '()
+                          dir)
+        (lambda (e1 e2)
+          (string<? (car e1) (car e2)))))
+
 (test-begin "derivations")
 
 (test-assert "parse & export"
@@ -46,7 +66,14 @@
     (and (equal? b1 b2)
          (equal? d1 d2))))
 
-(test-skip (if %store 0 3))
+(test-skip (if %store 0 4))
+
+(test-assert "add-to-store, recursive"
+  (let* ((dir (dirname (search-path %load-path "language/tree-il/spec.scm")))
+         (drv (add-to-store %store "dir-tree-test" #t #t "sha256" dir)))
+    (and (eq? 'directory (stat:type (stat drv)))
+         (equal? (directory-contents dir)
+                 (directory-contents drv)))))
 
 (test-assert "derivation with no inputs"
   (let ((builder (add-text-to-store %store "my-builder.sh"