(zilch magic): add helper to turn a CA drv into a non-CA equivalent

This reuses the exact NAR, so it cannot depend on the exact path of
$out. That is, however, good enough for the usecases Zilch has.

core/src/magic.sld

@@ -22,6 +22,8 @@
     store-path-for-impure-drv store-path-for-ca-drv store-path-for-ca-drv*
     store-path-realised store-path-open
 
+    drv-resolve-ca
+
     zilch-magic-counters)
 
   (begin
@@ -283,6 +285,70 @@
          (for-each (lambda (output) (set! has-placeholder (or has-placeholder (derivation-output-placeholder? (cdr (assoc output (derivation-outputs drv))))))) outputs)
          (or has-placeholder (zexp-ctx-has-placeholder (cdr drv-context))))))
 
+   (define (drv-is-ca drv)
+     (define is-ca #f)
+     (for-each (lambda (out) (when (eq? (derivation-output-hash (cdr out)) 'floating) (set! is-ca #t))) (derivation-outputs drv))
+     is-ca)
+
+   (define (rewrite-string str with-rewrites)
+     (define parts '())
+     (define (find-part-at i last-i)
+       (define next-slash (string-contains str "/" i))
+       (if (or (not next-slash) (>= next-slash (- (string-length str) 53)))
+         (if (= last-i 0)
+           (set! parts #f)
+           (set! parts (cons (string-copy str last-i) parts)))
+         (let* ((actual-string (string-copy str next-slash (+ next-slash 53)))
+                (mapping-pair (assoc actual-string with-rewrites string=?)))
+           ; If we have a mapping for this string, replace it and continue.
+           (if mapping-pair
+             (begin
+               (set! parts (cons (cdr mapping-pair) (cons (string-copy str last-i next-slash) parts)))
+               (find-part-at (+ next-slash 53) (+ next-slash 53)))
+             (find-part-at (+ next-slash 1) last-i)))))
+     (find-part-at 0 0)
+     (if (pair? parts)
+       (string-concatenate-reverse parts)
+       str))
+
+   (define (drv-resolve-ca drv needed-outputs)
+     (if (drv-is-ca drv)
+       (let
+         ((new-drvs (list)) (new-srcs (derivation-input-src drv)) (rewrites (list)))
+         ; For each drv, figure out if we need to CA it.
+         (begin
+          (for-each
+            (lambda (drv-and-outputs)
+              (define ca-outputs (drv-resolve-ca (car drv-and-outputs) (cdr drv-and-outputs)))
+              (if (not ca-outputs)
+                ; It's not CA'd, so add it back
+                (set! new-drvs (cons drv-and-outputs new-drvs))
+
+                ; Find the CA paths matching the input paths (this is basically equivalent to daemon-wop-query-derivation-output-map!)
+                ; Also record the rewrites!
+                (for-each
+                  (lambda (output)
+                    (set! new-srcs (cons (cdr (assoc output (cdr ca-outputs))) new-srcs))
+                    (define old-output (cdr (assoc output (derivation-outputs (car drv-and-outputs)))))
+                    (set! rewrites (cons (cons (derivation-output-path old-output) (cdr (assoc output (cdr ca-outputs)))) rewrites)))
+                  (cdr drv-and-outputs))))
+           (derivation-input-drvs drv))
+          ; Now we rewrite the builder and environment.
+          (let*
+            ((new-builder (rewrite-string (derivation-builder drv) rewrites))
+             (new-args (map (lambda (v) (rewrite-string v rewrites)) (derivation-args drv)))
+             (new-env (map (lambda (kv) (cons (car kv) (rewrite-string (cdr kv) rewrites))) (derivation-env drv)))
+             (new-drv (make-input-addressed-derivation
+                       (derivation-name drv)
+                       (derivation-system drv)
+                       new-drvs new-srcs (cons new-builder new-args) new-env (map car (derivation-outputs drv)))))
+            (write-drv-to-daemon new-drv)
+            (daemon-wop-build-paths (*daemon*) (list->vector (map (lambda (v) (string-append (derivation-path new-drv) "!" v)) needed-outputs)))
+            (map (lambda (o) (define-values (name hash nar-size ca-store-path) (store-path-to-fod (*daemon*) (derivation-output-path (cdr (assoc o (derivation-outputs new-drv) string=?))))) ca-store-path)
+              needed-outputs))))
+       ; Not a CA drv.
+       #f))
+
    (define (store-path-realised path)
      (define ctx (zexp-unwrap (zexp (zexp-unquote path))))
      (define val (zexp-evaluation-value ctx))