From 83a4a0569d6dad0b66a05a37884e753c7559570a Mon Sep 17 00:00:00 2001 From: Puck Meerburg Date: Sun, 11 May 2025 22:21:07 +0000 Subject: [PATCH] (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 | 66 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/core/src/magic.sld b/core/src/magic.sld index d2ceb7c..33bc8d6 100644 --- a/core/src/magic.sld +++ b/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))