From 42ea5fd576370bc66189328c06f5874891f36fc8 Mon Sep 17 00:00:00 2001 From: Puck Meerburg Date: Sat, 26 Jul 2025 15:42:17 +0000 Subject: [PATCH] (zilch lib rewrite): introduce bytevector/string rewrite helper Change-Id: I6a6a69645a253c8bc0cfd0919c280c20a6404c1e --- core/src/lib/rewrite.sld | 65 ++++++++++++++++++++++++++++++++++++++++ core/src/magic.sld | 43 +++++--------------------- core/zilch.egg | 4 ++- 3 files changed, 75 insertions(+), 37 deletions(-) create mode 100644 core/src/lib/rewrite.sld diff --git a/core/src/lib/rewrite.sld b/core/src/lib/rewrite.sld new file mode 100644 index 0000000..7d0f883 --- /dev/null +++ b/core/src/lib/rewrite.sld @@ -0,0 +1,65 @@ +;; Helper utilities to replace a list of bytevectors in a string. +;; Used for e.g. resolving placeholders, or swapping out store paths. +(define-library (zilch lib rewrite) + (import (scheme base) (srfi 207)) + + (export rewrite-bytevector-or-string) + + (begin + ;; Rewrites a bytevector. + ;; `with-rewrites` is a list of `(from . to)` bytevector pairs. + ;; All `from` values are assumed to start with a forward slash. + (define (rewrite-bytevector str with-rewrites) + (define parts '()) + (define shortest-rewrite #f) + (define longest-rewrite #f) + (for-each + (lambda (kv) + (define len (bytevector-length (car kv))) + (unless (and shortest-rewrite (> shortest-rewrite len)) (set! shortest-rewrite len)) + (unless (and longest-rewrite (< longest-rewrite len)) (set! longest-rewrite len))) + with-rewrites) + (define (matches i key) + (define key-len (bytevector-length key)) + (if (> i (- (bytevector-length str) key-len)) + #f + (let loop ((j 0)) + (cond + ((>= j key-len) #t) + ((= (bytevector-u8-ref key j) (bytevector-u8-ref str (+ i j))) (loop (+ 1 j))) + (else #f))))) + (define (find-match-at i) + (let loop ((l with-rewrites)) + (cond + ((null? l) #f) + ((matches i (caar l)) (car l)) + (else (loop (cdr l)))))) + (when shortest-rewrite + (let find-part ((i 0) (last-i 0)) + (let ((next-slash (bytestring-index str (lambda (c) (= c #x2F)) i))) + (if (or (not next-slash) (> next-slash (- (bytevector-length str) shortest-rewrite))) + (if (= last-i 0) + (set! parts #f) + (set! parts (cons (bytevector-copy str last-i) parts))) + (let ((mapping-pair (find-match-at next-slash))) + (if mapping-pair + (let* ((len (bytevector-length (car mapping-pair))) + (next-start (+ next-slash len))) + (set! parts (cons (cdr mapping-pair) (cons (bytevector-copy str last-i next-slash) parts))) + (find-part next-start next-start)) + (find-part (+ next-slash 1) last-i))))))) + (if (pair? parts) + (apply bytevector-append (reverse parts)) + #f)) + + ;; Rewrites a bytevector or string. + ;; `with-rewrites` is a list of `(from . to)` bytevector pairs. + ;; All `from` values are assumed to start with a forward slash. + (define (rewrite-bytevector-or-string str with-rewrites) + (define result + (if (string? str) + (rewrite-bytevector (string->utf8 str) with-rewrites) + (rewrite-bytevector str with-rewrites))) + (if (and (string? str) result) + (utf8->string result) + (or result str))))) diff --git a/core/src/magic.sld b/core/src/magic.sld index 4756fe1..b8323a5 100644 --- a/core/src/magic.sld +++ b/core/src/magic.sld @@ -10,7 +10,8 @@ (import (scheme base) (scheme file) (scheme lazy) (chicken condition) - (zilch lib hash) (zilch nix daemon) (zilch nix drv) (zilch nix path) + (zilch lib hash) (zilch lib rewrite) + (zilch nix daemon) (zilch nix drv) (zilch nix path) (zilch nix hash) (zilch planner step) (zilch zexpr) @@ -281,36 +282,6 @@ (else (loop (cdr drvs)))))) is-ca) - (define (rewrite-string str with-rewrites) - (define bv (string->utf8 str)) - (define out (rewrite-bytevector bv with-rewrites)) - (if (eq? bv out) str (utf8->string out))) - - (define (rewrite-bytevector str with-rewrites) - (define parts '()) - (let find-part-at ((i 0) (last-i 0)) - (let ((next-slash (bytestring-index str (lambda (c) (= c #x2F)) i))) - (if (or (not next-slash) (> next-slash (- (bytevector-length str) 53))) - (if (= last-i 0) - (set! parts #f) - (set! parts (cons (bytevector-copy str last-i) parts))) - (let* ((actual-string (utf8->string (bytevector-copy str next-slash (+ next-slash 53)))) - (mapping-pair (mapping-ref/default with-rewrites actual-string #f))) - ; If we have a mapping for this string, replace it and continue. - (if mapping-pair - (begin - (set! parts (cons (string->utf8 mapping-pair) (cons (bytevector-copy str last-i next-slash) parts))) - (find-part-at (+ next-slash 53) (+ next-slash 53))) - (find-part-at (+ next-slash 1) last-i)))))) - (if (pair? parts) - (apply bytevector-append (reverse parts)) - str)) - - (define (rewrite-string-or-bytevector str with-rewrites) - (if (bytevector? str) - (rewrite-bytevector str with-rewrites) - (rewrite-string str with-rewrites))) - (define-record-type (make-pending-item init-ca-drv ca-drv ia-drv resolved-paths awaiting-count awaited-by) pending-item? @@ -429,7 +400,7 @@ ; Rewrite CA drv to IA drv using the known inputs (define new-drvs (list)) (define new-srcs (derivation-input-src (pending-item-ca-drv item))) - (define rewrites (mapping (make-default-comparator))) + (define rewrites (list)) (for-each (lambda (drv-and-outputs) (mutex-lock! pending-mutex) @@ -442,7 +413,7 @@ (define new-path (cdr (assoc output (pending-item-resolved-paths dep-pend)))) (set! new-srcs (cons new-path new-srcs)) (define old-output (cdr (assoc output (derivation-outputs (car drv-and-outputs))))) - (set! rewrites (mapping-set! rewrites (derivation-output-path old-output) new-path))) + (set! rewrites (cons (cons (string->utf8 (derivation-output-path old-output)) (string->utf8 new-path)) rewrites))) (cdr drv-and-outputs)) ; Not a CA drv, add it back to the drvs list @@ -450,9 +421,9 @@ (derivation-input-drvs (pending-item-ca-drv item))) (define ca-drv (pending-item-ca-drv item)) - (define new-builder (rewrite-string-or-bytevector (derivation-builder ca-drv) rewrites)) - (define new-args (map (lambda (v) (rewrite-string-or-bytevector v rewrites)) (derivation-args ca-drv))) - (define new-env (map (lambda (kv) (cons (car kv) (rewrite-string-or-bytevector (cdr kv) rewrites))) (derivation-env ca-drv))) + (define new-builder (rewrite-bytevector-or-string (derivation-builder ca-drv) rewrites)) + (define new-args (map (lambda (v) (rewrite-bytevector-or-string v rewrites)) (derivation-args ca-drv))) + (define new-env (map (lambda (kv) (cons (car kv) (rewrite-bytevector-or-string (cdr kv) rewrites))) (derivation-env ca-drv))) (define ia-drv (if (drv-is-fod ca-drv) (let ((output (cdar (derivation-outputs ca-drv)))) diff --git a/core/zilch.egg b/core/zilch.egg index 8c76cfe..7c00796 100644 --- a/core/zilch.egg +++ b/core/zilch.egg @@ -43,4 +43,6 @@ (source "src/vfs.sld") (component-dependencies zilch.magic zilch.file zilch.zexpr)) (extension zilch.lib.getopt - (source "src/lib/getopt.sld")))) + (source "src/lib/getopt.sld")) + (extension zilch.lib.rewrite + (source "src/lib/rewrite.sld"))))