From ec41674598432dfc8ae5dfb7037fbdb8b8c49b13 Mon Sep 17 00:00:00 2001
From: Puck Meerburg <puck@puckipedia.com>
Date: Sun, 11 May 2025 22:21:07 +0000
Subject: [PATCH] (zilch magic): add helper to turn a store path into its FOD
 equivalent

---
 core/src/magic.sld | 64 +++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 55 insertions(+), 9 deletions(-)

diff --git a/core/src/magic.sld b/core/src/magic.sld
index 0f7544f..d9d264b 100644
--- a/core/src/magic.sld
+++ b/core/src/magic.sld
@@ -5,9 +5,10 @@
   (import
     (scheme base) (scheme file)
     (zilch lib hash) (zilch nix daemon) (zilch nix drv) (zilch nix path)
+    (zilch nix hash)
     (zilch planner step)
     (zilch zexpr)
-    (srfi 128) (srfi 132) (srfi 146) (srfi 152)
+    (srfi 128) (srfi 132) (srfi 146) (srfi 152) (srfi 207)
     (chicken base) (chicken format) socket)
 
   (export
@@ -24,16 +25,61 @@
     zilch-magic-counters)
 
   (begin
+
+   (define (daemon-connect)
+     (define conn
+      (parameterize
+       ((socket-send-buffer-size 4096) (socket-send-size 4096) (socket-receive-timeout 60000) (socket-send-timeout 5000))
+       (let ((unix-socket (socket af/unix sock/stream)))
+            (socket-connect unix-socket (unix-address "/nix/var/nix/daemon-socket/socket"))
+            (let-values (((in-port out-port) (socket-i/o-ports unix-socket)))
+                        (make-daemon-link in-port out-port)))))
+     (daemon-wop-handshake conn)
+     conn)
+
+   (define (daemon-close conn)
+     (close-input-port (daemon-link-in-port conn))
+     (close-output-port (daemon-link-out-port conn)))
+
    ;; The daemon connection used by `(zilch magic)`.
    (define *daemon*
-     (make-parameter
-       (parameterize
-        ((socket-send-buffer-size 4096) (socket-send-size 4096) (socket-receive-timeout 60000) (socket-send-timeout 5000))
-        (let ((unix-socket (socket af/unix sock/stream)))
-             (socket-connect unix-socket (unix-address "/nix/var/nix/daemon-socket/socket"))
-             (let-values (((in-port out-port) (socket-i/o-ports unix-socket)))
-                         (make-daemon-link in-port out-port))))))
-   (daemon-wop-handshake (*daemon*))
+     (make-parameter (daemon-connect)))
+
+   ; Create a CA store path from the store path being passed in.
+   (define (store-path-to-fod conn path)
+     (define data (daemon-wop-query-path-info conn path))
+     (define nar-size (valid-path-info-nar-size data))
+     (define hash (valid-path-info-nar-hash data))
+     (define references (valid-path-info-references data))
+     (define references-filtered (list-copy references))
+     (define self-references (member path references-filtered string=?))
+     (when self-references
+       (if (null? (cdr self-references))
+         (set! references-filtered '())
+         (begin
+           ; Cheaply remove this item from the list.
+           ;    (self-references . (foo . (bar . baz)))
+           ; -> (foo             . (bar . baz)
+           (set-car! self-references (cadr self-references))
+           (set-cdr! self-references (cddr self-references)))))
+
+     (define name (string-copy path (+ (string-length (%store-dir)) 1 32 1)))
+     (define ca-store-path (make-fixed-output-with-references hash name references-filtered self-references))
+     (unless (daemon-wop-query-path-info conn ca-store-path)
+       (daemon-wop-add-to-store-nar conn ca-store-path (valid-path-info-deriver data) (hex hash) references nar-size (string-append "fixed:r:sha256:" (as-base32 hash))
+         (lambda (write-blob)
+           (define new-conn (daemon-connect))
+           (daemon-wop-nar-from-path new-conn path)
+           (define blob (make-bytevector 4096))
+           (do ((i 0))
+               ((= i nar-size) (daemon-close new-conn))
+               (let* ((chunk-size (min 4096 (- nar-size i)))
+                      (bytes-read (read-bytevector! blob (daemon-link-in-port new-conn) 0 chunk-size)))
+                 (when (eof-object? bytes-read)
+                   (error "unexpected EOF"))
+                 (set! i (+ i bytes-read))
+                 (write-blob blob 0 bytes-read))))))
+     (values name hash nar-size ca-store-path))
 
    ;; If set to `#f`, `store-path-for-ca-drv*` will not generate
    ;; content-addressed derivations.