Add safety gap implementations: resource RAII, contracts, error hierarchy, immutable defaults
ober
fae3237851cc45e8cb6abe8926746b2c53384cc8
--- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$ # Shared object paths for FFI-based chez-* libraries CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll:$(CHEZ_EXT_DIR)/chez-inotify:$(CHEZ_EXT_DIR)/chez-crypto:$(CHEZ_EXT_DIR)/chez-sqlite:$(CHEZ_EXT_DIR)/chez-postgresql -.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-native native clean-native audit-native clean fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-native test-gaps native clean-native audit-native clean fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded @@ -284,7 +284,10 @@ test-native: native audit-native: cd $(RUST_NATIVE_DIR) && cargo audit -test-all: test test-features test-wrappers test-security test-native +test-gaps: + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-gaps.ss + +test-all: test test-features test-wrappers test-security test-native test-gaps ## ========== Fuzzing ========== new file mode 100644 --- /dev/null +++ b/docs/gaps.md @@ -0,0 +1,279 @@ +# Jerboa Language Review: Security, Safety, Performance for Claude + +A comprehensive review of Jerboa as a primary language for Claude to code in, +focused on best-in-class security, safety, and performance. + +## What Jerboa Is + +Jerboa reimplements Gerbil Scheme's API surface as pure **stock Chez Scheme** +libraries — 364 modules, ~2,900 tests, 13 fuzzing harnesses. No custom runtime, +no patched Chez. This is a significant engineering achievement. + +--- + +## Strengths (What's Already Best-in-Class) + +### Security Architecture — Exceptional + +The layered defense model is genuinely impressive and ahead of most languages: + +- **Allowlist-only sandbox** (`restrict.sls`) — 113 bindings, no blocklist. + Future Chez additions can't leak in. `read` replaced with depth-limited + `jerboa-read` (no `#.` read-eval). This is the right design. +- **Capability-based security** with sealed opaque records + CSPRNG nonces — + unforgeable by construction. +- **Taint tracking** with safe sinks — prevents untrusted data from reaching + `system`, `open-output-file`, etc. +- **OS-level enforcement** — Landlock (irreversible filesystem restrictions), + seccomp, privsep via fork. +- **Secure memory** — mlock, guard pages, explicit_bzero, DONTDUMP, DONTFORK. +- **AI attack hardening** — 13 findings addressed (empty-host = deny, symlink + resolution, etc.). +- **13 fuzzing harnesses** with configurable depth limits. + +### Rust Native Backend — Smart Architecture + +Replacing 10+ C dependencies with a single `libjerboa_native.so` via Rust is +the right call. ring for crypto, flate2 for compression, regex crate for +ReDoS-proof matching. The `ffi_wrap()`/`set_last_error()` panic handling is +correct. + +### Type System Breadth + +Refinement types, linear types, affine types, phantom types, GADTs, +typeclasses, row polymorphism, HKTs — all present. The `define/r` and +`lambda/r` forms for checked refinements are clean. + +### Chez Scheme Foundation + +Running on stock Chez gives you: engines (preemptive timeout), ephemerons +(GC-aware weak refs), FASL (fast serialization), ftypes (C struct access), WPO, +and a mature GC. These are genuine advantages over Gambit. + +--- + +## Gaps and Recommendations for Best-in-Class + +### 1. CRITICAL: Resource Safety / RAII Guarantees + +**Gap**: The `borrow.sls` module tracks borrows at runtime, but there's no +compile-time or macro-enforced resource discipline that prevents "forgot to +close the file" bugs — the #1 source of resource leaks in dynamic languages. + +**Recommendation**: Add a `with-resource` macro that is the **only** way to +acquire resources (files, sockets, DB connections, crypto contexts). Like +Python's `with` or Rust's `Drop`, but enforced: + +```scheme +(with-resource ([db (sqlite-open "test.db")] + [sock (tcp-connect "localhost" 8080)]) + (sqlite-exec db "SELECT 1") + (tcp-write sock "hello")) +;; db and sock are guaranteed closed here, even on exception +``` + +The existing `dynamic-wind` and `with-destroy` patterns exist but aren't +mandatory. For Claude-generated code, making the safe path the easy path matters +more than flexibility. + +### 2. CRITICAL: Contract-Checked Standard Library + +**Gap**: The contract system (`define/contract`, `check-argument`) exists but +isn't applied to the standard library itself. Claude can call `sqlite-exec` with +wrong types and get cryptic FFI errors. + +**Recommendation**: Wrap the top ~50 most-used stdlib APIs with contracts: + +```scheme +(define/contract (sqlite-exec db sql) + (pre: (sqlite-db? db) (string? sql)) + (post: (lambda (r) (or (null? r) (list? r)))) + ...) +``` + +This catches bugs at the Scheme boundary before they hit C/Rust FFI. In +`*typed-mode* 'release`, these should compile away to zero overhead. + +### 3. HIGH: Structured Error Types Across the Stack + +**Gap**: Many modules use bare `(error 'who "message")` which produces +unstructured error messages. The security modules have proper condition types +(`&taint-violation`, `&contract-violation`, `&sandbox-violation`), but +networking, database, and actor errors don't. + +**Recommendation**: Define a condition hierarchy for every subsystem: + +```scheme +;; Network errors +&network-error -> &connection-refused, &timeout, &dns-failure, &tls-error + +;; Database errors +&db-error -> &query-error, &constraint-violation, &connection-lost + +;; Actor errors +&actor-error -> &mailbox-full, &actor-dead, &supervision-failure +``` + +This lets Claude write proper error handling with `guard` clauses that +pattern-match on error type rather than parsing strings. + +### 4. HIGH: Compile-Time Import Verification + +**Gap**: No tool currently verifies at compile time that all imported symbols +are actually used, or that all used symbols are actually imported. The +`gerbil_lint` tool does this for Gerbil, but Jerboa needs its own. + +**Recommendation**: Add a `jerboa lint` command that: + +- Detects unused imports +- Detects unbound identifiers before runtime +- Warns on shadowed bindings +- Checks arity at call sites (using the type annotations when available) + +### 5. HIGH: Timeout Enforcement on All External Operations + +**Gap**: The engine-based timeout system is powerful (Chez-exclusive), but it's +not automatically applied to network I/O, database queries, or subprocess calls. +Claude-generated code that calls `tcp-read` without a timeout hangs forever. + +**Recommendation**: Make timeouts mandatory or defaulted on all blocking +operations: + +```scheme +;; Every blocking call should accept timeout: +(tcp-read sock 1024 timeout: 30) ;; seconds, raises &timeout after 30s +(sqlite-query db "SELECT ..." timeout: 5) +(channel-get ch timeout: 10) + +;; Or wrap in engine-based timeout: +(with-timeout 30 + (tcp-read sock 1024)) +``` + +### 6. MEDIUM: Immutable-by-Default Data Structures + +**Gap**: Hash tables, vectors, and records are mutable by default. For +Claude-generated code, accidental mutation is a common bug class. + +**Recommendation**: Provide immutable variants as the default import, with +mutable opt-in: + +```scheme +;; Default: immutable hash +(def h (hash ("key" "val"))) ;; immutable +(hash-set h "key2" "val2") ;; returns new hash + +;; Opt-in mutable +(def h (mutable-hash ("key" "val"))) +(hash-set! h "key2" "val2") ;; mutates in place +``` + +The persistent data structures (`pmap.sls`, `pvec.sls`) exist but aren't the +default. Making them default would prevent an entire class of bugs. + +### 7. MEDIUM: Serialization Safety + +**Gap**: FASL serialization is fast but can deserialize arbitrary objects +including procedures. This is dangerous for any network-facing code. + +**Recommendation**: Add a safe serialization mode that only allows data (no +procedures, no records unless explicitly registered): + +```scheme +(safe-fasl-write obj port) ;; raises if obj contains procedures +(safe-fasl-read port) ;; rejects procedures, unregistered records +(register-safe-record-type! <rtd>) ;; opt-in for specific types +``` + +### 8. MEDIUM: Actor Mailbox Backpressure by Default + +**Gap**: Actor mailboxes are unbounded by default (`bounded.sls` exists but is +opt-in). An actor receiving messages faster than it processes them will OOM. + +**Recommendation**: Default mailbox size of 10,000 messages. `spawn` should +accept `mailbox-size:` parameter. When full, `send` should either block +(backpressure) or drop-oldest with a logged warning. + +### 9. MEDIUM: Decompression Bomb Protection Everywhere + +**Gap**: `native-rust.sls` has a 100MB decompression limit for zlib — good. But +JSON parsing, XML parsing, and FASL deserialization don't have size limits. + +**Recommendation**: Add configurable limits to all parsers: + +- `*json-max-size*` — bytes before rejecting +- `*xml-max-size*`, `*xml-max-depth*` +- `*fasl-max-object-count*` — prevent billion-laughs via nested structures + +### 10. LOW: Deterministic Builds for Security Audit + +**Gap**: `build/reproducible.sls` and `build/sbom.sls` exist. Verify they're +actually producing bit-identical output and complete SBOMs including the Rust +dependency tree. + +### 11. Feature Addition: Structured Concurrency as Default + +**Gap**: `structured.sls` exists but isn't the primary concurrency model. Raw +`fork-thread` is still accessible. + +**Recommendation**: Make structured concurrency (nurseries/task groups) the +standard API. Every spawned task should belong to a scope that handles +cancellation: + +```scheme +(with-task-group + (spawn-task (lambda () (fetch-url "..."))) + (spawn-task (lambda () (query-db "..."))) + ;; if either task fails, the other is cancelled + ;; all tasks must complete before scope exits + ) +``` + +### 12. Feature Addition: First-Class Error Context / Traces + +**Recommendation**: Add automatic context accumulation for error diagnostics: + +```scheme +(with-context "processing user request #1234" + (with-context "validating input" + (check-argument string? input 'validate))) +;; Error message includes: +;; "processing user request #1234 > validating input > argument failed predicate" +``` + +This is invaluable for debugging Claude-generated code in production. + +--- + +## Summary Assessment + +| Category | Current Grade | With Recommendations | +|----------|:---:|:---:| +| **Security** | A | A+ | +| **Safety** | B+ | A | +| **Performance** | B+ | A- | +| **Claude-friendliness** | B | A | +| **Error diagnostics** | C+ | A- | +| **Resource management** | B- | A | + +### Strongest Differentiators vs. Other Languages for Claude + +1. Allowlist sandbox — best-in-class for running AI-generated code safely +2. Capability-based security — unforgeable by construction +3. Chez engines — preemptive timeout without OS signals +4. Taint tracking — prevents injection from untrusted sources +5. Rust native backend — memory-safe FFI without C footguns + +### Biggest Gaps to Close + +1. Contract-checked stdlib (catches most Claude bugs before FFI) +2. Mandatory resource cleanup (prevents leaks) +3. Structured error types (enables proper error handling) +4. Default timeouts on blocking ops (prevents hangs) + +### Conclusion + +The foundation is genuinely strong. The security architecture is more +comprehensive than most production languages. The main work needed is making the +safe path the *default* path — so Claude generates correct code without having +to know about the safety features. new file mode 100644 --- /dev/null +++ b/lib/std/error/conditions.sls @@ -0,0 +1,299 @@ +#!chezscheme +;;; (std error conditions) — Structured error condition hierarchy +;;; +;;; Every subsystem gets its own condition type so that guard/catch clauses +;;; can pattern-match on error kind instead of parsing strings. +;;; +;;; Hierarchy: +;;; &jerboa (root for all jerboa conditions) +;;; &jerboa-network (networking) +;;; &connection-refused +;;; &connection-timeout +;;; &dns-failure +;;; &tls-error +;;; &network-read-error +;;; &network-write-error +;;; &jerboa-db (databases) +;;; &db-connection-error +;;; &db-query-error +;;; &db-constraint-violation +;;; &db-timeout +;;; &jerboa-actor (actor system) +;;; &actor-dead +;;; &mailbox-full +;;; &supervision-failure +;;; &actor-timeout +;;; &jerboa-resource (resource management) +;;; &resource-leak +;;; &resource-already-closed +;;; &resource-exhausted +;;; &jerboa-timeout (generic timeout) +;;; &jerboa-serialization (FASL / serialization) +;;; &unsafe-deserialize +;;; &serialize-size-exceeded +;;; &jerboa-parse (parsers: JSON, XML, CSV, etc.) +;;; &parse-depth-exceeded +;;; &parse-size-exceeded +;;; &parse-invalid-input + +(library (std error conditions) + (export + ;; Root + &jerboa make-jerboa-condition jerboa-condition? + jerboa-condition-subsystem + + ;; Network + &jerboa-network make-network-error network-error? + network-error-address network-error-port-number + + &connection-refused make-connection-refused connection-refused? + &connection-timeout make-connection-timeout connection-timeout? + connection-timeout-seconds + &dns-failure make-dns-failure dns-failure? + dns-failure-hostname + &tls-error make-tls-error tls-error? + tls-error-reason + &network-read-error make-network-read-error network-read-error? + &network-write-error make-network-write-error network-write-error? + + ;; Database + &jerboa-db make-db-error db-error? + db-error-backend + + &db-connection-error make-db-connection-error db-connection-error? + &db-query-error make-db-query-error db-query-error? + db-query-error-sql + &db-constraint-violation make-db-constraint-violation db-constraint-violation? + db-constraint-violation-constraint + &db-timeout make-db-timeout db-timeout? + db-timeout-seconds + + ;; Actor + &jerboa-actor make-actor-error actor-error? + actor-error-actor-id + + &actor-dead make-actor-dead actor-dead? + &mailbox-full make-mailbox-full mailbox-full? + mailbox-full-capacity + &supervision-failure make-supervision-failure supervision-failure? + supervision-failure-child-id supervision-failure-reason + &actor-timeout make-actor-timeout actor-timeout? + actor-timeout-seconds + + ;; Resource + &jerboa-resource make-resource-error resource-error? + resource-error-resource-type + + &resource-leak make-resource-leak resource-leak? + &resource-already-closed make-resource-already-closed resource-already-closed? + &resource-exhausted make-resource-exhausted resource-exhausted? + resource-exhausted-limit + + ;; Timeout (generic) + &jerboa-timeout make-timeout-error timeout-error? + timeout-error-seconds timeout-error-operation + + ;; Serialization + &jerboa-serialization make-serialization-error serialization-error? + + &unsafe-deserialize make-unsafe-deserialize unsafe-deserialize? + unsafe-deserialize-type-name + &serialize-size-exceeded make-serialize-size-exceeded serialize-size-exceeded? + serialize-size-exceeded-limit serialize-size-exceeded-actual + + ;; Parse + &jerboa-parse make-parse-error parse-error? + parse-error-format + + &parse-depth-exceeded make-parse-depth-exceeded parse-depth-exceeded? + parse-depth-exceeded-limit parse-depth-exceeded-actual + &parse-size-exceeded make-parse-size-exceeded parse-size-exceeded? + parse-size-exceeded-limit parse-size-exceeded-actual + &parse-invalid-input make-parse-invalid-input parse-invalid-input? + parse-invalid-input-position + + ;; Helpers + raise-network-error + raise-db-error + raise-timeout-error + raise-parse-error) + + (import (chezscheme)) + + ;; ========================================================================= + ;; Root condition + ;; ========================================================================= + + (define-condition-type &jerboa &serious + make-jerboa-condition jerboa-condition? + (subsystem jerboa-condition-subsystem)) ;; symbol: 'network, 'db, 'actor, etc. + + ;; ========================================================================= + ;; Network conditions + ;; ========================================================================= + + (define-condition-type &jerboa-network &jerboa + make-network-error network-error? + (address network-error-address) ;; string or #f + (port-number network-error-port-number)) ;; integer or #f + + (define-condition-type &connection-refused &jerboa-network + make-connection-refused connection-refused?) + + (define-condition-type &connection-timeout &jerboa-network + make-connection-timeout connection-timeout? + (seconds connection-timeout-seconds)) + + (define-condition-type &dns-failure &jerboa-network + make-dns-failure dns-failure? + (hostname dns-failure-hostname)) + + (define-condition-type &tls-error &jerboa-network + make-tls-error tls-error? + (reason tls-error-reason)) + + (define-condition-type &network-read-error &jerboa-network + make-network-read-error network-read-error?) + + (define-condition-type &network-write-error &jerboa-network + make-network-write-error network-write-error?) + + ;; ========================================================================= + ;; Database conditions + ;; ========================================================================= + + (define-condition-type &jerboa-db &jerboa + make-db-error db-error? + (backend db-error-backend)) ;; symbol: 'sqlite, 'postgresql, 'leveldb + + (define-condition-type &db-connection-error &jerboa-db + make-db-connection-error db-connection-error?) + + (define-condition-type &db-query-error &jerboa-db + make-db-query-error db-query-error? + (sql db-query-error-sql)) + + (define-condition-type &db-constraint-violation &jerboa-db + make-db-constraint-violation db-constraint-violation? + (constraint db-constraint-violation-constraint)) + + (define-condition-type &db-timeout &jerboa-db + make-db-timeout db-timeout? + (seconds db-timeout-seconds)) + + ;; ========================================================================= + ;; Actor conditions + ;; ========================================================================= + + (define-condition-type &jerboa-actor &jerboa + make-actor-error actor-error? + (actor-id actor-error-actor-id)) ;; integer or #f + + (define-condition-type &actor-dead &jerboa-actor + make-actor-dead actor-dead?) + + (define-condition-type &mailbox-full &jerboa-actor + make-mailbox-full mailbox-full? + (capacity mailbox-full-capacity)) + + (define-condition-type &supervision-failure &jerboa-actor + make-supervision-failure supervision-failure? + (child-id supervision-failure-child-id) + (reason supervision-failure-reason)) + + (define-condition-type &actor-timeout &jerboa-actor + make-actor-timeout actor-timeout? + (seconds actor-timeout-seconds)) + + ;; ========================================================================= + ;; Resource conditions + ;; ========================================================================= + + (define-condition-type &jerboa-resource &jerboa + make-resource-error resource-error? + (resource-type resource-error-resource-type)) ;; symbol: 'file, 'socket, 'db, etc. + + (define-condition-type &resource-leak &jerboa-resource + make-resource-leak resource-leak?) + + (define-condition-type &resource-already-closed &jerboa-resource + make-resource-already-closed resource-already-closed?) + + (define-condition-type &resource-exhausted &jerboa-resource + make-resource-exhausted resource-exhausted? + (limit resource-exhausted-limit)) + + ;; ========================================================================= + ;; Timeout (generic, for any subsystem) + ;; ========================================================================= + + (define-condition-type &jerboa-timeout &jerboa + make-timeout-error timeout-error? + (seconds timeout-error-seconds) + (operation timeout-error-operation)) ;; symbol: 'tcp-read, 'db-query, etc. + + ;; ========================================================================= + ;; Serialization conditions + ;; ========================================================================= + + (define-condition-type &jerboa-serialization &jerboa + make-serialization-error serialization-error?) + + (define-condition-type &unsafe-deserialize &jerboa-serialization + make-unsafe-deserialize unsafe-deserialize? + (type-name unsafe-deserialize-type-name)) + + (define-condition-type &serialize-size-exceeded &jerboa-serialization + make-serialize-size-exceeded serialize-size-exceeded? + (limit serialize-size-exceeded-limit) + (actual serialize-size-exceeded-actual)) + + ;; ========================================================================= + ;; Parse conditions + ;; ========================================================================= + + (define-condition-type &jerboa-parse &jerboa + make-parse-error parse-error? + (format parse-error-format)) ;; symbol: 'json, 'xml, 'csv, 'fasl + + (define-condition-type &parse-depth-exceeded &jerboa-parse + make-parse-depth-exceeded parse-depth-exceeded? + (limit parse-depth-exceeded-limit) + (actual parse-depth-exceeded-actual)) + + (define-condition-type &parse-size-exceeded &jerboa-parse + make-parse-size-exceeded parse-size-exceeded? + (limit parse-size-exceeded-limit) + (actual parse-size-exceeded-actual)) + + (define-condition-type &parse-invalid-input &jerboa-parse + make-parse-invalid-input parse-invalid-input? + (position parse-invalid-input-position)) ;; integer offset or #f + + ;; ========================================================================= + ;; Convenience raisers — compound conditions with message + ;; ========================================================================= + + (define (raise-network-error type msg . args) + ;; type is one of the make-* constructors for network subtypes + ;; For simple cases, use make-network-error directly + (raise (condition + (make-network-error 'network #f #f) + (make-message-condition (apply format #f msg args))))) + + (define (raise-db-error backend msg . args) + (raise (condition + (make-db-error 'db backend) + (make-message-condition (apply format #f msg args))))) + + (define (raise-timeout-error seconds operation msg . args) + (raise (condition + (make-timeout-error 'timeout seconds operation) + (make-message-condition (apply format #f msg args))))) + + (define (raise-parse-error fmt msg . args) + (raise (condition + (make-parse-error 'parse fmt) + (make-message-condition (apply format #f msg args))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/error/context.sls @@ -0,0 +1,114 @@ +#!chezscheme +;;; (std error context) — Error context accumulation +;;; +;;; Automatically accumulates breadcrumb context for error messages. +;;; When an error occurs inside nested with-context forms, the full +;;; context chain is included in the error message. +;;; +;;; Usage: +;;; (with-context "processing request #1234" +;;; (with-context "validating input" +;;; (check-argument string? input 'validate))) +;;; ;; Error includes: "processing request #1234 > validating input > ..." +;;; +;;; (with-context* ('request-handler "POST /api/users" user-id: 42) +;;; ...) ;; structured context with metadata + +(library (std error context) + (export + with-context + with-context* + current-context + context->string + context->list + raise-in-context + &context-condition make-context-condition context-condition? + context-condition-chain) + + (import (chezscheme)) + + ;; ========================================================================= + ;; Context chain — thread-local stack of context strings + ;; ========================================================================= + + (define *context-stack* (make-thread-parameter '())) + + (define (current-context) + ;; Returns the current context stack as a list of strings (outermost first). + (reverse (*context-stack*))) + + (define (context->string) + ;; Format the current context chain as "a > b > c". + (let ([ctx (current-context)]) + (if (null? ctx) + "" + (let loop ([parts ctx] [acc ""]) + (cond + [(null? parts) acc] + [(string=? acc "") (loop (cdr parts) (car parts))] + [else (loop (cdr parts) + (string-append acc " > " (car parts)))]))))) + + (define (context->list) + ;; Returns context as a list of strings (outermost first). + (current-context)) + + ;; ========================================================================= + ;; Condition type for context + ;; ========================================================================= + + (define-condition-type &context-condition &condition + make-context-condition context-condition? + (chain context-condition-chain)) ;; list of strings + + ;; ========================================================================= + ;; with-context — push a context string for the dynamic extent of body + ;; ========================================================================= + + (define-syntax with-context + (syntax-rules () + [(_ label body ...) + (parameterize ([*context-stack* (cons label (*context-stack*))]) + (with-exception-handler + (lambda (exn) + ;; Re-raise with context attached if not already present + (if (and (condition? exn) (context-condition? exn)) + (raise exn) + (let* ([ctx-str (context->string)] + [orig-msg (cond + [(and (condition? exn) (message-condition? exn)) + (condition-message exn)] + [(string? exn) exn] + [else (format #f "~a" exn)])] + [new-msg (string-append ctx-str " > " orig-msg)]) + (raise (condition + (make-context-condition (current-context)) + (make-message-condition new-msg)))))) + (lambda () body ...)))])) + + ;; ========================================================================= + ;; with-context* — structured context with key-value metadata + ;; ========================================================================= + + (define-syntax with-context* + (syntax-rules () + [(_ (tag description kv ...) body ...) + (let ([label (format #f "~a: ~a" 'tag description)]) + (with-context label body ...))])) + + ;; ========================================================================= + ;; raise-in-context — raise an error with current context included + ;; ========================================================================= + + (define (raise-in-context who msg . args) + (let ([ctx (context->string)] + [formatted (apply format #f msg args)]) + (raise (condition + (make-who-condition who) + (make-message-condition + (if (string=? ctx "") + formatted + (string-append ctx " > " formatted))) + (make-context-condition (current-context)))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/immutable.sls @@ -0,0 +1,149 @@ +#!chezscheme +;;; (std immutable) — Immutable-by-default data structures +;;; +;;; Re-exports persistent map and vector as the primary data structure API. +;;; Functional updates return new values; originals are never mutated. +;;; This prevents accidental mutation bugs in Claude-generated code. +;;; +;;; Usage: +;;; (import (std immutable)) +;;; +;;; ;; Immutable hash map (HAMT) +;;; (define m (imap "name" "Alice" "age" 30)) +;;; (define m2 (imap-set m "age" 31)) ;; m unchanged, m2 has age=31 +;;; (imap-ref m "name") ;; => "Alice" +;;; +;;; ;; Immutable vector (persistent trie) +;;; (define v (ivec 1 2 3)) +;;; (define v2 (ivec-set v 0 99)) ;; v unchanged, v2 = #(99 2 3) +;;; (define v3 (ivec-append v 4)) ;; v3 = #(1 2 3 4) + +(library (std immutable) + (export + ;; Immutable map (pmap wrappers with short names) + imap + imap-empty + imap? + imap-ref + imap-has? + imap-set + imap-delete + imap-size + imap->alist + imap-keys + imap-values + imap-for-each + imap-map + imap-fold + imap-filter + imap-merge + + ;; Immutable vector (pvec wrappers with short names) + ivec + ivec-empty + ivec? + ivec-ref + ivec-set + ivec-append + ivec-length + ivec->list + ivec-for-each + ivec-map + ivec-fold + ivec-filter + ivec-concat + ivec-slice + + ;; Conversion from mutable + hashtable->imap + vector->ivec + list->ivec + + ;; Re-export full APIs for advanced use + persistent-map? + persistent-vector?) + + (import (chezscheme) + (std pmap) + (std pvec)) + + ;; ========================================================================= + ;; Immutable Map — short aliases for persistent-map + ;; ========================================================================= + + (define imap-empty pmap-empty) + + (define imap? persistent-map?) + + (define (imap . kvs) + ;; Construct from alternating key/value pairs: + ;; (imap "a" 1 "b" 2) => {"a": 1, "b": 2} + (let loop ([pairs kvs] [m imap-empty]) + (cond + [(null? pairs) m] + [(null? (cdr pairs)) + (error 'imap "odd number of arguments — expected key/value pairs")] + [else + (loop (cddr pairs) + (persistent-map-set m (car pairs) (cadr pairs)))]))) + + (define (imap-ref m key . default) + (if (null? default) + (persistent-map-ref m key) + (persistent-map-ref m key (car default)))) + + (define imap-has? persistent-map-has?) + (define imap-set persistent-map-set) + (define imap-delete persistent-map-delete) + (define imap-size persistent-map-size) + (define imap->alist persistent-map->list) + (define imap-keys persistent-map-keys) + (define imap-values persistent-map-values) + (define imap-for-each persistent-map-for-each) + (define imap-map persistent-map-map) + (define imap-fold persistent-map-fold) + (define imap-filter persistent-map-filter) + (define imap-merge persistent-map-merge) + + (define (hashtable->imap ht) + ;; Convert a mutable hashtable to an immutable map. + (let-values ([(keys vals) (hashtable-entries ht)]) + (let loop ([i 0] [m imap-empty]) + (if (fx= i (vector-length keys)) + m + (loop (fx+ i 1) + (persistent-map-set m + (vector-ref keys i) + (vector-ref vals i))))))) + + ;; ========================================================================= + ;; Immutable Vector — short aliases for persistent-vector + ;; ========================================================================= + + (define ivec-empty pvec-empty) + + (define ivec? persistent-vector?) + + (define (ivec . items) + ;; Construct from arguments: (ivec 1 2 3) + (list->persistent-vector items)) + + (define ivec-ref persistent-vector-ref) + (define ivec-set persistent-vector-set) + (define ivec-append persistent-vector-append) + (define ivec-length persistent-vector-length) + (define ivec->list persistent-vector->list) + (define ivec-for-each persistent-vector-for-each) + (define ivec-map persistent-vector-map) + (define ivec-fold persistent-vector-fold) + (define ivec-filter persistent-vector-filter) + (define ivec-concat persistent-vector-concat) + (define ivec-slice persistent-vector-slice) + + (define (vector->ivec vec) + ;; Convert a mutable vector to an immutable vector. + (list->persistent-vector (vector->list vec))) + + (define list->ivec list->persistent-vector) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/resource.sls @@ -0,0 +1,135 @@ +#!chezscheme +;;; (std resource) — RAII-style resource management +;;; +;;; Guarantees cleanup of resources even on exceptions. +;;; Auto-detects cleanup procedures for common resource types. +;;; +;;; Usage: +;;; (with-resource ([db (sqlite-open "test.db")] +;;; [sock (tcp-connect "localhost" 8080)] +;;; [f (open-input-file "data.txt")]) +;;; (sqlite-exec db "SELECT 1") +;;; (tcp-write-string sock "hello")) +;;; ;; All three resources guaranteed closed here +;;; +;;; ;; Explicit cleanup: +;;; (with-resource ([buf (make-bytevector 4096) (lambda (b) (bytevector-fill! b 0))]) +;;; (use buf)) +;;; +;;; ;; Single resource shorthand: +;;; (with-resource1 (db (sqlite-open "test.db")) +;;; (sqlite-exec db "SELECT 1")) + +(library (std resource) + (export + with-resource + with-resource1 + register-resource-cleanup! + call-with-resource) + + (import (chezscheme)) + + ;; ========================================================================= + ;; Cleanup registry — maps type predicates to cleanup procedures + ;; ========================================================================= + + (define *cleanup-registry* '()) + (define *registry-mutex* (make-mutex)) + + (define (register-resource-cleanup! pred cleanup) + ;; Register a cleanup procedure for resources matching pred. + ;; pred: (lambda (obj) boolean?) + ;; cleanup: (lambda (obj) void) + (with-mutex *registry-mutex* + (set! *cleanup-registry* + (cons (cons pred cleanup) *cleanup-registry*)))) + + ;; Built-in cleanups for common types + (define (auto-cleanup resource) + ;; Returns a cleanup thunk for the resource, or a no-op if unknown. + (cond + ;; Ports (files, string ports, transcoded ports) + [(port? resource) + (lambda () + (when (not (port-closed? resource)) + (when (output-port? resource) + (flush-output-port resource)) + (close-port resource)))] + ;; Check registered cleanups + [(find-registered-cleanup resource) + => (lambda (cleanup) + (lambda () (cleanup resource)))] + ;; Unknown — no-op (user should provide explicit cleanup) + [else (lambda () (void))])) + + (define (find-registered-cleanup resource) + (let loop ([registry *cleanup-registry*]) + (cond + [(null? registry) #f] + [((caar registry) resource) (cdar registry)] + [else (loop (cdr registry))]))) + + ;; ========================================================================= + ;; Core: call-with-resource (procedural API) + ;; ========================================================================= + + (define (call-with-resource acquire cleanup body) + ;; acquire: thunk that returns a resource + ;; cleanup: (lambda (resource) ...) or #f for auto-detect + ;; body: (lambda (resource) ...) + (let ([resource (acquire)]) + (let ([do-cleanup + (if cleanup + (lambda () (cleanup resource)) + (auto-cleanup resource))]) + (dynamic-wind + (lambda () (void)) + (lambda () (body resource)) + do-cleanup)))) + + ;; ========================================================================= + ;; with-resource1 — single resource binding + ;; ========================================================================= + + (define-syntax with-resource1 + (syntax-rules () + ;; With explicit cleanup + [(_ (var init cleanup) body ...) + (let ([var init]) + (dynamic-wind + (lambda () (void)) + (lambda () body ...) + (lambda () (cleanup var))))] + ;; Auto-detect cleanup + [(_ (var init) body ...) + (let ([resource init]) + (let ([do-cleanup (auto-cleanup resource)]) + (let ([var resource]) + (dynamic-wind + (lambda () (void)) + (lambda () body ...) + do-cleanup))))])) + + ;; ========================================================================= + ;; with-resource — multiple resource bindings (nested cleanup) + ;; ========================================================================= + ;; + ;; Each binding is (var init) or (var init cleanup-proc). + ;; Resources are acquired left-to-right, cleaned up right-to-left. + ;; If acquisition of resource N fails, resources 0..N-1 are still cleaned up. + + (define-syntax with-resource + (syntax-rules () + ;; Base case: no more bindings + [(_ () body ...) + (begin body ...)] + ;; Binding with explicit cleanup