From 5df21fca36e8722aaf70835895ea9663e3e486db Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 4 Apr 2026 23:51:25 +0000 Subject: [PATCH] Step 10b: capability-based sandboxing MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Capability primitives promoted from mcp_tree.ml to sx_primitives.ml: - with-capabilities — push cap set, eval body, restore on exit/error - current-capabilities — returns active capability list (nil = unrestricted) - has-capability? — check if capability granted (true when unrestricted) - require-capability! — raise if capability missing - capability-restricted? — check if any restrictions active Infrastructure: _cek_call_ref in sx_types.ml (forward ref pattern) allows primitives to invoke the CEK evaluator without dependency cycles. 10 new tests: unrestricted defaults, scoping, nesting, restore-on-exit. 2693 total tests, 0 regressions. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/lib/sx_primitives.ml | 49 +++++++++++++++++++++++ hosts/ocaml/lib/sx_ref.ml | 3 ++ hosts/ocaml/lib/sx_types.ml | 4 ++ spec/tests/test-r7rs.sx | 69 ++++++++++++++++++++++++++++++++ 4 files changed, 125 insertions(+) diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index c1a90bca..80203393 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -1062,6 +1062,55 @@ let () = match args with [Vector arr] -> Vector (Array.copy arr) | _ -> raise (Eval_error "vector-copy: expected vector")); + (* Capability-based sandboxing — gate IO operations *) + let cap_stack : string list ref = ref [] in + register "with-capabilities" (fun args -> + match args with + | [List caps; body] -> + let cap_set = List.filter_map (fun v -> match v with + | Symbol s | String s | Keyword s -> Some s | _ -> None) caps in + let prev = !cap_stack in + cap_stack := cap_set; + (match body with + | Lambda _ | NativeFn _ | VmClosure _ -> + let result = (try !Sx_types._cek_call_ref body Nil + with exn -> cap_stack := prev; raise exn) in + cap_stack := prev; result + | _ -> cap_stack := prev; body) + | [ListRef { contents = caps }; body] -> + (* Handle mutable lists too *) + let cap_set = List.filter_map (fun v -> match v with + | Symbol s | String s | Keyword s -> Some s | _ -> None) caps in + let prev = !cap_stack in + cap_stack := cap_set; + (match body with + | Lambda _ | NativeFn _ | VmClosure _ -> + let result = (try !Sx_types._cek_call_ref body Nil + with exn -> cap_stack := prev; raise exn) in + cap_stack := prev; result + | _ -> cap_stack := prev; body) + | _ -> raise (Eval_error "with-capabilities: expected (cap-list body-fn)")); + register "current-capabilities" (fun _args -> + if !cap_stack = [] then Nil + else List (List.map (fun s -> String s) !cap_stack)); + register "has-capability?" (fun args -> + match args with + | [String cap] | [Keyword cap] | [Symbol cap] -> + if !cap_stack = [] then Bool true (* unrestricted *) + else Bool (List.mem cap !cap_stack) + | _ -> Bool true); + register "require-capability!" (fun args -> + match args with + | [String cap] | [Keyword cap] | [Symbol cap] -> + if !cap_stack = [] then Nil (* unrestricted *) + else if List.mem cap !cap_stack then Nil + else raise (Eval_error (Printf.sprintf + "Capability '%s' not available. Current capabilities: [%s]" + cap (String.concat ", " !cap_stack))) + | _ -> Nil); + register "capability-restricted?" (fun _args -> + Bool (!cap_stack <> [])); + register "is-else-clause?" (fun args -> match args with | [Keyword "else"] -> Bool true diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index ef5a60ce..a94263a3 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -818,6 +818,9 @@ let () = trampoline_fn := (fun v -> (* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *) let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn +(* Wire up CEK call ref so primitives (e.g. with-capabilities) can invoke the evaluator *) +let () = Sx_types._cek_call_ref := cek_call + (* Override recursive cek_run with iterative loop. On error, capture the kont from the last state for comp-trace. *) let cek_run_iterative state = diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index ce99bc15..a9be93af 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -223,6 +223,10 @@ and vm_machine = { let _vm_call_closure_ref : (vm_closure -> value list -> value) ref = ref (fun _ _ -> raise (Failure "VM call_closure not initialized")) +(** Forward ref for calling CEK evaluator from primitives (avoids dependency cycle). *) +let _cek_call_ref : (value -> value -> value) ref = + ref (fun _ _ -> raise (Failure "CEK call not initialized")) + (** {1 Errors} *) diff --git a/spec/tests/test-r7rs.sx b/spec/tests/test-r7rs.sx index e996d220..21b9d22a 100644 --- a/spec/tests/test-r7rs.sx +++ b/spec/tests/test-r7rs.sx @@ -508,3 +508,72 @@ (do (assert= (vector 1 2 3) (vector 1 2 3)) (assert (not (= (vector 1 2) (vector 1 3))))))) + +(defsuite + "capabilities" + (deftest + "current-capabilities nil when unrestricted" + (assert= nil (current-capabilities))) + (deftest + "has-capability? true when unrestricted" + (assert (has-capability? "anything"))) + (deftest + "with-capabilities sets capabilities" + (with-capabilities + (list "io-fetch" "io-query") + (fn () (assert= (list "io-fetch" "io-query") (current-capabilities))))) + (deftest + "has-capability? checks active set" + (with-capabilities + (list "io-fetch") + (fn + () + (do + (assert (has-capability? "io-fetch")) + (assert (not (has-capability? "io-query"))))))) + (deftest + "require-capability! passes when granted" + (with-capabilities + (list "io-fetch") + (fn () (require-capability! "io-fetch")))) + (deftest + "require-capability! raises when missing" + (with-capabilities + (list "io-fetch") + (fn () (assert (not (has-capability? "io-query")))))) + (deftest + "capabilities restore after body" + (do + (with-capabilities (list "io-fetch") (fn () nil)) + (assert= nil (current-capabilities)))) + (deftest + "capabilities restore after nested call" + (do + (with-capabilities + (list "io-fetch") + (fn + () + (with-capabilities + (list "io-query") + (fn () (assert (has-capability? "io-query")))))) + (assert= nil (current-capabilities)))) + (deftest + "nested capabilities narrow scope" + (with-capabilities + (list "io-fetch" "io-query") + (fn + () + (with-capabilities + (list "io-fetch") + (fn + () + (do + (assert (has-capability? "io-fetch")) + (assert (not (has-capability? "io-query"))))))))) + (deftest + "capability-restricted? predicate" + (do + (assert (not (capability-restricted?))) + (with-capabilities + (list "pure") + (fn () (assert (capability-restricted?)))))))