Migrate 40 more .sls with custom accessor names
ober
670bf152f3d25cfadca7be1733a22db1db30f3b6
deleted file mode 100644 --- a/lib/jerboa/cross.sls +++ /dev/null @@ -1,159 +0,0 @@ -#!chezscheme -;;; (jerboa cross) — Cross-Compilation Utilities -;;; -;;; Target OS/arch config, ABI info, and C compiler flag generation. - -(library (jerboa cross) - (export - make-cross-config cross-config? - cross-config-target-os cross-config-target-arch - cross-config-sysroot cross-config-cc cross-config-cflags - target-os-linux? target-os-macos? target-os-windows? - target-arch-x86-64? target-arch-aarch64? target-arch-riscv64? - detect-host-config cross-config-valid? - cc-flags-for-target abi-name endianness-for-target - pointer-size-for-target platform-string normalize-path-sep) - - (import (chezscheme)) - - ;; ========== String search helper ========== - (define (string-has-substring? str sub) - ;; Returns #t if sub appears anywhere in str. - (let ([slen (string-length str)] - [sublen (string-length sub)]) - (if (> sublen slen) - #f - (let loop ([i 0]) - (cond - [(> (+ i sublen) slen) #f] - [(let check ([j 0]) - (cond - [(= j sublen) #t] - [(char=? (string-ref str (+ i j)) (string-ref sub j)) - (check (+ j 1))] - [else #f])) - #t] - [else (loop (+ i 1))]))))) - - ;; ========== Cross Config ========== - - (define-record-type (%cross-config make-cross-config cross-config?) - (fields (immutable target-os cross-config-target-os) ;; symbol: linux macos windows - (immutable target-arch cross-config-target-arch) ;; symbol: x86-64 aarch64 riscv64 - (immutable sysroot cross-config-sysroot) ;; string path or #f - (immutable cc cross-config-cc) ;; string path to C compiler - (immutable cflags cross-config-cflags))) ;; list of strings - - ;; ========== Predicates ========== - - (define (target-os-linux? cfg) (eq? (cross-config-target-os cfg) 'linux)) - (define (target-os-macos? cfg) (eq? (cross-config-target-os cfg) 'macos)) - (define (target-os-windows? cfg) (eq? (cross-config-target-os cfg) 'windows)) - - (define (target-arch-x86-64? cfg) (eq? (cross-config-target-arch cfg) 'x86-64)) - (define (target-arch-aarch64? cfg) (eq? (cross-config-target-arch cfg) 'aarch64)) - (define (target-arch-riscv64? cfg) (eq? (cross-config-target-arch cfg) 'riscv64)) - - ;; ========== Host Detection ========== - - (define (machine-type->os mt) - ;; Detect OS from Chez machine-type symbol. - ;; e.g., a6le = x86-64 linux, ta6osx = x86-64 macos threaded - (let ([s (symbol->string mt)]) - (cond - [(or (string-has-substring? s "le") - (string-has-substring? s "l3")) 'linux] - [(or (string-has-substring? s "osx") - (string-has-substring? s "darwin")) 'macos] - [(or (string-has-substring? s "nt") - (string-has-substring? s "win")) 'windows] - [else 'linux]))) ;; default - - (define (machine-type->arch mt) - ;; Detect arch from Chez machine-type symbol. - ;; a6 = x86-64, arm64 = aarch64, rv = riscv64 - (let ([s (symbol->string mt)]) - (cond - [(string-has-substring? s "arm64") 'aarch64] - [(string-has-substring? s "arm") 'aarch64] - [(string-has-substring? s "a6") 'x86-64] - [(string-has-substring? s "rv") 'riscv64] - [(string-has-substring? s "i3") 'x86-64] ;; treat i386 as x86-64 for simplicity - [else 'x86-64]))) ;; default - - (define (detect-host-config) - ;; Return a cross-config for the current host. - (let* ([mt (machine-type)] - [os (machine-type->os mt)] - [arch (machine-type->arch mt)]) - (make-cross-config os arch #f "cc" '()))) - - ;; ========== Validation ========== - - (define (cross-config-valid? cfg) - ;; Check that OS and arch are known values. - (and (member (cross-config-target-os cfg) '(linux macos windows)) - (member (cross-config-target-arch cfg) '(x86-64 aarch64 riscv64)) - #t)) - - ;; ========== Compiler Flags ========== - - (define (cc-flags-for-target cfg) - ;; Generate GCC/Clang cross-compilation flags. - (let ([os (cross-config-target-os cfg)] - [arch (cross-config-target-arch cfg)] - [sr (cross-config-sysroot cfg)] - [extra (cross-config-cflags cfg)]) - (let* ([triple (abi-name cfg)] - [base (list (string-append "--target=" triple))]) - (append - base - (if sr (list (string-append "--sysroot=" sr)) '()) - extra)))) - - ;; ========== ABI / Platform Info ========== - - (define (abi-name cfg) - ;; Returns GNU/LLVM target triple string. - (let ([os (cross-config-target-os cfg)] - [arch (cross-config-target-arch cfg)]) - (let ([arch-str (case arch - [(x86-64) "x86_64"] - [(aarch64) "aarch64"] - [(riscv64) "riscv64"] - [else (symbol->string arch)])] - [os-str (case os - [(linux) "linux-gnu"] - [(macos) "apple-darwin"] - [(windows) "w64-mingw32"] - [else (symbol->string os)])]) - (string-append arch-str "-" os-str)))) - - (define (endianness-for-target cfg) - ;; Returns 'little or 'big. - ;; All currently supported arches are little-endian. - (case (cross-config-target-arch cfg) - [(x86-64 aarch64 riscv64) 'little] - [else 'little])) - - (define (pointer-size-for-target cfg) - ;; Returns 4 or 8. - (case (cross-config-target-arch cfg) - [(x86-64 aarch64 riscv64) 8] - [else 8])) - - (define (platform-string cfg) - ;; Human-readable platform description. - (let ([os (cross-config-target-os cfg)] - [arch (cross-config-target-arch cfg)]) - (format "~a/~a" arch os))) - - (define (normalize-path-sep path cfg) - ;; Convert / to \\ on Windows targets. - (if (target-os-windows? cfg) - (list->string - (map (lambda (c) (if (char=? c #\/) #\\ c)) - (string->list path))) - path)) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/cross.ss @@ -0,0 +1,162 @@ +#!chezscheme +;;; (jerboa cross) — Cross-Compilation Utilities +;;; +;;; Target OS/arch config, ABI info, and C compiler flag generation. + +(library (jerboa cross) + (export + make-cross-config cross-config? + cross-config-target-os cross-config-target-arch + cross-config-sysroot cross-config-cc cross-config-cflags + target-os-linux? target-os-macos? target-os-windows? + target-arch-x86-64? target-arch-aarch64? target-arch-riscv64? + detect-host-config cross-config-valid? + cc-flags-for-target abi-name endianness-for-target + pointer-size-for-target platform-string normalize-path-sep) + + (import (chezscheme) + (only (jerboa core) def defstruct)) + + ;; ========== String search helper ========== + (def (string-has-substring? str sub) + ;; Returns #t if sub appears anywhere in str. + (let ([slen (string-length str)] + [sublen (string-length sub)]) + (if (> sublen slen) + #f + (let loop ([i 0]) + (cond + [(> (+ i sublen) slen) #f] + [(let check ([j 0]) + (cond + [(= j sublen) #t] + [(char=? (string-ref str (+ i j)) (string-ref sub j)) + (check (+ j 1))] + [else #f])) + #t] + [else (loop (+ i 1))]))))) + + ;; ========== Cross Config ========== + + (defstruct %cross-config (target-os target-arch sysroot cc cflags)) + (def make-cross-config make-%cross-config) + (def cross-config? %cross-config?) + (def cross-config-target-os %cross-config-target-os) + (def cross-config-target-arch %cross-config-target-arch) + (def cross-config-sysroot %cross-config-sysroot) + (def cross-config-cc %cross-config-cc) + (def cross-config-cflags %cross-config-cflags) ;; list of strings + + ;; ========== Predicates ========== + + (def (target-os-linux? cfg) (eq? (cross-config-target-os cfg) 'linux)) + (def (target-os-macos? cfg) (eq? (cross-config-target-os cfg) 'macos)) + (def (target-os-windows? cfg) (eq? (cross-config-target-os cfg) 'windows)) + + (def (target-arch-x86-64? cfg) (eq? (cross-config-target-arch cfg) 'x86-64)) + (def (target-arch-aarch64? cfg) (eq? (cross-config-target-arch cfg) 'aarch64)) + (def (target-arch-riscv64? cfg) (eq? (cross-config-target-arch cfg) 'riscv64)) + + ;; ========== Host Detection ========== + + (def (machine-type->os mt) + ;; Detect OS from Chez machine-type symbol. + ;; e.g., a6le = x86-64 linux, ta6osx = x86-64 macos threaded + (let ([s (symbol->string mt)]) + (cond + [(or (string-has-substring? s "le") + (string-has-substring? s "l3")) 'linux] + [(or (string-has-substring? s "osx") + (string-has-substring? s "darwin")) 'macos] + [(or (string-has-substring? s "nt") + (string-has-substring? s "win")) 'windows] + [else 'linux]))) ;; default + + (def (machine-type->arch mt) + ;; Detect arch from Chez machine-type symbol. + ;; a6 = x86-64, arm64 = aarch64, rv = riscv64 + (let ([s (symbol->string mt)]) + (cond + [(string-has-substring? s "arm64") 'aarch64] + [(string-has-substring? s "arm") 'aarch64] + [(string-has-substring? s "a6") 'x86-64] + [(string-has-substring? s "rv") 'riscv64] + [(string-has-substring? s "i3") 'x86-64] ;; treat i386 as x86-64 for simplicity + [else 'x86-64]))) ;; default + + (def (detect-host-config) + ;; Return a cross-config for the current host. + (let* ([mt (machine-type)] + [os (machine-type->os mt)] + [arch (machine-type->arch mt)]) + (make-cross-config os arch #f "cc" '()))) + + ;; ========== Validation ========== + + (def (cross-config-valid? cfg) + ;; Check that OS and arch are known values. + (and (member (cross-config-target-os cfg) '(linux macos windows)) + (member (cross-config-target-arch cfg) '(x86-64 aarch64 riscv64)) + #t)) + + ;; ========== Compiler Flags ========== + + (def (cc-flags-for-target cfg) + ;; Generate GCC/Clang cross-compilation flags. + (let ([os (cross-config-target-os cfg)] + [arch (cross-config-target-arch cfg)] + [sr (cross-config-sysroot cfg)] + [extra (cross-config-cflags cfg)]) + (let* ([triple (abi-name cfg)] + [base (list (string-append "--target=" triple))]) + (append + base + (if sr (list (string-append "--sysroot=" sr)) '()) + extra)))) + + ;; ========== ABI / Platform Info ========== + + (def (abi-name cfg) + ;; Returns GNU/LLVM target triple string. + (let ([os (cross-config-target-os cfg)] + [arch (cross-config-target-arch cfg)]) + (let ([arch-str (case arch + [(x86-64) "x86_64"] + [(aarch64) "aarch64"] + [(riscv64) "riscv64"] + [else (symbol->string arch)])] + [os-str (case os + [(linux) "linux-gnu"] + [(macos) "apple-darwin"] + [(windows) "w64-mingw32"] + [else (symbol->string os)])]) + (string-append arch-str "-" os-str)))) + + (def (endianness-for-target cfg) + ;; Returns 'little or 'big. + ;; All currently supported arches are little-endian. + (case (cross-config-target-arch cfg) + [(x86-64 aarch64 riscv64) 'little] + [else 'little])) + + (def (pointer-size-for-target cfg) + ;; Returns 4 or 8. + (case (cross-config-target-arch cfg) + [(x86-64 aarch64 riscv64) 8] + [else 8])) + + (def (platform-string cfg) + ;; Human-readable platform description. + (let ([os (cross-config-target-os cfg)] + [arch (cross-config-target-arch cfg)]) + (format "~a/~a" arch os))) + + (def (normalize-path-sep path cfg) + ;; Convert / to \\ on Windows targets. + (if (target-os-windows? cfg) + (list->string + (map (lambda (c) (if (char=? c #\/) #\\ c)) + (string->list path))) + path)) + +) ;; end library deleted file mode 100644 --- a/lib/jerboa/embed.sls +++ /dev/null @@ -1,190 +0,0 @@ -#!chezscheme -;;; (jerboa embed) — Embeddable Runtime / Sandbox API -;;; -;;; Isolated evaluation environments using Chez Scheme's environment system. - -(library (jerboa embed) - (export - make-sandbox sandbox? sandbox-eval sandbox-eval-string - sandbox-define! sandbox-ref sandbox-call sandbox-environment - sandbox-error? sandbox-error-message sandbox-error-irritants - sandbox-reset! sandbox-import! - make-sandbox-config sandbox-config? - with-sandbox) - - (import (chezscheme) - (std security restrict) - (jerboa reader)) - - ;; ========== Sandbox Config ========== - - (define-record-type (%sandbox-config make-sandbox-config sandbox-config?) - (fields (immutable max-eval-time sandbox-config-max-eval-time) ;; ms or #f - (immutable allowed-imports sandbox-config-allowed-imports) ;; list or #f (all) - (immutable capture-output sandbox-config-capture-output))) ;; #t/#f - - ;; ========== Sandbox Error ========== - - (define-record-type (%sandbox-error make-sandbox-error sandbox-error?) - (fields (immutable message sandbox-error-message) - (immutable irritants sandbox-error-irritants))) - - ;; When error is called as (error "msg" irritants...) inside eval, - ;; Chez may set the message to an internal format string and put - ;; the actual message in the irritants list. - ;; Pattern: msg = "invalid message argument ~s (who = ~s, irritants = ~s)" - ;; irritants = (first-irritant "msg" (rest-irritants...)) - (define (exn->sandbox-error exn) - (cond - [(message-condition? exn) - (let ([msg (condition-message exn)] - [irrs (if (irritants-condition? exn) (condition-irritants exn) '())]) - ;; Detect the "invalid message argument" pattern from eval context. - ;; Guard with length checks before any list-ref access. - (if (and (string? msg) - (>= (string-length msg) 24) - (string=? (substring msg 0 24) "invalid message argument") - (list? irrs) - (>= (length irrs) 3) - (string? (list-ref irrs 1))) - ;; irritants = (first-arg "real-msg" (rest-args...)) - ;; Extract real message and irritants from the encoded form - (make-sandbox-error - (list-ref irrs 1) - (let ([rest (list-ref irrs 2)]) - (if (and (list? rest) (not (null? irrs))) - (cons (car irrs) rest) - (list (car irrs))))) - (make-sandbox-error msg irrs)))] - [(string? exn) - (make-sandbox-error exn '())] - [else - (make-sandbox-error (format "~a" exn) '())])) - - ;; ========== Sandbox ========== - - ;; env: Chez environment (interaction-environment copy) - ;; config: sandbox-config or #f - ;; user-bindings: hashtable of name -> value (user definitions) - - (define-record-type (%sandbox make-sandbox-raw sandbox?) - (fields (mutable env sandbox-environment sandbox-environment-set!) - (mutable user-bindings sandbox-user-bindings sandbox-user-bindings-set!) - (immutable config sandbox-config-field))) - - (define (make-sandbox . args) - ;; Optional config as first arg. - ;; HARDENED: Defaults to restricted environment (allowlist-only). - ;; Use (copy-environment (interaction-environment) #t) only if you - ;; explicitly need full access — never for untrusted code. - (let ([config (if (and (pair? args) (sandbox-config? (car args))) - (car args) - #f)]) - (make-sandbox-raw - (make-restricted-environment) - (make-hashtable equal-hash equal?) - config))) - - ;; Internal: run thunk with max-eval-time enforcement if configured. - (define (%with-time-limit sb thunk) - (let ([config (sandbox-config-field sb)]) - (if (and config (sandbox-config-max-eval-time config)) - (let ([timeout-ms (sandbox-config-max-eval-time config)] - [result #f] - [finished? #f] - [lock (make-mutex)] - [cv (make-condition)]) - ;; Run in a worker thread - (fork-thread - (lambda () - (let ([val (guard (exn [#t (exn->sandbox-error exn)]) - (thunk))]) - (with-mutex lock - (set! result val) - (set! finished? #t) - (condition-signal cv))))) - ;; Wait with timeout (wall-clock via time-utc, not CPU time, - ;; so that blocked I/O operations are properly timed out) - (with-mutex lock - (unless finished? - (let loop () - (unless finished? - (condition-wait cv lock (make-time 'time-duration - (* timeout-ms 1000000) 0)) - (unless finished? - ;; Timed out - (void)))))) - (if finished? - result - (make-sandbox-error - (format "sandbox eval timed out after ~a ms" timeout-ms) '()))) - ;; No time limit configured — run directly - (guard (exn [#t (exn->sandbox-error exn)]) - (thunk))))) - - (define (sandbox-eval sb datum) - ;; Evaluate a datum in the sandbox. Returns result or sandbox-error. - (%with-time-limit sb - (lambda () (eval datum (sandbox-environment sb))))) - - (define (sandbox-eval-string sb str) - ;; Read and eval a string in the sandbox. - ;; HARDENED: Uses jerboa-read (depth-limited) instead of bare read. - ;; Both reading and evaluation are covered by the time limit, - ;; so pathological input (deeply nested structures) is bounded. - (%with-time-limit sb - (lambda () - (let ([port (open-input-string str)]) - (let loop ([last (if #f #f)]) - (let ([form (parameterize ([*max-read-depth* 200] - [*max-list-length* 100000]) - (jerboa-read port))]) - (if (eof-object? form) - last - (loop (eval form (sandbox-environment sb)))))))))) - - (define (sandbox-define! sb name val) - ;; Bind name (symbol) to val in the sandbox. - (hashtable-set! (sandbox-user-bindings sb) name val) - (eval `(define ,name ',val) (sandbox-environment sb))) - - (define (sandbox-ref sb name) - ;; Look up a binding in the sandbox. Returns value or raises error. - (guard (exn [#t (error 'sandbox-ref "unbound variable" name)]) - (eval name (sandbox-environment sb)))) - - (define (sandbox-call sb name . args) - ;; Call a procedure defined in the sandbox. - (guard (exn [#t (exn->sandbox-error exn)]) - (let ([proc (eval name (sandbox-environment sb))]) - (apply proc args)))) - - (define (sandbox-reset! sb) - ;; Clear user-defined bindings by creating a fresh environment. - ;; HARDENED: Uses restricted environment, consistent with make-sandbox. - (hashtable-clear! (sandbox-user-bindings sb)) - (sandbox-environment-set! sb - (make-restricted-environment))) - - (define (sandbox-import! sb lib-name) - ;; Import a library into the sandbox. - ;; lib-name: e.g., '(std log) or '(chezscheme) - ;; HARDENED: Enforces allowed-imports from sandbox config. - (let ([config (sandbox-config-field sb)]) - (when (and config (sandbox-config-allowed-imports config)) - (unless (member lib-name (sandbox-config-allowed-imports config)) - (raise (condition - (make-message-condition - (format "sandbox import denied: ~a is not in allowed-imports list" - lib-name)) - (make-irritants-condition (list lib-name))))))) - (guard (exn [#t (exn->sandbox-error exn)]) - (eval `(import ,lib-name) (sandbox-environment sb)))) - - (define-syntax with-sandbox - (syntax-rules () - [(_ sb body ...) - (let ([sb (make-sandbox)]) - body ...)])) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/embed.ss @@ -0,0 +1,199 @@ +#!chezscheme +;;; (jerboa embed) — Embeddable Runtime / Sandbox API +;;; +;;; Isolated evaluation environments using Chez Scheme's environment system. + +(library (jerboa embed) + (export + make-sandbox sandbox? sandbox-eval sandbox-eval-string + sandbox-define! sandbox-ref sandbox-call sandbox-environment + sandbox-error? sandbox-error-message sandbox-error-irritants + sandbox-reset! sandbox-import! + make-sandbox-config sandbox-config? + with-sandbox) + + (import (chezscheme) + (std security restrict) + (jerboa reader) + (only (jerboa core) def defstruct try catch finally)) + + ;; ========== Sandbox Config ========== + + (defstruct %sandbox-config (max-eval-time allowed-imports capture-output)) + (def make-sandbox-config make-%sandbox-config) + (def sandbox-config? %sandbox-config?) + (def sandbox-config-max-eval-time %sandbox-config-max-eval-time) + (def sandbox-config-allowed-imports %sandbox-config-allowed-imports) + (def sandbox-config-capture-output %sandbox-config-capture-output) ;; #t/#f + + ;; ========== Sandbox Error ========== + + (defstruct %sandbox-error (message irritants)) + (def make-sandbox-error make-%sandbox-error) + (def sandbox-error? %sandbox-error?) + (def sandbox-error-message %sandbox-error-message) + (def sandbox-error-irritants %sandbox-error-irritants) + + ;; When error is called as (error "msg" irritants...) inside eval, + ;; Chez may set the message to an internal format string and put + ;; the actual message in the irritants list. + ;; Pattern: msg = "invalid message argument ~s (who = ~s, irritants = ~s)" + ;; irritants = (first-irritant "msg" (rest-irritants...)) + (def (exn->sandbox-error exn) + (cond + [(message-condition? exn) + (let ([msg (condition-message exn)] + [irrs (if (irritants-condition? exn) (condition-irritants exn) '())]) + ;; Detect the "invalid message argument" pattern from eval context. + ;; Guard with length checks before any list-ref access. + (if (and (string? msg) + (>= (string-length msg) 24) + (string=? (substring msg 0 24) "invalid message argument") + (list? irrs) + (>= (length irrs) 3) + (string? (list-ref irrs 1))) + ;; irritants = (first-arg "real-msg" (rest-args...)) + ;; Extract real message and irritants from the encoded form + (make-sandbox-error + (list-ref irrs 1) + (let ([rest (list-ref irrs 2)]) + (if (and (list? rest) (not (null? irrs))) + (cons (car irrs) rest) + (list (car irrs))))) + (make-sandbox-error msg irrs)))] + [(string? exn) + (make-sandbox-error exn '())] + [else + (make-sandbox-error (format "~a" exn) '())])) + + ;; ========== Sandbox ========== + + ;; env: Chez environment (interaction-environment copy) + ;; config: sandbox-config or #f + ;; user-bindings: hashtable of name -> value (user definitions) + + (defstruct %sandbox (env user-bindings config)) + (def make-sandbox-raw make-%sandbox) + (def sandbox? %sandbox?) + (def sandbox-environment %sandbox-env) + (def sandbox-environment-set! %sandbox-env-set!) + (def sandbox-user-bindings %sandbox-user-bindings) + (def sandbox-user-bindings-set! %sandbox-user-bindings-set!) + (def sandbox-config-field %sandbox-config) + + (def (make-sandbox . args) + ;; Optional config as first arg. + ;; HARDENED: Defaults to restricted environment (allowlist-only). + ;; Use (copy-environment (interaction-environment) #t) only if you + ;; explicitly need full access — never for untrusted code. + (let ([config (if (and (pair? args) (sandbox-config? (car args))) + (car args) + #f)]) + (make-sandbox-raw + (make-restricted-environment) + (make-hashtable equal-hash equal?) + config))) + + ;; Internal: run thunk with max-eval-time enforcement if configured. + (def (%with-time-limit sb thunk) + (let ([config (sandbox-config-field sb)]) + (if (and config (sandbox-config-max-eval-time config)) + (let ([timeout-ms (sandbox-config-max-eval-time config)] + [result #f] + [finished? #f] + [lock (make-mutex)] + [cv (make-condition)]) + ;; Run in a worker thread + (fork-thread + (lambda () + (let ([val (try (thunk) + (catch (exn) (exn->sandbox-error exn)))]) + (with-mutex lock + (set! result val) + (set! finished? #t) + (condition-signal cv))))) + ;; Wait with timeout (wall-clock via time-utc, not CPU time, + ;; so that blocked I/O operations are properly timed out) + (with-mutex lock + (unless finished? + (let loop () + (unless finished? + (condition-wait cv lock (make-time 'time-duration + (* timeout-ms 1000000) 0)) + (unless finished? + ;; Timed out + (void)))))) + (if finished? + result + (make-sandbox-error + (format "sandbox eval timed out after ~a ms" timeout-ms) '()))) + ;; No time limit configured — run directly + (try (thunk) + (catch (exn) (exn->sandbox-error exn)))))) + + (def (sandbox-eval sb datum) + ;; Evaluate a datum in the sandbox. Returns result or sandbox-error. + (%with-time-limit sb + (lambda () (eval datum (sandbox-environment sb))))) + + (def (sandbox-eval-string sb str) + ;; Read and eval a string in the sandbox. + ;; HARDENED: Uses jerboa-read (depth-limited) instead of bare read. + ;; Both reading and evaluation are covered by the time limit, + ;; so pathological input (deeply nested structures) is bounded. + (%with-time-limit sb + (lambda () + (let ([port (open-input-string str)]) + (let loop ([last (if #f #f)]) + (let ([form (parameterize ([*max-read-depth* 200] + [*max-list-length* 100000]) + (jerboa-read port))]) + (if (eof-object? form) + last + (loop (eval form (sandbox-environment sb)))))))))) + + (def (sandbox-define! sb name val) + ;; Bind name (symbol) to val in the sandbox. + (hashtable-set! (sandbox-user-bindings sb) name val) + (eval `(define ,name ',val) (sandbox-environment sb))) + + (def (sandbox-ref sb name) + ;; Look up a binding in the sandbox. Returns value or raises error. + (try (eval name (sandbox-environment sb)) + (catch (exn) (error 'sandbox-ref "unbound variable" name)))) + + (def (sandbox-call sb name . args) + ;; Call a procedure defined in the sandbox. + (try (let ([proc (eval name (sandbox-environment sb))]) + (apply proc args)) + (catch (exn) (exn->sandbox-error exn)))) + + (def (sandbox-reset! sb) + ;; Clear user-defined bindings by creating a fresh environment. + ;; HARDENED: Uses restricted environment, consistent with make-sandbox. + (hashtable-clear! (sandbox-user-bindings sb)) + (sandbox-environment-set! sb + (make-restricted-environment))) + + (def (sandbox-import! sb lib-name) + ;; Import a library into the sandbox. + ;; lib-name: e.g., '(std log) or '(chezscheme) + ;; HARDENED: Enforces allowed-imports from sandbox config. + (let ([config (sandbox-config-field sb)]) + (when (and config (sandbox-config-allowed-imports config)) + (unless (member lib-name (sandbox-config-allowed-imports config)) + (raise (condition + (make-message-condition + (format "sandbox import denied: ~a is not in allowed-imports list" + lib-name)) + (make-irritants-condition (list lib-name))))))) + (try (eval `(import ,lib-name) (sandbox-environment sb)) + (catch (exn) (exn->sandbox-error exn)))) + + (define-syntax with-sandbox + (syntax-rules () + [(_ sb body ...) + (let ([sb (make-sandbox)]) + body ...)])) + +) ;; end library deleted file mode 100644 --- a/lib/jerboa/hot.sls +++ /dev/null @@ -1,120 +0,0 @@ -#!chezscheme -;;; (jerboa hot) — Hot Code Reload -;;; -;;; Watch files for modification using mtime polling and reload them. - -(library (jerboa hot) - (export - make-reloader reloader? reloader-watch! reloader-unwatch! - reloader-check! reloader-reload! reloader-watched - file-modified? file-mtimes - with-reloader reloader-on-reload! reloader-on-error! - reload-result? reload-result-file reload-result-success? reload-result-error - ;; Testing helper: mark a watched file as stale (mtime=unknown) - reloader-force-stale!) - - (import (chezscheme)) - - ;; ========== Reload Result ========== - - (define-record-type (%reload-result make-reload-result reload-result?) - (fields (immutable file reload-result-file) - (immutable success reload-result-success?) - (immutable error reload-result-error))) ;; #f or condition - - ;; ========== Reloader ========== - - ;; mtimes: hashtable path -> mtime (integer seconds) - ;; on-reload: procedure called with (path) on success; or #f - ;; on-error: procedure called with (path exn) on error; or #f - - (define-record-type (%reloader make-reloader-raw reloader?) - (fields (mutable mtimes reloader-mtimes reloader-mtimes-set!) - (mutable on-reload reloader-on-reload-cb reloader-on-reload-cb-set!) - (mutable on-error reloader-on-error-cb reloader-on-error-cb-set!))) - - (define (make-reloader) - (make-reloader-raw (make-hashtable equal-hash equal?) #f #f)) - - (define (reloader-on-reload! r cb) - (reloader-on-reload-cb-set! r cb)) - - (define (reloader-on-error! r cb) - (reloader-on-error-cb-set! r cb)) - - (define (get-mtime path) - (guard (exn [#t #f]) - (if (file-exists? path) - (file-modification-time path) - #f))) - - (define (mtime-equal? t1 t2) - (cond - [(and (not t1) (not t2)) #t] - [(or (not t1) (not t2)) #f] - [else (time=? t1 t2)])) - - (define (reloader-watch! r path) - ;; Add path to watch list, storing current mtime. - (let ([mtime (get-mtime path)]) - (hashtable-set! (reloader-mtimes r) path mtime))) - - (define (reloader-unwatch! r path) - (hashtable-delete! (reloader-mtimes r) path)) - - (define (reloader-watched r) - ;; Returns list of watched file paths. - (let-values ([(keys _) (hashtable-entries (reloader-mtimes r))]) - (vector->list keys))) - - (define (file-modified? r path) - ;; Returns #t if mtime differs from stored mtime. - (let ([stored (hashtable-ref (reloader-mtimes r) path #f)] - [current (get-mtime path)]) - (not (mtime-equal? stored current)))) - - (define (file-mtimes r) - ;; Returns alist of (path . mtime) for all watched files. - (let-values ([(keys vals) (hashtable-entries (reloader-mtimes r))]) - (let loop ([i 0] [acc '()]) - (if (= i (vector-length keys)) - acc - (loop (+ i 1) - (cons (cons (vector-ref keys i) (vector-ref vals i)) - acc)))))) - - (define (reloader-force-stale! r path) - ;; Mark a watched file as stale (for testing). Sets stored mtime to #f. - (hashtable-set! (reloader-mtimes r) path #f)) - - (define (reloader-check! r) - ;; Check all watched files; return list of changed file paths. - (filter (lambda (path) (file-modified? r path)) - (reloader-watched r))) - - (define (reloader-reload! r) - ;; For each changed file, reload it; return list of reload-results. - (let ([changed (reloader-check! r)]) - (map (lambda (path) - (let ([result - (guard (exn [#t (make-reload-result path #f exn)]) - (load path) - ;; Update stored mtime on success - (hashtable-set! (reloader-mtimes r) path (get-mtime path)) - (make-reload-result path #t #f))]) - ;; Fire callbacks - (if (reload-result-success? result) - (let ([cb (reloader-on-reload-cb r)]) - (when cb (cb path))) - (let ([cb (reloader-on-error-cb r)]) - (when cb (cb path (reload-result-error result))))) - result)) - changed))) - - (define-syntax with-reloader - (syntax-rules () - [(_ r body ...) - (let ([r (make-reloader)]) - body ...)])) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/hot.ss @@ -0,0 +1,128 @@ +#!chezscheme +;;; (jerboa hot) — Hot Code Reload +;;; +;;; Watch files for modification using mtime polling and reload them. + +(library (jerboa hot) + (export + make-reloader reloader? reloader-watch! reloader-unwatch! + reloader-check! reloader-reload! reloader-watched + file-modified? file-mtimes + with-reloader reloader-on-reload! reloader-on-error! + reload-result? reload-result-file reload-result-success? reload-result-error + ;; Testing helper: mark a watched file as stale (mtime=unknown) + reloader-force-stale!) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch finally)) + + ;; ========== Reload Result ========== + + (defstruct %reload-result (file success error)) + (def make-reload-result make-%reload-result) + (def reload-result? %reload-result?) + (def reload-result-file %reload-result-file) + (def reload-result-success? %reload-result-success) + (def reload-result-error %reload-result-error) ;; #f or condition + + ;; ========== Reloader ========== + + ;; mtimes: hashtable path -> mtime (integer seconds) + ;; on-reload: procedure called with (path) on success; or #f + ;; on-error: procedure called with (path exn) on error; or #f + + (defstruct %reloader (mtimes on-reload on-error)) + (def make-reloader-raw make-%reloader) + (def reloader? %reloader?) + (def reloader-mtimes %reloader-mtimes) + (def reloader-mtimes-set! %reloader-mtimes-set!) + (def reloader-on-reload-cb %reloader-on-reload) + (def reloader-on-reload-cb-set! %reloader-on-reload-set!) + (def reloader-on-error-cb %reloader-on-error) + (def reloader-on-error-cb-set! %reloader-on-error-set!) + + (def (make-reloader) + (make-reloader-raw (make-hashtable equal-hash equal?) #f #f)) + + (def (reloader-on-reload! r cb) + (reloader-on-reload-cb-set! r cb)) + + (def (reloader-on-error! r cb) + (reloader-on-error-cb-set! r cb)) + + (def (get-mtime path) + (try (if (file-exists? path) + (file-modification-time path) + #f) + (catch (exn) #f))) + + (def (mtime-equal? t1 t2) + (cond + [(and (not t1) (not t2)) #t] + [(or (not t1) (not t2)) #f] + [else (time=? t1 t2)])) + + (def (reloader-watch! r path) + ;; Add path to watch list, storing current mtime. + (let ([mtime (get-mtime path)]) + (hashtable-set! (reloader-mtimes r) path mtime))) + + (def (reloader-unwatch! r path) + (hashtable-delete! (reloader-mtimes r) path)) + + (def (reloader-watched r) + ;; Returns list of watched file paths. + (let-values ([(keys _) (hashtable-entries (reloader-mtimes r))]) + (vector->list keys))) + + (def (file-modified? r path) + ;; Returns #t if mtime differs from stored mtime. + (let ([stored (hashtable-ref (reloader-mtimes r) path #f)] + [current (get-mtime path)]) + (not (mtime-equal? stored current)))) + + (def (file-mtimes r) + ;; Returns alist of (path . mtime) for all watched files. + (let-values ([(keys vals) (hashtable-entries (reloader-mtimes r))]) + (let loop ([i 0] [acc '()]) + (if (= i (vector-length keys)) + acc + (loop (+ i 1) + (cons (cons (vector-ref keys i) (vector-ref vals i)) + acc)))))) + + (def (reloader-force-stale! r path) + ;; Mark a watched file as stale (for testing). Sets stored mtime to #f. + (hashtable-set! (reloader-mtimes r) path #f)) + + (def (reloader-check! r) + ;; Check all watched files; return list of changed file paths. + (filter (lambda (path) (file-modified? r path)) + (reloader-watched r))) + + (def (reloader-reload! r) + ;; For each changed file, reload it; return list of reload-results. + (let ([changed (reloader-check! r)]) + (map (lambda (path) + (let ([result + (try (begin (load path) + ;; Update stored mtime on success + (hashtable-set! (reloader-mtimes r) path (get-mtime path)) + (make-reload-result path #t #f)) + (catch (exn) (make-reload-result path #f exn)))]) + ;; Fire callbacks + (if (reload-result-success? result) + (let ([cb (reloader-on-reload-cb r)]) + (when cb (cb path))) + (let ([cb (reloader-on-error-cb r)]) + (when cb (cb path (reload-result-error result))))) + result)) + changed))) + + (define-syntax with-reloader + (syntax-rules () + [(_ r body ...) + (let ([r (make-reloader)]) + body ...)])) + +) ;; end library deleted file mode 100644 --- a/lib/jerboa/pkg.sls +++ /dev/null @@ -1,191 +0,0 @@ -#!chezscheme -;;; (jerboa pkg) — Package Manager -;;; -;;; Semantic versioning, dependency resolution, manifests. - -(library (jerboa pkg) - (export - ;; Package records - make-package package? package-name package-version package-deps - package-description package-author - - ;; Version operations - version->list version-compare version<? version=? version>=? - - ;; Dependency records - make-dep dep? dep-name dep-version-constraint - - ;; Constraint checking - constraint-satisfied? - - ;; Resolution - resolve-deps dependency-order - - ;; Manifest - make-manifest manifest? manifest-packages - manifest-add manifest-remove manifest-lookup) -