security: default scripts to safe prelude
ober
808b17409fc291dc2e41a11c91ff430f4b96857f
--- a/Makefile +++ b/Makefile @@ -76,7 +76,7 @@ TYPED_LLVMIR_PARITY_FN ?= sample_typed_llvmir_smoke::main LLVM_BIN ?= $(shell if command -v llvm-as >/dev/null 2>&1; then dirname "$$(command -v llvm-as)"; elif [ -x /opt/homebrew/opt/llvm/bin/llvm-as ]; then echo /opt/homebrew/opt/llvm/bin; elif [ -x /usr/local/opt/llvm/bin/llvm-as ]; then echo /usr/local/opt/llvm/bin; fi) TYPED_WRAPPER_DIR ?= build/typed/jerboa -.PHONY: help chez static-supported-check chez-cross build binary binary-typed binary-typed-smoke binary-cross native-cross pure-audit typecheck typed-rust typed-llvmir typed-llvmir-check typed-llvmir-smoke typed-llvmir-parity typed-wrappers typed-build typed-wrapper-smoke typed-split-tree-smoke typed-test typed-clean test test-known-flaky test-reader test-core test-runtime test-try-debug test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-sqlite-robustness test-limits-primitives test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-kotlin test-typed-llvmir test-typed-wrappers test-pure-audit 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-security-profile test-native test-gaps native clean-native audit audit-native source-balance restrict-closure-check security-audit clean security security-production security-profile security-hardware-smoke sbom reproducibility-report reproducibility-compare verify release-evidence fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-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-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict data-check docker-build docker-push lint +.PHONY: help chez static-supported-check chez-cross build binary binary-typed binary-typed-smoke binary-cross native-cross pure-audit typecheck typed-rust typed-llvmir typed-llvmir-check typed-llvmir-smoke typed-llvmir-parity typed-wrappers typed-build typed-wrapper-smoke typed-split-tree-smoke typed-test typed-clean test test-known-flaky test-reader test-core test-runtime test-try-debug test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-sqlite-robustness test-limits-primitives test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-kotlin test-typed-llvmir test-typed-wrappers test-pure-audit 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-security-profile test-native test-gaps native clean-native audit audit-native import-policy-check source-balance restrict-closure-check security-audit clean security security-production security-profile security-hardware-smoke sbom reproducibility-report reproducibility-compare verify release-evidence fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-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-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict data-check docker-build docker-push lint .PHONY: check-cross-tools docker fuzz-websocket-fuzz jlsp jlsp-freebsd-amd64 \ jlsp-install jlsp-linux-amd64 jlsp-portable jmcp-freebsd-amd64 \ jmcp-freebsd-arm64 jmcp-linux-amd64 jmcp-linux-arm64 \ @@ -1736,7 +1736,10 @@ source-balance: restrict-closure-check: @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-restrict-closure.ss -audit: source-balance restrict-closure-check security-audit audit-native data-check security-production unification-check +import-policy-check: build + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-import-policy.ss examples + +audit: source-balance restrict-closure-check import-policy-check security-audit audit-native data-check security-production unification-check test-gaps: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-gaps.ss --- a/data/cookbooks.sexp +++ b/data/cookbooks.sexp @@ -91,7 +91,7 @@ "#!/usr/bin/env -S jerboa run\n\n; Or run manually:\n; jerboa run myscript.ss\n\n; Compile imported libraries for speed:\n; jerboa build\n\n(import (jerboa prelude))\n\n; Command-line args\n(def args (cdr (command-line)))\n\n(display \"Hello from Jerboa!\")\n(newline)") ("id" . "jerboa-run-script") ("imports") ("notes" . - "Set JERBOA_HOME to point to your Jerboa installation. The --compile-imported-libraries flag pre-compiles .sls to .so for faster startup.") + "Set JERBOA_HOME to point to your Jerboa installation. Direct scripts run with the safe application prelude by default: raw foreign-procedure, system, eval, and fork-thread are unavailable. Use jerboa run --unsafe-prelude myscript.ss or (import (jerboa prelude unsafe)) only when raw Chez bindings are explicitly required; both paths warn. The --compile-imported-libraries flag pre-compiles .sls to .so for faster startup.") ("tags" "run" "script" "scheme" "command line" "execute") ("title" . "Running a Jerboa Script")) (("code" --- a/docs/JERBOA-LANG.md +++ b/docs/JERBOA-LANG.md @@ -22,11 +22,16 @@ Run with: jerboa run hello.ss ``` -One import gives you the entire language: +One import gives direct scripts the safe application language: ```scheme (import (jerboa prelude)) ``` +When a script is run through `jerboa run`, that import is resolved as the safe +prelude. Raw FFI, `system`, `eval`, and raw thread bindings require +`jerboa run --unsafe-prelude hello.ss` or `(import (jerboa prelude unsafe))`; +both escape hatches print a warning. + --- ## Table of Contents @@ -71,9 +76,13 @@ A Jerboa `.ss` file has this shape: Key points: - **No `(library ...)` wrapper** — that's for `.sls` internals only -- **`(import (jerboa prelude))`** gives you everything: core macros, runtime, - result types, datetime, iterators, CSV, pretty-printer, JSON, paths, strings, - lists, alists, hash tables, functional combinators, ergo typing, FFI, and more +- **`(import (jerboa prelude))`** gives application scripts the safe Jerboa + surface: core macros, runtime, result types, datetime, iterators, CSV, + pretty-printer, JSON, paths, strings, lists, alists, hash tables, functional + combinators, ergo typing, and safe wrappers for risky APIs +- **Raw prelude is explicit**: use `--unsafe-prelude` or + `(import (jerboa prelude unsafe))` when you intentionally need raw Chez + bindings such as FFI, `system`, `eval`, or raw threads - For specialized modules not in the prelude, add extra imports --- @@ -1143,7 +1152,7 @@ These are **not** in the prelude — import them separately: ## The Jerboa Philosophy -1. **One import to start**: `(import (jerboa prelude))` gives you a complete language +1. **One import to start**: `(import (jerboa prelude))` gives application scripts a complete safe language 2. **`.ss` files are the language**: You never need to write `.sls` files 3. **Gerbil-familiar, Chez-powered**: Syntax is Gerbil-like, performance is Chez 4. **Batteries included**: JSON, CSV, datetime, result types, iterators — all in the prelude --- a/docs/kimi3-security-recommmendations.md +++ b/docs/kimi3-security-recommmendations.md @@ -472,11 +472,15 @@ eval-shaped channel; authentication shrinks who can even reach the parser. Today "always use `(jerboa prelude safe)`" is advice in docs. Advice is what a 23-minute adversary counts on users skipping. -- **Status:** import-conflict cleanup landed 2026-07-27, and the safe SQLite - wrappers now validate SQL before handle work and map invalid handles/raw - backend failures to structured DB conditions. `tests/test-safe-prelude.ss` - passes 24/24. The default-prelude switch, explicit unsafe escape hatch, - application import-audit enforcement, and broader user docs remain open. +- **Status:** import-conflict cleanup landed 2026-07-27. Safe SQLite + wrappers validate SQL before handle work and map invalid handles/raw backend + failures to structured DB conditions. Direct script loading now runs in a + safe environment by default: `(jerboa prelude)` is rewritten to + `(jerboa prelude safe)`, direct `(scheme)`/`(chezscheme)` imports are rejected + in safe mode, and `--unsafe-prelude` or `(jerboa prelude unsafe)` re-enable + raw bindings with a stderr warning. `make audit` now includes an + application import-policy gate for `examples/`. `tests/test-safe-prelude.ss` + passes 28/28. - **Do:** (a) `jerboa run file.ss` and the script path default to resolving `(jerboa prelude)` as `(jerboa prelude safe)`; opting into the raw prelude requires an explicit `(jerboa prelude unsafe)` (rename with @@ -489,10 +493,10 @@ what a 23-minute adversary counts on users skipping. allowlisted set of stdlib-internal files. (d) Update `quickstart.md`, `safety-guide.md`, `JERBOA-LANG.md`, `model-coding-guidance.md` and the MCP cookbook to teach safe-prelude-first. -- **Accept:** `tests/test-safe-prelude.ss` extended: a fresh script using - `(jerboa prelude)` cannot reach `foreign-procedure`, `system`, `eval`, - or `fork-thread`; the escape hatch works and warns; no import-conflict - warning remains at build. +- **Accept:** done for the app-entry surface: `tests/test-safe-prelude.ss` + now proves a fresh script using `(jerboa prelude)` cannot reach + `foreign-procedure`, `system`, `eval`, or `fork-thread`; the escape hatch + works and warns; no import-conflict warning remains at build. ### K3-P0-07 — Security regression suite v1 (exploit-shaped tests) **Serves:** G3, G4. **Effort:** 3–4 days. --- a/docs/model-coding-guidance.md +++ b/docs/model-coding-guidance.md @@ -4,6 +4,18 @@ This document records implementation facts that coding agents should treat as hard constraints when writing standalone Jerboa scripts, especially verifier-led benchmark tasks. +## Safe Prelude Default + +Standalone scripts should start with `(import (jerboa prelude))` and be run with +`jerboa run script.ss`. The script runner resolves that import to the safe +application prelude, so raw `foreign-procedure`, `system`, `eval`, and +`fork-thread` are unavailable by default. + +Only use `jerboa run --unsafe-prelude script.ss` or +`(import (jerboa prelude unsafe))` when the task explicitly requires raw Chez +bindings. The escape hatch prints a warning and should not appear in generated +application code by default. + ## Atoms Use the real prelude atom API: --- a/docs/quickstart.md +++ b/docs/quickstart.md @@ -36,6 +36,11 @@ Run it: jerboa run hello.ss ``` +For direct application scripts, `jerboa run` treats `(import (jerboa prelude))` +as the safe application prelude. Raw FFI, `system`, `eval`, and raw thread +bindings are not available unless you explicitly run with `--unsafe-prelude` or +import `(jerboa prelude unsafe)`, both of which print a warning. + ## 4. Use the REPL ```bash --- a/docs/safety-guide.md +++ b/docs/safety-guide.md @@ -5,16 +5,18 @@ features as of 2026-06-25. --- -## 1. Quick Start: The Safe Prelude +## 1. Quick Start: Safe Application Scripts -The single most important line in any Jerboa application: +For application scripts run with `jerboa run`, the normal prelude import is +safe by default: ```scheme -(import (jerboa prelude safe)) +(import (jerboa prelude)) ``` -This gives you the full Jerboa standard library with safety turned on by -default. Specifically, you get: +The script loader resolves that import as `(jerboa prelude safe)` and evaluates +the script in a base environment with raw FFI, `system`, `eval`, `fork-thread`, +`load`, and compiler entry points removed. Specifically, you get: - **Contract-checked stdlib** — SQLite, TCP, file I/O, and JSON functions validate arguments before FFI calls and return structured error conditions @@ -35,8 +37,11 @@ What you do NOT get (intentionally): - `eval` — use `run-safe-eval` for allowlisted expressions; use an exec worker for adversarial input that requires process isolation -If you need raw FFI or unscoped threads, import `(jerboa prelude)` instead. -But the safe prelude is the recommended default for application code. +If you need raw FFI or unscoped threads, use the explicit escape hatch: +`jerboa run --unsafe-prelude app.ss` or `(import (jerboa prelude unsafe))`. +Both paths print a one-line warning to stderr. Library and tool implementation +code may still import `(jerboa prelude safe)` directly when it needs the safe +surface outside the script loader. --- @@ -836,13 +841,6 @@ The runtime SQL injection check in `(std safe)` uses pattern matching. It catches common attacks but a determined adversary with knowledge of the heuristics can craft bypasses. Parameterized queries are the real defense. -### Import Conflict in Safe Prelude - -The safe prelude has overlapping symbol exports between imported modules that -produce a "multiple definitions" warning. This is cosmetic but means symbol -resolution order could theoretically surprise you in edge cases. In practice, -the safe version always wins because it is bound last. - ### Reproducibility Evidence Needs Independent Comparison `make reproducibility-report` performs a local two-build comparison of the --- a/docs/security-reference.md +++ b/docs/security-reference.md @@ -132,6 +132,7 @@ Access rights are unforgeable tokens (sealed, opaque records with CSPRNG nonces) - `(std security capability-typed)` -- `define/cap` and `lambda/cap` macros that declare capability requirements in function signatures - `(std security import-audit)` -- build-time scanner that detects direct `(chezscheme)` imports bypassing the capability system +- `(jerboa script-loader)` -- direct script entry uses the safe prelude by default, rejects direct `(scheme)`/`(chezscheme)` imports in safe mode, and requires `--unsafe-prelude` or `(jerboa prelude unsafe)` for raw bindings --- --- a/examples/chat-server.ss +++ b/examples/chat-server.ss @@ -9,13 +9,7 @@ ;;; In production, you'd use websockets; here we simulate clients ;;; with threads to show the patterns. -(import (except (scheme) - make-hash-table hash-table? - sort sort! format printf fprintf - iota 1+ 1- - path-extension path-absolute? - with-input-from-string with-output-to-string) - (jerboa prelude) +(import (jerboa prelude) (std misc thread) (std misc channel)) --- a/examples/cli-tool.ss +++ b/examples/cli-tool.ss @@ -7,13 +7,7 @@ ;;; bin/jerboa run examples/cli-tool.ss stats lib/std/ ;;; bin/jerboa run examples/cli-tool.ss find --pattern "defstruct" lib/ -(import (except (scheme) - make-hash-table hash-table? - sort sort! format printf fprintf - iota 1+ 1- - path-extension path-absolute? - with-input-from-string with-output-to-string) - (jerboa prelude) +(import (jerboa prelude) (std cli getopt) (std misc process) (std text json)) --- a/examples/data-pipeline.ss +++ b/examples/data-pipeline.ss @@ -7,13 +7,7 @@ ;;; ;;; Creates sample CSV data, parses it, transforms it, and outputs JSON. -(import (except (scheme) - make-hash-table hash-table? - sort sort! format printf fprintf - iota 1+ 1- - path-extension path-absolute? - with-input-from-string with-output-to-string) - (jerboa prelude) +(import (jerboa prelude) (std iter) (std text json) (std text csv) --- a/examples/hello-api.ss +++ b/examples/hello-api.ss @@ -6,13 +6,7 @@ ;;; Run: bin/jerboa run examples/hello-api.ss ;;; Test: curl http://localhost:8080/api/greeting?name=World -(import (except (scheme) - make-hash-table hash-table? - sort sort! format printf fprintf - iota 1+ 1- - path-extension path-absolute? - with-input-from-string with-output-to-string) - (jerboa prelude) +(import (jerboa prelude) (std net httpd) (std net router) (std misc thread)) --- a/jerbuild.ss +++ b/jerbuild.ss @@ -12,7 +12,11 @@ (import (rename (scheme) (system unsafe-system) (delete-file unsafe-delete-file)) - (jerboa build)) ;; compute-file-hash, module-changed? + (jerboa build) + (only (jerboa script-loader) + split-unsafe-prelude-flag + jerboa-load-script + jerboa-load-stdin)) ;; compute-file-hash, module-changed? ;;;; ============================================================ ;;;; CLI @@ -1656,36 +1660,17 @@ (unless (null? libs) (library-directories libs))) -(define (load-stdin!) - (define max-chars (* 16 1024 1024)) - (define source - (let ([out (open-output-string)]) - (let loop ([count 0]) - (when (> count max-chars) - (error 'jerbuild "exec stdin exceeds 16 MiB character limit")) - (let ([ch (read-char (current-input-port))]) - (unless (eof-object? ch) - (write-char ch out) - (loop (+ count 1))))) - (get-output-string out))) - (let ([env (interaction-environment)] - [port (open-input-string source)]) - (let loop () - (let ([form (read port)]) ; jerboa-security: suppress bare-read-untrusted -- bounded source - (unless (eof-object? form) - (eval form env) - (loop)))))) - (define (run-exec args) - ;; jerbuild exec [--libdirs <p>] <script.ss|-> [script-args...] - (let-values ([(libs rest) (parse-libdirs-flag args)]) - (when (null? rest) - (error 'jerbuild "exec: missing script path")) - (apply-libdirs! libs) - (command-line-arguments (cdr rest)) - (if (string=? (car rest) "-") - (load-stdin!) - (load (car rest))))) + ;; jerbuild exec [--libdirs <p>] [--unsafe-prelude] <script.ss|-> [script-args...] + (let-values ([(libs rest0) (parse-libdirs-flag args)]) + (let-values ([(rest unsafe-prelude?) (split-unsafe-prelude-flag rest0)]) + (when (null? rest) + (error 'jerbuild "exec: missing script path")) + (apply-libdirs! libs) + (command-line-arguments (cdr rest)) + (if (string=? (car rest) "-") + (jerboa-load-stdin unsafe-prelude?) + (jerboa-load-script (car rest) unsafe-prelude?))))) (define (run-compile args) ;; jerbuild compile [--libdirs <p>] [--wpo] <file.ss>... new file mode 100644 --- /dev/null +++ b/lib/jerboa/script-loader.ss @@ -0,0 +1,162 @@ +#!chezscheme +;;; (jerboa script-loader) -- safe-by-default direct script loading. + +(library (jerboa script-loader) + (export split-unsafe-prelude-flag + jerboa-load-script + jerboa-load-stdin) + (import (chezscheme) + (prefix (only (jerboa prelude) displayln) raw:) + (prefix (only (jerboa prelude safe) displayln) safe:)) + + (define max-script-chars (* 16 1024 1024)) + + (define blocked-safe-base-bindings + '(foreign-procedure foreign-callable load-shared-object + system eval fork-thread load compile compile-file + compile-library compile-program)) + + (define (split-unsafe-prelude-flag args) + (let loop ([rest args] [kept '()] [unsafe? #f]) + (cond + [(null? rest) (values (reverse kept) unsafe?)] + [(string=? (car rest) "--unsafe-prelude") + (loop (cdr rest) kept #t)] + [else + (loop (cdr rest) (cons (car rest) kept) unsafe?)]))) + + (define (read-port-bounded port label) + (let ([out (open-output-string)]) + (let loop ([count 0]) + (when (> count max-script-chars) + (error 'jerboa-script-loader "script exceeds 16 MiB character limit" label)) + (let ([ch (read-char port)]) + (unless (eof-object? ch) + (write-char ch out) + (loop (+ count 1))))) + (get-output-string out))) + + (define (read-file-bounded path) + (call-with-input-file path + (lambda (port) + (read-port-bounded port path)))) + + (define (read-script-forms source label) + (let ([port (open-input-string source)]) + (let loop ([forms '()]) + (let ([form (read port)]) ; jerboa-security: suppress bare-read-untrusted -- source is bounded before top-level parsing + (if (eof-object? form) + (reverse forms) + (loop (cons form forms))))))) + + (define (prelude-spec? spec) + (equal? spec '(jerboa prelude))) + + (define (unsafe-prelude-spec? spec) + (equal? spec '(jerboa prelude unsafe))) + + (define (import-wrapper? spec) + (and (pair? spec) + (memq (car spec) '(only except prefix rename)) + (pair? (cdr spec)))) + + (define (spec-requests-unsafe? spec) + (cond + [(unsafe-prelude-spec? spec) #t] + [(import-wrapper? spec) (spec-requests-unsafe? (cadr spec))] + [else #f])) + + (define (form-requests-unsafe? form) + (and (pair? form) + (eq? (car form) 'import) + (let loop ([specs (cdr form)]) + (and (pair? specs) + (or (spec-requests-unsafe? (car specs)) + (loop (cdr specs))))))) + + (define (script-requests-unsafe? forms) + (let loop ([rest forms]) + (and (pair? rest) + (or (form-requests-unsafe? (car rest)) + (loop (cdr rest)))))) + + (define (raw-base-import-spec? spec) + (cond + [(or (equal? spec '(scheme)) + (equal? spec '(chezscheme))) + #t] + [(import-wrapper? spec) (raw-base-import-spec? (cadr spec))] + [else #f])) + + (define (validate-safe-import-form! form) + (when (and (pair? form) (eq? (car form) 'import)) + (let loop ([specs (cdr form)]) + (when (pair? specs) + (when (raw-base-import-spec? (car specs)) + (error 'jerboa-script-loader + "direct (scheme)/(chezscheme) imports require --unsafe-prelude" + (car specs))) + (loop (cdr specs)))))) + + (define (rewrite-import-spec spec unsafe?) + (cond + [(unsafe-prelude-spec? spec) '(jerboa prelude)] + [(prelude-spec? spec) + (if unsafe? '(jerboa prelude) '(jerboa prelude safe))] + [(import-wrapper? spec) + (cons (car spec) + (cons (rewrite-import-spec (cadr spec) unsafe?) + (cddr spec)))] + [else spec])) + + (define (rewrite-top-level-form form unsafe?) + (if (and (pair? form) (eq? (car form) 'import)) + (cons 'import + (map (lambda (spec) (rewrite-import-spec spec unsafe?)) + (cdr form))) + form)) + + (define (safe-script-environment) + (copy-environment + (environment + '(except (chezscheme) + foreign-procedure foreign-callable load-shared-object + system eval fork-thread load compile compile-file + compile-library compile-program) + '(jerboa prelude safe)))) + + (define (unsafe-script-environment) + (copy-environment + (environment '(chezscheme) '(jerboa prelude)))) + + (define (warn-unsafe-prelude! label) + (fprintf (current-error-port) + "warning: unsafe prelude enabled for ~a; raw Chez bindings are available\n" + label)) + + (define (evaluate-script-forms forms unsafe? label) + (when unsafe? + (warn-unsafe-prelude! label)) + (let ([env (if unsafe? + (unsafe-script-environment) + (safe-script-environment))]) + (let loop ([rest forms]) + (unless (null? rest) + (let ([form (car rest)]) + (unless unsafe? + (validate-safe-import-form! form)) + (let ([rewritten (rewrite-top-level-form form unsafe?)]) + (eval rewritten env)) ; jerboa-security: suppress direct-eval -- bounded top-level script forms run in a safe environment by default + (loop (cdr rest))))))) + + (define (jerboa-load-script path unsafe-flag?) + (let* ([source (read-file-bounded path)] + [forms (read-script-forms source path)] + [unsafe? (or unsafe-flag? (script-requests-unsafe? forms))]) + (evaluate-script-forms forms unsafe? path))) + + (define (jerboa-load-stdin unsafe-flag?) + (let* ([source (read-port-bounded (current-input-port) "stdin")] + [forms (read-script-forms source "stdin")] + [unsafe? (or unsafe-flag? (script-requests-unsafe? forms))]) + (evaluate-script-forms forms unsafe? "stdin")))) --- a/support/binary-entry.ss +++ b/support/binary-entry.ss @@ -10,7 +10,10 @@ with-output-to-string iota 1+ 1- partition make-date make-time meta atom?) (jerboa prelude) - (only (jerboa reader) jerboa-read)) + (only (jerboa reader) jerboa-read) + (only (jerboa script-loader) + split-unsafe-prelude-flag + jerboa-load-script)) (let ([args (cdr (command-line))]) (cond @@ -38,10 +41,16 @@ (displayln "See LICENSE-CHEZ for Chez Scheme's NOTICE and license.")] [(or (string=? (car args) "--help") (string=? (car args) "-h")) - (displayln "Usage: jerboa-bin [<script.ss> | --version | --help]") - (displayln " no args start REPL") - (displayln " <script.ss> load and run a Scheme script") - (displayln " --version, -v print version") - (displayln " --help, -h print this help")] + (displayln "Usage: jerboa-bin [--unsafe-prelude] [<script.ss> | --version | --help]") + (displayln " no args start REPL") + (displayln " <script.ss> load and run a Scheme script with the safe prelude") + (displayln " --unsafe-prelude run script with raw Chez/prelude bindings") + (displayln " --version, -v print version") + (displayln " --help, -h print this help")] [else - (load (car args))])) + (let-values ([(script-args unsafe-prelude?) (split-unsafe-prelude-flag args)]) + (when (null? script-args) + (fprintf (current-error-port) "jerboa-bin: missing script path\n") + (exit 1)) + (command-line-arguments (cdr script-args)) + (jerboa-load-script (car script-args) unsafe-prelude?))])) --- a/support/build-jerboa-multicall.ss +++ b/support/build-jerboa-multicall.ss @@ -311,7 +311,10 @@ path-extension path-absolute? with-input-from-string with-output-to-string iota 1+ 1- partition make-date make-time meta atom?) - (jerboa prelude)) + (jerboa prelude) + (only (jerboa script-loader) + split-unsafe-prelude-flag + jerboa-load-script)) out) (newline out) (write `(import ,(entry-library-name 'mcp)) out) @@ -404,16 +407,23 @@ (displayln "See LICENSE-CHEZ for the runtime NOTICE and license.")] [(or (string=? (car args) "--help") (string=? (car args) "-h")) (for-each displayln - (list "Usage: jerboa [<script.ss> | <mode> ...] [--version]" - " (no args) start the Jerboa REPL" - " <script.ss> load and run a Jerboa script" - " jmcp|mcp ... run the MCP server" - " jlsp|lsp ... run the LSP server" - " jerbuild ... transpile/build a Jerboa project" - " jpkg|pkg ... run the package manager" + (list "Usage: jerboa [--unsafe-prelude] [<script.ss> | <mode> ...] [--version]" + " (no args) start the Jerboa REPL" + " <script.ss> load and run a Jerboa script with the safe prelude" + " --unsafe-prelude run script with raw Chez/prelude bindings" + " jmcp|mcp ... run the MCP server" + " jlsp|lsp ... run the LSP server" + " jerbuild ... transpile/build a Jerboa project" + " jpkg|pkg ... run the package manager" "" "Symlink to jmcp/jlsp/jerbuild/jpkg to pick a mode by name."))] - [else (load (car args))])) + [else + (let-values ([(script-args unsafe-prelude?) (split-unsafe-prelude-flag args)]) + (when (null? script-args) + (fprintf (current-error-port) "jerboa: missing script path\n") + (exit 1)) + (command-line-arguments (cdr script-args)) + (jerboa-load-script (car script-args) unsafe-prelude?))])) out) (newline out)))) --- a/support/build.ss +++ b/support/build.ss @@ -82,6 +82,8 @@ (jerboa runtime) (jerboa ffi) (jerboa build) + (jerboa script-loader) + (std security import-audit) (jerboa typed parser) (jerboa typed checker) (jerboa typed rust) @@ -97,6 +99,7 @@ ;; for the entire transitively-referenced tree. User scripts that ;; (import (jerboa prelude)) skip a large one-time compile at startup. (jerboa prelude) + (jerboa prelude safe) ;; jpkg package manager (multicall mode; not in the prelude). ;; (std pkg cli) transitively imports every (std pkg ...) module. (std pkg cli))) --- a/tests/test-safe-prelude.ss +++ b/tests/test-safe-prelude.ss @@ -5,7 +5,9 @@ (import (scheme) (std safe) (std lint) - (std error conditions)) + (std error conditions) + (std os temporaries) + (jerboa script-loader)) (define pass 0) (define fail 0) @@ -22,6 +24,46 @@ (begin (set! fail (+ fail 1)) (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) +(define (string-contains-substring? str sub) + (let ([n (string-length str)] + [m (string-length sub)]) + (let loop ([i 0]) + (cond + [(= m 0) #t] + [(> (+ i m) n) #f] + [(string=? (substring str i (+ i m)) sub) #t] + [else (loop (+ i 1))])))) + +(define (write-temp-script source) + (let ([path (make-temporary-file-name "jerboa-safe-entry")]) + (call-with-output-file path + (lambda (port) (display source port)) + 'replace) + path)) + +(define (run-script-loader source unsafe-prelude?) + (let ([path (write-temp-script source)] + [out (open-output-string)] + [err (open-output-string)]) + (let ([status + (parameterize ([current-output-port out] + [current-error-port err]) + (guard (exn [else (list 'error exn)]) + (jerboa-load-script path unsafe-prelude?) + '(ok)))]) + (guard (exn [else (void)]) + (delete-file path)) + (list status + (get-output-string out) + (get-output-string err))))) + +(define (loader-ok? result) + (equal? (car result) '(ok))) + +(define (loader-error? result) + (and (pair? (car result)) + (eq? (caar result) 'error))) + (printf "--- Safe Prelude & Safety Net Tests ---~%~%") ;; ========================================================================= @@ -90,7 +132,47 @@ #t) ;; ========================================================================= -;; 3. Lint: bare-error rule +;; 3. Direct script safe-prelude loader +;; ========================================================================= + +(printf "~%-- Direct script safe-prelude loader --~%") + +(test "script loader rewrites default prelude to safe surface" + (let ([result + (run-script-loader + "(import (jerboa prelude))\n(define (blocked? thunk)\n (guard (exn [else #t])\n (thunk)\n #f))\n(write (list\n (blocked? (lambda () foreign-procedure))\n (blocked? (lambda () system))\n (blocked? (lambda () eval))\n (blocked? (lambda () fork-thread))))\n" + #f)]) + (and (loader-ok? result) + (equal? (cadr result) "(#t #t #t #t)"))) + #t) + +(test "script loader unsafe flag preserves raw prelude and warns" + (let ([result + (run-script-loader + "(import (jerboa prelude))\n(write (guard (exn [else 'blocked])\n (system \"true\")\n 'allowed))\n" + #t)]) + (and (loader-ok? result) + (equal? (cadr result) "allowed") + (string-contains-substring? (caddr result) "unsafe prelude enabled"))) + #t) + +(test "script loader unsafe alias preserves raw prelude and warns" + (let ([result + (run-script-loader + "(import (jerboa prelude unsafe))\n(write (guard (exn [else 'blocked])\n (system \"true\")\n 'allowed))\n" + #f)]) + (and (loader-ok? result) + (equal? (cadr result) "allowed") + (string-contains-substring? (caddr result) "unsafe prelude enabled"))) + #t) + +(test "script loader rejects direct chezscheme import in safe mode" + (loader-error? + (run-script-loader "(import (chezscheme))\n(display \"bad\")\n" #f)) + #t) + +;; ========================================================================= +;; 4. Lint: bare-error rule ;; ========================================================================= (printf "~%-- Lint: bare-error rule --~%") new file mode 100644 --- /dev/null +++ b/tools/check-import-policy.ss @@ -0,0 +1,34 @@ +#!chezscheme +;;; check-import-policy.ss -- fail application import policy violations. + +(import (scheme) + (std security import-audit)) + +(define (scan-root root) + (if (file-directory? root) + (audit-imports-directory root) + '())) + +(define roots + (let ([args (cdr (command-line))]) + (if (null? args) + '("examples") + args))) + +(define violations + (let loop ([rest roots] [acc '()]) + (if (null? rest) + acc + (loop (cdr rest) (append acc (scan-root (car rest))))))) + +(unless (null? violations) + (for-each + (lambda (v) + (printf "import-policy: ~a:~a forbidden import ~s\n" + (import-violation-file v) + (import-violation-line v) + (import-violation-import-spec v))) + violations) + (exit 1)) + +(printf "import-policy: OK\n")