Add impersonators/chaperones for contract proxies (#37)
ober
b278dc6805e40e679952c79c08c31591f7c83444
new file mode 100644 --- /dev/null +++ b/lib/std/misc/chaperone.sls @@ -0,0 +1,278 @@ +#!chezscheme +;;; (std misc chaperone) — Impersonators/chaperones (contract proxies) +;;; +;;; Transparent proxies that intercept operations on values. +;;; Chaperones enforce contracts via interceptors; impersonators can freely transform. +;;; +;;; (chaperone-procedure proc args-interceptor result-interceptor) +;;; (impersonate-procedure proc args-interceptor result-interceptor) +;;; (chaperone-vector vec ref-interceptor set-interceptor) +;;; (chaperone-hashtable ht ref-interceptor set-interceptor delete-interceptor) +;;; (chaperone? v) — is v a chaperone/impersonator? +;;; (chaperone-of? v1 v2) — is v1 a chaperone wrapping v2 (directly or transitively)? + +(library (std misc chaperone) + (export chaperone-procedure + impersonate-procedure + chaperone-vector + chaperone-hashtable + chaperone? + chaperone-of? + chaperone-vector-ref + chaperone-vector-set! + chaperone-hashtable-ref + chaperone-hashtable-set! + chaperone-hashtable-delete! + chaperone-unwrap) + (import (chezscheme)) + + ;; --------------------------------------------------------------- + ;; Core record types + ;; --------------------------------------------------------------- + + ;; Base record type for all chaperones/impersonators + (define-record-type chaperone-base + (fields + (immutable inner) ; the wrapped value (or another chaperone) + (immutable kind))) ; symbol: procedure, vector, hashtable + + ;; Procedure chaperone/impersonator + (define-record-type procedure-chaperone + (parent chaperone-base) + (fields + (immutable args-interceptor) ; #f or (lambda args -> args-list) + (immutable result-interceptor) ; #f or (lambda results -> results-list) + (immutable impersonator?) ; #t if impersonator + (mutable wrapper))) ; the lambda returned to the user + + ;; Vector chaperone + (define-record-type vector-chaperone + (parent chaperone-base) + (fields + (immutable ref-interceptor) ; #f or (lambda (vec idx val) -> val) + (immutable set-interceptor))) ; #f or (lambda (vec idx val) -> val) + + ;; Hashtable chaperone + (define-record-type hashtable-chaperone + (parent chaperone-base) + (fields + (immutable ref-interceptor) ; #f or (lambda (ht key val) -> val) + (immutable set-interceptor) ; #f or (lambda (ht key val) -> val) + (immutable delete-interceptor))) ; #f or (lambda (ht key) -> key) + + ;; --------------------------------------------------------------- + ;; Mapping from wrapper procedures back to their chaperone records + ;; --------------------------------------------------------------- + + ;; We use an eq-hashtable with weak keys so that GC can collect + ;; wrapper procedures that are no longer referenced. + (define *proc-chaperone-table* + (make-weak-eq-hashtable)) + + (define (register-proc-chaperone! wrapper chap) + (hashtable-set! *proc-chaperone-table* wrapper chap)) + + (define (lookup-proc-chaperone wrapper) + (hashtable-ref *proc-chaperone-table* wrapper #f)) + + ;; --------------------------------------------------------------- + ;; Unwrap — get the innermost (non-chaperone) value + ;; --------------------------------------------------------------- + + (define (chaperone-unwrap v) + (cond + [(chaperone-base? v) + (chaperone-unwrap (chaperone-base-inner v))] + [(and (procedure? v) (lookup-proc-chaperone v)) + => (lambda (chap) (chaperone-unwrap (chaperone-base-inner chap)))] + [else v])) + + ;; --------------------------------------------------------------- + ;; Resolve — get the chaperone record for any chaperoned value + ;; --------------------------------------------------------------- + + (define (resolve-chaperone v) + (cond + [(chaperone-base? v) v] + [(and (procedure? v) (lookup-proc-chaperone v)) + => (lambda (chap) chap)] + [else #f])) + + ;; --------------------------------------------------------------- + ;; Predicates + ;; --------------------------------------------------------------- + + (define (chaperone? v) + (or (chaperone-base? v) + (and (procedure? v) (lookup-proc-chaperone v) #t))) + + ;; Is v1 a chaperone of v2? (directly or transitively) + (define (chaperone-of? v1 v2) + (let ([c1 (resolve-chaperone v1)]) + (and c1 + (let ([inner (chaperone-base-inner c1)]) + (or (eq? inner v2) + ;; For procedure chaperones, the inner might be a wrapper proc + (and (procedure-chaperone? c1) + (procedure-chaperone-wrapper c1) + ;; inner is the original proc or another wrapper + #f) + ;; Check if both unwrap to the same base value + (let ([c2 (resolve-chaperone v2)]) + (and c2 + (eq? (chaperone-unwrap v1) (chaperone-unwrap v2)))) + ;; Check transitively + (chaperone-of? inner v2)))))) + + ;; --------------------------------------------------------------- + ;; Procedure chaperones/impersonators + ;; --------------------------------------------------------------- + + (define (call-through-chain chap args) + ;; Walk the chain: intercept args at each layer, call base proc, intercept results + ;; We collect interceptors in outside-in order, then apply them. + (let loop ([c chap] [current-args args] [result-interceptors '()]) + (let ([intercepted-args + (if (procedure-chaperone-args-interceptor c) + (apply (procedure-chaperone-args-interceptor c) current-args) + current-args)] + [ri (if (procedure-chaperone-result-interceptor c) + (cons (procedure-chaperone-result-interceptor c) result-interceptors) + result-interceptors)]) + (let ([inner (chaperone-base-inner c)]) + (let ([inner-chap (resolve-chaperone inner)]) + (if (and inner-chap (procedure-chaperone? inner-chap)) + ;; Inner is also a procedure chaperone, continue chain + (loop inner-chap intercepted-args ri) + ;; Inner is the base procedure + (let ([results (call-with-values + (lambda () (apply inner intercepted-args)) + list)]) + ;; Apply result interceptors innermost-first (reverse of collection order) + (let apply-results ([rs ri] [vals results]) + (if (null? rs) + (apply values vals) + (apply-results + (cdr rs) + (apply (car rs) vals))))))))))) + + (define chaperone-procedure + (case-lambda + [(proc args-interceptor result-interceptor) + (unless (procedure? (chaperone-unwrap proc)) + (error 'chaperone-procedure "expected a procedure" proc)) + (let* ([chap (make-procedure-chaperone + proc 'procedure + args-interceptor result-interceptor #f #f)] + [wrapper (lambda args + (call-through-chain chap args))]) + (procedure-chaperone-wrapper-set! chap wrapper) + (register-proc-chaperone! wrapper chap) + wrapper)] + [(proc args-interceptor) + (chaperone-procedure proc args-interceptor #f)])) + + (define impersonate-procedure + (case-lambda + [(proc args-interceptor result-interceptor) + (unless (procedure? (chaperone-unwrap proc)) + (error 'impersonate-procedure "expected a procedure" proc)) + (let* ([chap (make-procedure-chaperone + proc 'procedure + args-interceptor result-interceptor #t #f)] + [wrapper (lambda args + (call-through-chain chap args))]) + (procedure-chaperone-wrapper-set! chap wrapper) + (register-proc-chaperone! wrapper chap) + wrapper)] + [(proc args-interceptor) + (impersonate-procedure proc args-interceptor #f)])) + + ;; --------------------------------------------------------------- + ;; Vector chaperones + ;; --------------------------------------------------------------- + + (define chaperone-vector + (case-lambda + [(vec ref-interceptor set-interceptor) + (unless (vector? (chaperone-unwrap vec)) + (error 'chaperone-vector "expected a vector" vec)) + (make-vector-chaperone vec 'vector ref-interceptor set-interceptor)] + [(vec ref-interceptor) + (chaperone-vector vec ref-interceptor #f)])) + + (define (chaperone-vector-ref cv idx) + (if (vector-chaperone? cv) + (let* ([inner (chaperone-base-inner cv)] + [raw-val (if (vector-chaperone? inner) + (chaperone-vector-ref inner idx) + (vector-ref inner idx))]) + (if (vector-chaperone-ref-interceptor cv) + ((vector-chaperone-ref-interceptor cv) cv idx raw-val) + raw-val)) + (vector-ref cv idx))) + + (define (chaperone-vector-set! cv idx val) + (if (vector-chaperone? cv) + (let* ([intercepted-val + (if (vector-chaperone-set-interceptor cv) + ((vector-chaperone-set-interceptor cv) cv idx val) + val)] + [inner (chaperone-base-inner cv)]) + (if (vector-chaperone? inner) + (chaperone-vector-set! inner idx intercepted-val) + (vector-set! inner idx intercepted-val))) + (vector-set! cv idx val))) + + ;; --------------------------------------------------------------- + ;; Hashtable chaperones + ;; --------------------------------------------------------------- + + (define chaperone-hashtable + (case-lambda + [(ht ref-interceptor set-interceptor delete-interceptor) + (unless (hashtable? (chaperone-unwrap ht)) + (error 'chaperone-hashtable "expected a hashtable" ht)) + (make-hashtable-chaperone + ht 'hashtable ref-interceptor set-interceptor delete-interceptor)] + [(ht ref-interceptor set-interceptor) + (chaperone-hashtable ht ref-interceptor set-interceptor #f)] + [(ht ref-interceptor) + (chaperone-hashtable ht ref-interceptor #f #f)])) + + (define (chaperone-hashtable-ref ch key default) + (if (hashtable-chaperone? ch) + (let* ([inner (chaperone-base-inner ch)] + [raw-val (if (hashtable-chaperone? inner) + (chaperone-hashtable-ref inner key default) + (hashtable-ref inner key default))]) + (if (hashtable-chaperone-ref-interceptor ch) + ((hashtable-chaperone-ref-interceptor ch) ch key raw-val) + raw-val)) + (hashtable-ref ch key default))) + + (define (chaperone-hashtable-set! ch key val) + (if (hashtable-chaperone? ch) + (let* ([intercepted-val + (if (hashtable-chaperone-set-interceptor ch) + ((hashtable-chaperone-set-interceptor ch) ch key val) + val)] + [inner (chaperone-base-inner ch)]) + (if (hashtable-chaperone? inner) + (chaperone-hashtable-set! inner key intercepted-val) + (hashtable-set! inner key intercepted-val))) + (hashtable-set! ch key val))) + + (define (chaperone-hashtable-delete! ch key) + (if (hashtable-chaperone? ch) + (let* ([intercepted-key + (if (hashtable-chaperone-delete-interceptor ch) + ((hashtable-chaperone-delete-interceptor ch) ch key) + key)] + [inner (chaperone-base-inner ch)]) + (if (hashtable-chaperone? inner) + (chaperone-hashtable-delete! inner intercepted-key) + (hashtable-delete! inner intercepted-key))) + (hashtable-delete! ch key))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-chaperone.ss @@ -0,0 +1,337 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc chaperone)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-true val msg) + (unless val + (error 'assert-true (string-append msg ": expected #t, got #f")))) + +(define (assert-false val msg) + (when val + (error 'assert-false (string-append msg ": expected #f, got #t")))) + +;; ========================================================= +;; Procedure chaperone tests +;; ========================================================= + +;; Test 1: chaperone a procedure — validate args are positive +(test "chaperone-procedure: validate positive args" + (lambda () + (let* ([add (lambda (a b) (+ a b))] + [safe-add + (chaperone-procedure add + (lambda (a b) + (unless (and (positive? a) (positive? b)) + (error 'safe-add "arguments must be positive")) + (list a b)) + #f)]) + (assert-equal (safe-add 3 4) 7 "positive args work") + (let ([caught #f]) + (guard (e [#t (set! caught #t)]) + (safe-add -1 4)) + (assert-true caught "negative arg rejected"))))) + +;; Test 2: chaperone-procedure with result interceptor +(test "chaperone-procedure: result interceptor" + (lambda () + (let* ([square (lambda (x) (* x x))] + [logged-square + (chaperone-procedure square + #f + (lambda (result) + (assert-true (>= result 0) "result non-negative") + (list result)))]) + (assert-equal (logged-square 5) 25 "5^2 = 25") + (assert-equal (logged-square -3) 9 "(-3)^2 = 9")))) + +;; Test 3: chaperone? predicate on procedure chaperone +(test "chaperone? on procedure chaperone" + (lambda () + (let* ([f (lambda (x) x)] + [cf (chaperone-procedure f #f #f)]) + (assert-true (chaperone? cf) "wrapped proc is chaperone") + (assert-false (chaperone? f) "original proc is not chaperone") + (assert-false (chaperone? 42) "number is not chaperone")))) + +;; Test 4: chaperone-of? on procedure chaperone +(test "chaperone-of? on procedure chaperone" + (lambda () + (let* ([f (lambda (x) x)] + [cf (chaperone-procedure f #f #f)]) + (assert-true (chaperone-of? cf f) "cf is chaperone of f") + (assert-false (chaperone-of? f cf) "f is not chaperone of cf")))) + +;; Test 5: impersonate a procedure — double the result +(test "impersonate-procedure: double result" + (lambda () + (let* ([add1 (lambda (x) (+ x 1))] + [double-add1 + (impersonate-procedure add1 + #f + (lambda (result) + (list (* result 2))))]) + (assert-equal (double-add1 5) 12 "(5+1)*2 = 12") + (assert-equal (double-add1 0) 2 "(0+1)*2 = 2")))) + +;; Test 6: impersonate-procedure with args interceptor +(test "impersonate-procedure: transform args" + (lambda () + (let* ([mul (lambda (a b) (* a b))] + [shifted-mul + (impersonate-procedure mul + (lambda (a b) (list (+ a 1) (+ b 1))) + #f)]) + (assert-equal (shifted-mul 2 3) 12 "(2+1)*(3+1) = 12")))) + +;; ========================================================= +;; Vector chaperone tests +;; ========================================================= + +;; Test 7: chaperone a vector — log accesses +(test "chaperone-vector: intercept ref" + (lambda () + (let* ([v (vector 10 20 30)] + [access-log '()] + [cv (chaperone-vector v + (lambda (vec idx val) + (set! access-log (cons idx access-log)) + val) + #f)]) + (assert-equal (chaperone-vector-ref cv 0) 10 "ref index 0") + (assert-equal (chaperone-vector-ref cv 2) 30 "ref index 2") + (assert-equal access-log '(2 0) "access log recorded")))) + +;; Test 8: chaperone vector — intercept set! +(test "chaperone-vector: intercept set!" + (lambda () + (let* ([v (vector 1 2 3)] + [set-log '()] + [cv (chaperone-vector v + #f + (lambda (vec idx val) + (set! set-log (cons (list idx val) set-log)) + val))]) + (chaperone-vector-set! cv 1 99) + (assert-equal (vector-ref v 1) 99 "underlying vector updated") + (assert-equal set-log '((1 99)) "set log recorded")))) + +;; Test 9: chaperone vector — set! interceptor can reject +(test "chaperone-vector: set! interceptor rejects" + (lambda () + (let* ([v (vector 1 2 3)] + [cv (chaperone-vector v + #f + (lambda (vec idx val) + (unless (number? val) + (error 'chaperone "only numbers allowed")) + val))]) + (chaperone-vector-set! cv 0 42) + (assert-equal (vector-ref v 0) 42 "number accepted") + (let ([caught #f]) + (guard (e [#t (set! caught #t)]) + (chaperone-vector-set! cv 0 "bad")) + (assert-true caught "non-number rejected"))))) + +;; Test 10: chaperone? on vector chaperone +(test "chaperone? on vector chaperone" + (lambda () + (let* ([v (vector 1 2)] + [cv (chaperone-vector v #f #f)]) + (assert-true (chaperone? cv) "vector chaperone detected") + (assert-false (chaperone? v) "plain vector not chaperone")))) + +;; ========================================================= +;; Hashtable chaperone tests +;; ========================================================= + +;; Test 11: chaperone hashtable ref +(test "chaperone-hashtable: intercept ref" + (lambda () + (let* ([ht (make-hashtable equal-hash equal?)] + [ref-log '()]) + (hashtable-set! ht 'a 1) + (hashtable-set! ht 'b 2) + (let ([cht (chaperone-hashtable ht + (lambda (h key val) + (set! ref-log (cons key ref-log)) + val) + #f + #f)]) + (assert-equal (chaperone-hashtable-ref cht 'a 0) 1 "ref a") + (assert-equal (chaperone-hashtable-ref cht 'b 0) 2 "ref b") + (assert-equal (chaperone-hashtable-ref cht 'c 0) 0 "ref c default") + (assert-equal ref-log '(c b a) "ref log"))))) + +;; Test 12: chaperone hashtable set! +(test "chaperone-hashtable: intercept set!" + (lambda () + (let* ([ht (make-hashtable equal-hash equal?)] + [cht (chaperone-hashtable ht + #f + (lambda (h key val) + (unless (and (number? val) (positive? val)) + (error 'chaperone "only positive numbers")) + val) + #f)]) + (chaperone-hashtable-set! cht 'x 42) + (assert-equal (hashtable-ref ht 'x 0) 42 "positive accepted") + (let ([caught #f]) + (guard (e [#t (set! caught #t)]) + (chaperone-hashtable-set! cht 'x -1)) + (assert-true caught "negative rejected"))))) + +;; Test 13: chaperone hashtable delete! +(test "chaperone-hashtable: intercept delete!" + (lambda () + (let* ([ht (make-hashtable equal-hash equal?)] + [delete-log '()]) + (hashtable-set! ht 'a 1) + (hashtable-set! ht 'b 2) + (let ([cht (chaperone-hashtable ht + #f #f + (lambda (h key) + (set! delete-log (cons key delete-log)) + key))]) + (chaperone-hashtable-delete! cht 'a) + (assert-equal (hashtable-ref ht 'a 'gone) 'gone "a deleted") + (assert-equal (hashtable-ref ht 'b 'gone) 2 "b still there") + (assert-equal delete-log '(a) "delete log"))))) + +;; ========================================================= +;; Composition tests +;; ========================================================= + +;; Test 14: chaperone of a chaperone (procedure) +(test "composing procedure chaperones" + (lambda () + (let* ([f (lambda (x) (* x x))] + ;; First layer: ensure arg is positive + [c1 (chaperone-procedure f + (lambda (x) + (unless (positive? x) + (error 'c1 "must be positive")) + (list x)) + #f)] + ;; Second layer: ensure arg is < 100 + [c2 (chaperone-procedure c1 + (lambda (x) + (unless (< x 100) + (error 'c2 "must be < 100")) + (list x)) + #f)]) + (assert-equal (c2 5) 25 "valid arg passes both") + ;; Negative: caught by inner chaperone + (let ([caught #f]) + (guard (e [#t (set! caught #t)]) + (c2 -1)) + (assert-true caught "negative rejected")) + ;; Too large: caught by outer chaperone + (let ([caught #f]) + (guard (e [#t (set! caught #t)]) + (c2 200)) + (assert-true caught "too-large rejected"))))) + +;; Test 15: chaperone of a chaperone (vector) +(test "composing vector chaperones" + (lambda () + (let* ([v (vector 10 20 30)] + [log1 '()] + [log2 '()] + [cv1 (chaperone-vector v + (lambda (vec idx val) + (set! log1 (cons idx log1)) + val) + #f)] + [cv2 (chaperone-vector cv1 + (lambda (vec idx val) + (set! log2 (cons idx log2)) + val) + #f)]) + (assert-equal (chaperone-vector-ref cv2 1) 20 "ref through two layers") + (assert-equal log1 '(1) "inner interceptor called") + (assert-equal log2 '(1) "outer interceptor called")))) + +;; Test 16: chaperone-of? with nested chaperones +(test "chaperone-of? with nesting" + (lambda () + (let* ([v (vector 1 2 3)] + [cv1 (chaperone-vector v #f #f)] + [cv2 (chaperone-vector cv1 #f #f)]) + (assert-true (chaperone-of? cv1 v) "cv1 is chaperone of v") + (assert-true (chaperone-of? cv2 cv1) "cv2 is chaperone of cv1") + (assert-true (chaperone-of? cv2 v) "cv2 is chaperone of v (transitive)")))) + +;; Test 17: chaperone-unwrap +(test "chaperone-unwrap returns base value" + (lambda () + (let* ([v (vector 1 2 3)] + [cv1 (chaperone-vector v #f #f)] + [cv2 (chaperone-vector cv1 #f #f)]) + (assert-true (eq? (chaperone-unwrap cv2) v) "unwrap cv2 -> v") + (assert-true (eq? (chaperone-unwrap cv1) v) "unwrap cv1 -> v") + (assert-true (eq? (chaperone-unwrap v) v) "unwrap plain -> same")))) + +;; Test 18: impersonate with both arg and result transforms +(test "impersonate-procedure: both args and result" + (lambda () + (let* ([add (lambda (a b) (+ a b))] + [weird-add + (impersonate-procedure add + (lambda (a b) (list (* a 10) (* b 10))) + (lambda (result) (list (- result 1))))]) + ;; (3*10 + 4*10) - 1 = 69 + (assert-equal (weird-add 3 4) 69 "arg+result transform")))) + +;; Test 19: chaperone-procedure with no interceptors (passthrough) +(test "chaperone-procedure: passthrough (no interceptors)" + (lambda () + (let* ([f (lambda (x) (* x 3))] + [cf (chaperone-procedure f #f #f)]) + (assert-equal (cf 7) 21 "passthrough works") + (assert-true (chaperone? cf) "still recognized as chaperone")))) + +;; Test 20: chaperone-vector-ref/set! on plain vector (no chaperone) +(test "chaperone-vector-ref/set! on plain vector" + (lambda () + (let ([v (vector 1 2 3)]) + (assert-equal (chaperone-vector-ref v 0) 1 "ref on plain vector") + (chaperone-vector-set! v 1 99) + (assert-equal (vector-ref v 1) 99 "set! on plain vector")))) + +;; Test 21: chaperone-hashtable ops on plain hashtable +(test "chaperone-hashtable ops on plain hashtable" + (lambda () + (let ([ht (make-hashtable equal-hash equal?)]) + (chaperone-hashtable-set! ht 'x 42) + (assert-equal (chaperone-hashtable-ref ht 'x 0) 42 "ref on plain ht") + (chaperone-hashtable-delete! ht 'x) + (assert-equal (chaperone-hashtable-ref ht 'x 'gone) 'gone "delete on plain ht")))) + +;; ========================================================= +;; Summary +;; ========================================================= + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))