Speed up indexing the storage

1 files changed, 22 insertions, 24 deletions

diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm
index 4c1a9df..5a9a2f6 100644
--- a/nar-herder/storage.scm
+++ b/nar-herder/storage.scm
@@ -70,30 +70,28 @@
 
 (define (index-storage database storage-root)
   (define (get-files-hash)
-    (define (get-file-strings prefix children)
-      (append-map
-       (match-lambda
-         ((name stat)
-          (list (string-append prefix "/" name)))
-         ((name stat children ...)
-          (get-file-strings (string-append prefix "/" name)
-                            children)))
-       children))
-
-    (let* ((lst
-            (match (file-system-tree storage-root)
-              ((_ _ (name stat children ...))
-               (get-file-strings (string-append "/" name)
-                                 children))
-              ((_ _) '())))             ; empty directory
-           (hash-table
-            (make-hash-table (length lst))))
-
-      (for-each (lambda (s)
-                  (hash-set! hash-table s #t))
-                lst)
-
-      hash-table))
+    (define storage-root-length
+      (string-length storage-root))
+
+    (define enter? (const #t))
+    (define (leaf name stat result)
+      (hash-set! result
+                 (peek (string-drop name storage-root-length))
+                 #t)
+      result)
+
+    (define (down name stat result) result)
+    (define (up name stat result) result)
+    (define (skip name stat result) result)
+
+    (define (error name stat errno result)
+      (format (current-error-port) "warning: ~a: ~a~%"
+              name (strerror errno))
+      result)
+
+    (file-system-fold enter? leaf down up skip error
+                      (make-hash-table (expt 2 19))
+                      storage-root))
 
   (let* ((files-hash
           (get-files-hash))