|
#!/usr/bin/env bb |
|
;; -*- mode: clojure -*- |
|
;; |
|
;; ============================================================================ |
|
;; NVIDIA OpenShell Policy Lab Environment — Clojure Functional Validator |
|
;; ============================================================================ |
|
;; |
|
;; This lab environment uses pure, composable Clojure anonymous functions |
|
;; to enforce the security constraints defined by the NVIDIA OpenShell Policy |
|
;; Schema (Version 1). |
|
;; |
|
;; Enforced Policy Dimensions: |
|
;; 1. Filesystem Security: |
|
;; - Absolute pathing verification (must start with "/") |
|
;; - Directory-traversal (parent directory "..") bans |
|
;; - Robust folder-boundary prefix matching (no partial directory matches) |
|
;; - Operations enforcement (read vs. read-write access mapping) |
|
;; 2. Process Security: |
|
;; - run_as_user and run_as_group matching |
|
;; - Identity isolation constraints (preventing root execution) |
|
;; 3. Network Security: |
|
;; - Host-to-endpoint mapping (supports wildcarding or literal domains) |
|
;; - Port boundary matching |
|
;; - Protocol restrictions (Layer 7: rest, websocket, graphql, etc.) |
|
;; - Executable-calling verification (only permitted binaries can open sockets) |
|
;; |
|
;; ---------------------------------------------------------------------------- |
|
;; Designed for pair programming with Antigravity. (ERGODIC 0 Witness Shell) |
|
;; ---------------------------------------------------------------------------- |
|
|
|
(ns policy-lab |
|
(:require [clj-yaml.core :as yaml] |
|
[clojure.string :as str] |
|
[clojure.edn :as edn] |
|
[babashka.fs :as fs] |
|
[babashka.cli :as cli] |
|
[clojure.pprint :as pprint])) |
|
|
|
;; Add local jet/src to classpath dynamically so we can use its namespaces as a library. |
|
(try |
|
(require '[babashka.classpath]) |
|
(let [script-dir (some-> (System/getProperty "babashka.file") fs/file fs/parent) |
|
jet-src (and script-dir (fs/file script-dir "jet" "src"))] |
|
(if (and jet-src (fs/exists? jet-src)) |
|
(babashka.classpath/add-classpath (str jet-src)) |
|
(let [cwd-jet-src (fs/file "openshell" "fable" "jet" "src")] |
|
(when (fs/exists? cwd-jet-src) |
|
(babashka.classpath/add-classpath (str cwd-jet-src)))))) |
|
(catch Exception _ nil)) |
|
|
|
;; ============================================================================ |
|
;; 1. Core Anonymous Assertion Primitives (The Predicate Layer) |
|
;; ============================================================================ |
|
|
|
;; Check if a path is absolute. |
|
(def abs-path? |
|
(fn [path] |
|
(and (string? path) |
|
(str/starts-with? path "/")))) |
|
|
|
;; Check if a path contains directory traversal sequences. |
|
(def traversal-free? |
|
(fn [path] |
|
(and (string? path) |
|
(not (str/includes? path ".."))))) |
|
|
|
;; Clean and split paths into segments to avoid partial prefix exploits. |
|
;; E.g., "/sandbox/worlds-secret" must not match prefix "/sandbox/worlds". |
|
(def path->segments |
|
(fn [path] |
|
(filter seq (str/split path #"/")))) |
|
|
|
;; Match non-root constraints. |
|
(def non-root? |
|
(fn [id] |
|
(and (string? id) |
|
(not= (str/lower-case id) "root")))) |
|
|
|
;; Safely parse integer or string to integer |
|
(def parse-int |
|
(fn [x] |
|
(cond |
|
(integer? x) x |
|
(string? x) (try (Long/parseLong x) (catch Exception _ nil)) |
|
:else nil))) |
|
|
|
;; ============================================================================ |
|
;; 2. Protocol and Record Design (Fogus & Marz Architectural Synthesis) |
|
;; ============================================================================ |
|
|
|
(defprotocol Constraint |
|
"A unified security abstraction that can be compiled, composed, and enforced." |
|
(allowed? [this context] |
|
"Returns true if the action described by context is permitted, false otherwise.")) |
|
|
|
;; --- Composable Dynamic Combinators (Fogus-style open polymorphism) --- |
|
|
|
(defrecord AndConstraint [constraints] |
|
Constraint |
|
(allowed? [this context] |
|
(every? #(allowed? % context) constraints))) |
|
|
|
(defrecord OrConstraint [constraints] |
|
Constraint |
|
(allowed? [this context] |
|
(some #(allowed? % context) constraints))) |
|
|
|
(defrecord NotConstraint [constraint] |
|
Constraint |
|
(allowed? [this context] |
|
(not (allowed? constraint context)))) |
|
|
|
;; --- Optimized Dimension-Specific Constraints (Marz-style compiled performance) --- |
|
|
|
(defrecord FilesystemConstraint [ro-segments-list rw-segments-list] |
|
Constraint |
|
(allowed? [this {:keys [op path]}] |
|
(let [target (str/replace path #"/+" "/")] |
|
(boolean |
|
(and (abs-path? target) |
|
(traversal-free? target) |
|
(let [t-segs (path->segments target) |
|
;; Optimize: We match pre-computed segment lists rather than splitting prefix-strings at runtime |
|
match-segments? (fn [p-segs] |
|
(and (<= (count p-segs) (count t-segs)) |
|
(every? true? (map = p-segs (take (count p-segs) t-segs))))) |
|
in-ro? (some match-segments? ro-segments-list) |
|
in-rw? (some match-segments? rw-segments-list)] |
|
(case op |
|
:read (or in-ro? in-rw?) |
|
:write in-rw? |
|
false))))))) |
|
|
|
(defrecord ProcessConstraint [allowed-user allowed-group] |
|
Constraint |
|
(allowed? [this {:keys [user group]}] |
|
(and (non-root? user) |
|
(non-root? group) |
|
(= user allowed-user) |
|
(= group allowed-group)))) |
|
|
|
(defrecord NetworkRule [binaries endpoints] |
|
Constraint |
|
(allowed? [this {:keys [binary host port protocol]}] |
|
(let [binary-matches? (some #(= (:path %) binary) binaries) |
|
endpoint-matches? (fn [ep] |
|
(let [ep-host (:host ep) |
|
ep-port (:port-int ep) |
|
ep-proto (:proto-name ep)] |
|
(and (or (= ep-host host) (= ep-host "*")) |
|
;; Direct comparison of pre-parsed values. No runtime parsing or casting! |
|
(or (= ep-port port) (= ep-port "*") (nil? ep-port)) |
|
(or (nil? ep-proto) |
|
(= ep-proto (name protocol))))))] |
|
(and binary-matches? |
|
(boolean (some endpoint-matches? endpoints)))))) |
|
|
|
(defrecord NetworkConstraint [rules] |
|
Constraint |
|
(allowed? [this context] |
|
(boolean (some #(allowed? % context) rules)))) |
|
|
|
;; --- The Compilation Pipeline (AOT Optimization Pass) --- |
|
|
|
(defn compile-endpoint [ep] |
|
(let [port-val (:port ep)] |
|
{:host (:host ep) |
|
:port-int (if (= (str port-val) "*") |
|
"*" |
|
(parse-int port-val)) |
|
:proto-name (when-let [p (:protocol ep)] |
|
(name p))})) |
|
|
|
(defn compile-policy |
|
"Takes a raw, declarative policy map (from YAML/EDN) and compiles it into |
|
an optimized tree of Enforceable Constraint Records, resolving wildcards, |
|
parsing ports, and tokenizing paths ahead of time for O(1) loop-enforcement." |
|
[policy] |
|
(let [norm-path (fn [p] (str/replace p #"/+" "/")) |
|
ro-paths (map norm-path (get-in policy [:filesystem_policy :read_only] [])) |
|
rw-paths (map norm-path (get-in policy [:filesystem_policy :read_write] [])) |
|
|
|
;; Pre-split into segment lists at compile time so hot path splits aren't required |
|
ro-segs (mapv path->segments ro-paths) |
|
rw-segs (mapv path->segments rw-paths) |
|
|
|
p-user (get-in policy [:process :run_as_user]) |
|
p-group (get-in policy [:process :run_as_group]) |
|
|
|
net-rules (get policy :network_policies {}) |
|
compiled-net-rules (mapv (fn [[_k rule]] |
|
(->NetworkRule |
|
(:binaries rule) |
|
(mapv compile-endpoint (:endpoints rule)))) |
|
net-rules)] |
|
{:filesystem (->FilesystemConstraint ro-segs rw-segs) |
|
:process (->ProcessConstraint p-user p-group) |
|
:network (->NetworkConstraint compiled-net-rules)})) |
|
|
|
;; --- Legacy API Adapter (100% Backwards Compatible) --- |
|
|
|
(defn make-validator |
|
"Wrapper function mapping the compiled protocol record architecture |
|
to the legacy high-order function interface to maintain perfect backwards compatibility." |
|
[policy] |
|
(let [compiled (compile-policy policy)] |
|
{:fs-allowed? |
|
(fn [op target-path] |
|
(allowed? (:filesystem compiled) {:op op :path target-path})) |
|
|
|
:process-allowed? |
|
(fn [user group] |
|
(allowed? (:process compiled) {:user user :group group})) |
|
|
|
:network-allowed? |
|
(fn [binary host port protocol] |
|
(allowed? (:network compiled) {:binary binary :host host :port port :protocol protocol}))})) |
|
|
|
;; ============================================================================ |
|
;; 3. Interactive Lab Demonstration & Assertions |
|
;; ============================================================================ |
|
|
|
(def print-test-header |
|
(fn [title] |
|
(println "\n" (str/join "" (repeat 80 "="))) |
|
(println " TEST SUITE:" title) |
|
(println (str/join "" (repeat 80 "="))))) |
|
|
|
(def evaluate-assertion |
|
(fn [label predicate args expected] |
|
(let [result (apply predicate args) |
|
passed? (= result expected)] |
|
(printf " [%s] %-55s -> %s\n" |
|
(if passed? "PASS" "FAIL") |
|
label |
|
(str (if passed? "✓ " "✗ ") result " (expected: " expected ")")) |
|
passed?))) |
|
|
|
(defn run-lab-tests [policy-path] |
|
(println "Loading Policy File:" policy-path) |
|
(let [raw-content (slurp policy-path) |
|
policy (yaml/parse-string raw-content) |
|
{:keys [fs-allowed? process-allowed? network-allowed?]} (make-validator policy)] |
|
|
|
;; ------------------------------------------------------------------------ |
|
;; Filesystem Security Tests |
|
;; ------------------------------------------------------------------------ |
|
(print-test-header "FILESYSTEM POLICIES (LANDLOCK ENVELOPE)") |
|
|
|
(evaluate-assertion |
|
"Read file in read-only zone (/usr/bin/bb)" |
|
fs-allowed? [:read "/usr/bin/bb"] true) |
|
|
|
(evaluate-assertion |
|
"Write file in read-only zone (/usr/bin/bb)" |
|
fs-allowed? [:write "/usr/bin/bb"] false) |
|
|
|
(evaluate-assertion |
|
"Write file in read-write zone (/sandbox/worlds/own.duckdb)" |
|
fs-allowed? [:write "/sandbox/worlds/own.duckdb"] true) |
|
|
|
(evaluate-assertion |
|
"Read file in read-write zone (/sandbox/worlds/own.duckdb)" |
|
fs-allowed? [:read "/sandbox/worlds/own.duckdb"] true) |
|
|
|
(evaluate-assertion |
|
"Read file in read-write rollout subfolder (/sandbox/worlds/own-rollouts/rollout1.json)" |
|
fs-allowed? [:read "/sandbox/worlds/own-rollouts/rollout1.json"] true) |
|
|
|
(evaluate-assertion |
|
"Write file outside allowed sandbox bounds (/etc/shadow)" |
|
fs-allowed? [:write "/etc/shadow"] false) |
|
|
|
(evaluate-assertion |
|
"Read file outside allowed sandbox bounds (/root/.ssh/id_rsa)" |
|
fs-allowed? [:read "/root/.ssh/id_rsa"] false) |
|
|
|
(evaluate-assertion |
|
"Prevent directory partial-matching exploit (/sandbox/worlds-secret/hack.txt)" |
|
fs-allowed? [:read "/sandbox/worlds-secret/hack.txt"] false) |
|
|
|
(evaluate-assertion |
|
"Reject relative pathing vulnerability (own.duckdb)" |
|
fs-allowed? [:read "own.duckdb"] false) |
|
|
|
(evaluate-assertion |
|
"Reject directory traversal attack (/sandbox/worlds/own-rollouts/../own.duckdb)" |
|
fs-allowed? [:write "/sandbox/worlds/own-rollouts/../own.duckdb"] false) |
|
|
|
;; ------------------------------------------------------------------------ |
|
;; Process Identity Isolation Tests |
|
;; ------------------------------------------------------------------------ |
|
(print-test-header "PROCESS IDENTITIES & PRIVILEGE ISOLATION") |
|
|
|
(evaluate-assertion |
|
"Permit configured non-root sandbox identity (sandbox/sandbox)" |
|
process-allowed? ["sandbox" "sandbox"] true) |
|
|
|
(evaluate-assertion |
|
"Block non-matching identities (daemon/daemon)" |
|
process-allowed? ["daemon" "daemon"] false) |
|
|
|
(evaluate-assertion |
|
"Explicity block root execution attempt (root/root)" |
|
process-allowed? ["root" "root"] false) |
|
|
|
;; ------------------------------------------------------------------------ |
|
;; Network Egress Isolation Tests |
|
;; ------------------------------------------------------------------------ |
|
(print-test-header "NETWORK EGRESS & LAYER 7 RESTRICTIONS") |
|
|
|
(if (get policy :network_policies) |
|
(do |
|
(evaluate-assertion |
|
"Permit local prompt model egress (localhost:11434, REST via bb)" |
|
network-allowed? ["/usr/bin/bb" "localhost" 11434 :rest] true) |
|
|
|
(evaluate-assertion |
|
"Permit local prompt model egress (127.0.0.1:11434, REST via bb)" |
|
network-allowed? ["/usr/bin/bb" "127.0.0.1" 11434 :rest] true) |
|
|
|
(evaluate-assertion |
|
"Block local prompt model egress if called by unauthorized binary (curl)" |
|
network-allowed? ["/usr/bin/curl" "localhost" 11434 :rest] |
|
;; Check if curl is in binary list for own.policy.yaml |
|
(some? (some #(= (:path %) "/usr/bin/curl") |
|
(get-in policy [:network_policies :local_prompt_model :binaries])))) |
|
|
|
(evaluate-assertion |
|
"Block arbitrary internet egress (google.com:443)" |
|
network-allowed? ["/usr/bin/curl" "google.com" 443 :rest] false)) |
|
(println " [SKIP] No network policies defined in this YAML schema.")) |
|
|
|
(println "\n" (str/join "" (repeat 80 "="))) |
|
(println " Lab Suite Evaluation Finished.") |
|
(println (str/join "" (repeat 80 "=")) "\n"))) |
|
|
|
;; ============================================================================ |
|
;; 4. Command Line Entrypoint & Dynamic CLI Engine |
|
;; ============================================================================ |
|
|
|
(defn run-query [policy query-str] |
|
(try |
|
(require '[jet.query :as jq] '[clojure.edn :as edn]) |
|
(let [query-expr (edn/read-string query-str) |
|
result ((resolve 'jq/query) policy query-expr)] |
|
(pprint/pprint result)) |
|
(catch Exception e |
|
(println "Error executing query:" (.getMessage e)) |
|
(System/exit 2)))) |
|
|
|
(defn print-help [] |
|
(println " |
|
NVIDIA OpenShell Policy Lab Environment — Clojure Functional Validator |
|
|
|
Usage: |
|
./policy_lab.clj [options] [subcommand] [arguments] |
|
|
|
Options: |
|
--policy, -p <file> Path to the YAML policy file. (Default: openshell/fable/own.policy.yaml) |
|
--query, -q <expr> Run a Jet-lang query against the loaded policy. |
|
--check-fs-read <path> Check read permission for a path. |
|
--check-fs-write <path> Check write permission for a path. |
|
--test, -t Run the built-in comprehensive lab test suite. |
|
--help, -h Show this help message. |
|
|
|
Subcommands: |
|
check-fs <op> <path> Verify filesystem access (op: read or write). |
|
check-process <user> <group> Verify process user and group credentials. |
|
check-network <bin> <host> <p> <proto> Check if process can perform network egress. |
|
query <expr> Run a Jet-lang query against the policy. |
|
|
|
Examples: |
|
./policy_lab.clj check-fs read /sandbox/worlds/fable.duckdb |
|
./policy_lab.clj check-fs write /sandbox/worlds/own.duckdb |
|
./policy_lab.clj check-process sandbox sandbox |
|
./policy_lab.clj check-network /usr/bin/bb localhost 11434 rest |
|
./policy_lab.clj --query \"[:filesystem_policy :read_write]\" |
|
")) |
|
|
|
(defn execute-cli [opts args] |
|
(let [policy-file (or (:policy opts) (:p opts) "openshell/fable/own.policy.yaml") |
|
full-path (fs/absolutize (fs/file policy-file))] |
|
(if-not (fs/exists? full-path) |
|
(do |
|
(println "Error: Policy file not found at" policy-file) |
|
(println "Available files:") |
|
(doseq [f (fs/glob "openshell/fable" "*.yaml")] |
|
(println " -" (str f))) |
|
(System/exit 1)) |
|
(let [policy (yaml/parse-string (slurp (str full-path))) |
|
{:keys [fs-allowed? process-allowed? network-allowed?]} (make-validator policy) |
|
subcommand (first args) |
|
sub-args (rest args)] |
|
(cond |
|
;; Help flag |
|
(or (:help opts) (:h opts)) |
|
(print-help) |
|
|
|
;; Subcommand: query or option: --query / -q |
|
(or (= subcommand "query") (:query opts) (:q opts)) |
|
(let [query-expr (or (:query opts) (:q opts) (first sub-args))] |
|
(if-not query-expr |
|
(do (println "Error: No query expression provided.") (System/exit 1)) |
|
(run-query policy query-expr))) |
|
|
|
;; Subcommand: check-fs or option: --check-fs-read / --check-fs-write |
|
(or (= subcommand "check-fs") (:check-fs opts) (:check-fs-read opts) (:check-fs-write opts)) |
|
(let [[op path] (cond |
|
(= subcommand "check-fs") [(keyword (first sub-args)) (second sub-args)] |
|
(:check-fs opts) [(keyword (:check-fs opts)) (first args)] |
|
(:check-fs-read opts) [:read (:check-fs-read opts)] |
|
(:check-fs-write opts) [:write (:check-fs-write opts)])] |
|
(if-not (and op path) |
|
(do (println "Error: Missing operation or path for filesystem check.") (System/exit 1)) |
|
(let [allowed? (fs-allowed? op path)] |
|
(println "\nNVIDIA OpenShell Policy Verification Check") |
|
(println (str/join "" (repeat 80 "="))) |
|
(println "Policy: " (str full-path)) |
|
(println "Dimension: Filesystem Security") |
|
(println "Operation:" (name op)) |
|
(println "Target: " path) |
|
(println (str/join "" (repeat 80 "-"))) |
|
(printf "Result: %s\n" (if allowed? "ALLOWED ✓" "DENIED ✗")) |
|
(println (str/join "" (repeat 80 "=")) "\n") |
|
(System/exit (if allowed? 0 1))))) |
|
|
|
;; Subcommand: check-process |
|
(or (= subcommand "check-process") (:check-process opts)) |
|
(let [[user group] (cond |
|
(= subcommand "check-process") [(first sub-args) (second sub-args)] |
|
:else [(:check-process opts) (first args)])] |
|
(if-not (and user group) |
|
(do (println "Error: Missing user or group for process identity check.") (System/exit 1)) |
|
(let [allowed? (process-allowed? user group)] |
|
(println "\nNVIDIA OpenShell Policy Verification Check") |
|
(println (str/join "" (repeat 80 "="))) |
|
(println "Policy: " (str full-path)) |
|
(println "Dimension: Process Identity & Isolation") |
|
(println "User: " user) |
|
(println "Group: " group) |
|
(println (str/join "" (repeat 80 "-"))) |
|
(printf "Result: %s\n" (if allowed? "ALLOWED ✓" "DENIED ✗")) |
|
(println (str/join "" (repeat 80 "=")) "\n") |
|
(System/exit (if allowed? 0 1))))) |
|
|
|
;; Subcommand: check-network |
|
(or (= subcommand "check-network") (:check-network opts)) |
|
(let [[binary host port protocol] (cond |
|
(= subcommand "check-network") [(nth sub-args 0 nil) (nth sub-args 1 nil) (nth sub-args 2 nil) (keyword (nth sub-args 3 nil))] |
|
:else [(:check-network opts) (nth args 0 nil) (nth args 1 nil) (keyword (nth args 2 nil))])] |
|
(if-not (and binary host port protocol) |
|
(do (println "Error: Missing binary, host, port, or protocol for network check.") (System/exit 1)) |
|
(let [allowed? (network-allowed? binary host (parse-int port) protocol)] |
|
(println "\nNVIDIA OpenShell Policy Verification Check") |
|
(println (str/join "" (repeat 80 "="))) |
|
(println "Policy: " (str full-path)) |
|
(println "Dimension: Network Egress & L7 Restrictions") |
|
(println "Binary: " binary) |
|
(println "Host: " host) |
|
(println "Port: " port) |
|
(println "Protocol: " (name protocol)) |
|
(println (str/join "" (repeat 80 "-"))) |
|
(printf "Result: %s\n" (if allowed? "ALLOWED ✓" "DENIED ✗")) |
|
(println (str/join "" (repeat 80 "=")) "\n") |
|
(System/exit (if allowed? 0 1))))) |
|
|
|
;; Test flag or default (no subcommand and no check flags) |
|
(or (:test opts) (:t opts)) |
|
(run-lab-tests (str full-path)) |
|
|
|
:else |
|
(run-lab-tests (str full-path))))))) |
|
|
|
(defn -main [& args] |
|
(let [{:keys [opts args]} (cli/parse-args args)] |
|
(execute-cli opts args))) |
|
|
|
;; Enable script-style direct execution |
|
(when-not (System/getProperty "babashka.jvm.lookup") |
|
(apply -main *command-line-args*)) |