From 59dc27b94c25c41eab0d12fb75892f2707131a22 Mon Sep 17 00:00:00 2001
From: Puck Meerburg <puck@puckipedia.com>
Date: Wed, 27 Nov 2024 16:38:40 +0000
Subject: [PATCH] (zilch vfs): actually commit the file

oops.
---
 core/src/vfs.sld | 115 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 115 insertions(+)
 create mode 100644 core/src/vfs.sld

diff --git a/core/src/vfs.sld b/core/src/vfs.sld
new file mode 100644
index 0000000..cdee1ac
--- /dev/null
+++ b/core/src/vfs.sld
@@ -0,0 +1,115 @@
+;; Contains procedures to work with a very simple virtual filesystem,
+;; abstracting between local and in-store store paths.
+(define-library (zilch vfs)
+  (import
+    (scheme base) (scheme file)
+    (chicken file)
+    (zilch magic) (zilch file) (zilch zexpr)
+    (srfi 4) (srfi 113) (srfi 128) (srfi 146))
+
+  (export
+    <vfs> make-vfs vfs? vfs-contents
+    vfs-dir-files vfs-file-ref
+    vfs-dir-filter vfs-dir-filter-all
+    vfs-from-directory vfs-from-store
+    vfs-to-store)
+
+  (begin
+    (define (read-full-file port)
+      (define buf (make-bytevector 2048 0))
+      (call-with-port (open-output-bytevector)
+        (lambda (outport)
+          (do ((read-bytes 0 (read-bytevector! buf port))) ((eof-object? read-bytes) (get-output-bytevector outport))
+              (unless (eof-object? read-bytes) (write-bytevector buf outport 0 read-bytes))))))
+
+    ;; `contents` is a mapping whose keys are a pair (dir . filename) to file contents (e.g. zfile, or store path).
+    ;; The file contents may be the symbol 'directory to indicate there's a directory.
+    ;;
+    ;; The root directory is specified by `dir` being an empty string. There are no trailing or leading slashes.
+    (define-record-type <vfs>
+      (make-vfs contents)
+      vfs?
+      (contents vfs-contents))
+
+    (define (vfs-dir-files vfs dir)
+      (mapping-map->list
+        (lambda (k v) (cons (cdr k) v))
+        (mapping-filter
+          (lambda (key val)
+            (and (not (eq? val 'directory)) (string=? (car key) dir)))
+          (vfs-contents vfs))))
+
+    (define (vfs-file-ref vfs dirname filename)
+      (mapping-ref/default (vfs-contents vfs) (cons dirname filename) #f))
+
+    ;; Calls the filter with the dir, filename, and contents, for each file.
+    ;; If filter returns #f, the file in the vfs will be replaced by /dev/null.
+    (define (vfs-dir-filter vfs filter)
+      (make-vfs
+        (mapping-map/monotone
+          (lambda (key val)
+            (if (or (eq? val 'directory) (filter (car key) (cdr key) val)) (values key val) (values key "/dev/null")))
+          (make-default-comparator)
+          (vfs-contents vfs))))
+
+    ;; Calls the filter for each directory. If the filter returns #f, the directory's files are replaced with `/dev/null`.
+    (define (vfs-dir-filter-all filter vfs)
+      (define to-filter-out (set (make-default-comparator)))
+      (mapping-for-each
+        (lambda (key val)
+          (when (and (eq? val 'directory) (not (filter (string-append (car key) "/" (cdr key)))))
+            (set! to-filter-out (set-adjoin! to-filter-out (string-append (car key) "/" (cdr key))))))
+        (vfs-contents vfs))
+      (define (is-filtered dirname)
+        (set-any? (lambda (v) (string=? v dirname)) to-filter-out))
+      (make-vfs
+        (mapping-map/monotone
+          (lambda (key val)
+             (if (or (eq? val 'directory) (not (is-filtered (car key)))) (values key val) (values key "/dev/null")))
+          (make-default-comparator)
+          (vfs-contents vfs))))
+
+    ;; Takes a VFS and writes its directory structure into the Nix store,
+    ;; returning a zdir describing the root directory.
+    (define (vfs-to-store vfs)
+      (define dirmap (mapping (make-default-comparator)))
+      (mapping-for-each
+        (lambda (k contents)
+          (define dir (car k))
+          (define fname (cdr k))
+          (if (eq? contents 'directory)
+            (set! dirmap (mapping-update!/default dirmap dir (lambda (v) (cons (cons fname 'directory) v)) '()))
+            (set! dirmap (mapping-update!/default dirmap dir (lambda (v) (cons (cons fname (zsymlink contents)) v)) '()))))
+        (vfs-contents vfs))
+      (define (read-dir dirname)
+        (define contents (mapping-ref/default dirmap dirname '()))
+        (for-each
+          (lambda (pair)
+            (when (eq? (cdr pair) 'directory)
+              (set-cdr! pair (read-dir (if (string=? dirname "") (car pair) (string-append dirname "/" (car pair)))))))
+          contents)
+        (zdir contents))
+      (read-dir ""))
+
+    ;; Generates a full VFS structure from an on-disk directory.
+    (define (vfs-from-directory osdir)
+      (define out (mapping (make-default-comparator)))
+      (define (iter-dir dirpath)
+        (define reldir (string-append osdir "/" dirpath))
+        (define contents (directory reldir))
+        (for-each
+          (lambda (name)
+            (unless (string=? (string-copy name 0 1) ".")
+              (if (directory-exists? (string-append reldir "/" name))
+                (begin
+                  (iter-dir (if (string=? dirpath "") name (string-append dirpath "/" name)))
+                  (set! out (mapping-set! out (cons dirpath name) 'directory)))
+                (set! out (mapping-set! out (cons dirpath name) (zfile (zexp ,(call-with-input-file (string-append reldir "/" name) read-full-file))))))))
+          contents))
+      (iter-dir "")
+      (make-vfs out))
+
+    (define (vfs-from-store store-path)
+      (define osdir (store-path-realised store-path))
+      ; TODO(puck): use builtin:fetchurl here instead of reimporting (requires divining a hash first)
+      (vfs-from-directory osdir))))