puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(zilch lib rewrite): introduce bytevector/string rewrite helper

Browse source 
Change-Id: I6a6a69645a253c8bc0cfd0919c280c20a6404c1e
This commit is contained in:
puck 2025-07-26 15:42:17 +00:00
parent 8e711a4b0b
commit 42ea5fd576
3 changed files with 75 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

65
core/src/lib/rewrite.sld Normal file
View file

@ -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)))))

43
core/src/magic.sld
View file

@ -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 <pending-item>
(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))))