Add security profile library
ober
90f1554a4ce8c0f63dc2c52d919156300d40c85f
new file mode 100644 --- /dev/null +++ b/.jerboa/security.json @@ -0,0 +1,70 @@ +{ + "version": 1, + "repo": "jerboa", + "extends": [ + "jerboa:library", + "jerboa:ffi", + "jerboa:parser", + "jerboa:crypto", + "jerboa:network-client", + "jerboa:network-service", + "jerboa:generated-heavy" + ], + "paths": { + "production": [ + "lib/**/*.ss", + "lib/**/*.sls", + "support/**/*.{ss,c,h,sh}", + "src/**/*.{c,h}", + "jerbuild.ss", + "Makefile" + ], + "tests": [ + "tests/**", + "examples/**", + "benchmarks/**" + ], + "generated": [ + "build/**", + "lib-cross/**", + ".chez/**", + ".chez-cross-*/**", + "jerboa-bin*" + ], + "vendor": [ + "vendor/**" + ], + "docs": [ + "README.md", + "docs/**", + "*.md", + "AGENTS.md", + "CLAUDE.md" + ] + }, + "policy": { + "failOn": ["critical", "high"], + "imports": { + "directChezscheme": "allow-in-library-boundaries" + }, + "ffi": { + "allowed": true, + "requireOwnershipComments": true, + "requireDynamicWindCleanup": true, + "requireCloseOnExec": true + }, + "process": { + "shellInterpolation": "deny" + }, + "network": { + "requireTimeouts": true, + "requireFailClosedSandbox": true + }, + "eval": { + "stringEval": "deny", + "bareRead": "deny", + "allowReadEval": false + } + }, + "suppressions": [] +} --- a/Makefile +++ b/Makefile @@ -24,7 +24,7 @@ CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$ # Shared object paths for legacy 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: help chez chez-cross build binary binary-cross native-cross 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-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push +.PHONY: help chez chez-cross build binary binary-cross native-cross 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-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile 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-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push help: @echo "Usage: make <target>" @@ -65,6 +65,7 @@ help: @echo " test-features Phase 2 + Phase 3 feature tests" @echo " test-wrappers FFI wrapper module tests" @echo " test-security Security tests" + @echo " security Run profile-aware local security checks" @echo " test-native Rust native library tests" @echo " test-all All test suites combined" @echo " test-phase2 Phase 2 feature tests" @@ -541,6 +542,7 @@ test-functional: test-security: @echo "--- Security tests ---" + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-security-profile.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-crypto-random.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-crypto-compare.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-crypto-digest.ss @@ -558,6 +560,16 @@ test-security: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-phase6-supply.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-security2-parsers.ss +test-security-profile: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-security-profile.ss + +security: security-production + +security-production: security-profile test-security-profile + +security-profile: + @test -f .jerboa/security.json + # Rust native library RUST_NATIVE_DIR = jerboa-native-rs UNAME_S := $(shell uname -s) new file mode 100644 --- /dev/null +++ b/lib/std/security/profile.ss @@ -0,0 +1,308 @@ +#!chezscheme +;;; (std security profile) -- per-repository security policy profiles + +(library (std security profile) + (export + discover-security-profile + load-security-profile + security-profile? + classify-path + profile-policy-ref + finding-allowed? + finding-severity) + + (import (chezscheme) + (std text json) + (only (jerboa core) def)) + + (def *profile-names* + '(".jerboa/security.json" + "jerboa-security.json" + "security-profile.json")) + + (def *classes* + '(vendor generated tests docs production)) + + (def *default-paths* + '((production . ("**/*.ss" "**/*.scm" "**/*.sls" "**/*.c" "**/*.h")) + (tests . ("test/**" "tests/**" "**/*-test.ss" "**/*-test.sls" "**/*.test.ss")) + (generated . ("generated/**" "dist/**" "target/**" "build/**")) + (vendor . ("vendor/**" "third_party/**" "third-party/**" "node_modules/**")) + (docs . ("README*" "docs/**" "**/*.md")) + (unknown . ()))) + + (def (security-profile? obj) + (hashtable? obj)) + + (def (discover-security-profile project-root) + (let loop ([names *profile-names*]) + (cond + [(null? names) #f] + [else + (let ([candidate (path-join project-root (car names))]) + (if (file-exists? candidate) + candidate + (loop (cdr names))))]))) + + (def (load-security-profile project-root . maybe-path) + (let ([path (if (null? maybe-path) + (discover-security-profile project-root) + (car maybe-path))]) + (if (not path) + #f + (let* ([raw (call-with-input-file path get-string-all)] + [profile (string->json-object raw)]) + (unless (hashtable? profile) + (error 'load-security-profile "profile must be a JSON object" path)) + (hashtable-set! profile "__profile-path" path) + (hashtable-set! profile "__project-root" + (if (string-suffix? "/.jerboa/security.json" path) + (drop-suffix path "/.jerboa/security.json") + (dirname path))) + (validate-suppressions! profile) + profile)))) + + (def (classify-path profile project-root path) + (let ([rel (normalize-path (relative-ish project-root path))]) + (let loop ([classes *classes*]) + (cond + [(null? classes) 'unknown] + [else + (let* ([class (car classes)] + [patterns (profile-paths profile class)]) + (if (any (lambda (pat) (glob-match? pat rel)) patterns) + class + (loop (cdr classes))))])))) + + (def (profile-policy-ref profile key . default) + (let ([fallback (if (null? default) #f (car default))]) + (if (not profile) + fallback + (let ([policy (ht-ref profile "policy" #f)]) + (cond + [(not policy) fallback] + [(pair? key) + (let loop ([obj policy] [ks key]) + (cond + [(null? ks) obj] + [(hashtable? obj) + (let ([next (ht-ref obj (key->string (car ks)) #f)]) + (if next (loop next (cdr ks)) fallback))] + [else fallback]))] + [else (ht-ref policy (key->string key) fallback)]))))) + + (def (finding-allowed? profile path rule-id) + (not (find-suppression profile path rule-id))) + + (def (finding-severity finding . default) + (let ([fallback (if (null? default) 'low (car default))]) + (cond + [(hashtable? finding) + (let ([sev (ht-ref finding "severity" #f)]) + (if (string? sev) (string->symbol sev) fallback))] + [(and (pair? finding) (assq 'severity finding)) => cdr] + [else fallback]))) + + ;; ------------------------------------------------------------------ + ;; Profile access + + (def (profile-paths profile class) + (let ([from-profile + (and profile + (let ([paths (ht-ref profile "paths" #f)]) + (and (hashtable? paths) + (ht-ref paths (symbol->string class) #f))))]) + (cond + [(and (list? from-profile) (all string? from-profile)) from-profile] + [else (let ([entry (assq class *default-paths*)]) + (if entry (cdr entry) '()))]))) + + (def (validate-suppressions! profile) + (let ([suppressions (ht-ref profile "suppressions" '())]) + (when (list? suppressions) + (for-each + (lambda (supp) + (when (hashtable? supp) + (let ([rule (ht-ref supp "rule" #f)] + [path (ht-ref supp "path" #f)] + [reason (ht-ref supp "reason" #f)]) + (unless (and (string? rule) + (string? path) + (string? reason) + (> (string-length reason) 0)) + (error 'load-security-profile + "suppression requires rule, path, and non-empty reason"))))) + suppressions)))) + + (def (find-suppression profile path rule-id) + (and profile + (let* ([root (ht-ref profile "__project-root" "")] + [rel (normalize-path (relative-ish root path))] + [suppressions (ht-ref profile "suppressions" '())]) + (and (list? suppressions) + (let loop ([xs suppressions]) + (cond + [(null? xs) #f] + [(not (hashtable? (car xs))) (loop (cdr xs))] + [else + (let* ([supp (car xs)] + [rule (ht-ref supp "rule" "")] + [pat (ht-ref supp "path" "")]) + (if (and (or (string=? rule rule-id) + (string=? rule "*")) + (glob-match? pat rel)) + supp + (loop (cdr xs))))])))))) + + ;; ------------------------------------------------------------------ + ;; Path and glob helpers + + (def (path-join a b) + (cond + [(or (string=? a "") (string=? a ".")) b] + [(string-suffix? "/" a) (string-append a b)] + [else (string-append a "/" b)])) + + (def (dirname path) + (let ([idx (last-index-of path #\/)]) + (cond + [(not idx) "."] + [(= idx 0) "/"] + [else (substring path 0 idx)]))) + + (def (relative-ish root path) + (let* ([nr (normalize-path root)] + [np (normalize-path path)] + [prefix (if (string-suffix? "/" nr) nr (string-append nr "/"))]) + (if (string-prefix? prefix np) + (substring np (string-length prefix) (string-length np)) + np))) + + (def (normalize-path path) + (list->string + (map (lambda (ch) (if (char=? ch #\\) #\/ ch)) + (string->list path)))) + + (def (glob-match? pattern path) + (let ([patterns (expand-braces pattern)]) + (any (lambda (pat) (glob-match-one? (normalize-path pat) path)) patterns))) + + (def (glob-match-one? pattern path) + (cond + [(string=? pattern path) #t] + [(string-suffix? "/**" pattern) + (let ([prefix (substring pattern 0 (- (string-length pattern) 2))]) + (string-prefix? prefix path))] + [(string-prefix? "**/*" pattern) + (string-suffix? (substring pattern 4 (string-length pattern)) path)] + [(string-prefix? "**/" pattern) + (string-suffix? (substring pattern 3 (string-length pattern)) path)] + [(contains? pattern "/**/") + (let* ([idx (string-index-substring pattern "/**/")] + [prefix (substring pattern 0 (+ idx 1))] + [suffix (substring pattern (+ idx 4) (string-length pattern))]) + (and (string-prefix? prefix path) + (glob-match-one? suffix + (substring path (string-length prefix) (string-length path)))))] + [(string-suffix? "/*" pattern) + (let ([prefix (substring pattern 0 (- (string-length pattern) 1))]) + (and (string-prefix? prefix path) + (not (contains? (substring path (string-length prefix) (string-length path)) "/"))))] + [(and (> (string-length pattern) 1) + (char=? (string-ref pattern 0) #\*)) + (string-suffix? (substring pattern 1 (string-length pattern)) path)] + [(string-suffix? "*" pattern) + (string-prefix? (substring pattern 0 (- (string-length pattern) 1)) path)] + [else #f])) + + (def (expand-braces pattern) + (let ([open (string-index pattern #\{)]) + (if (not open) + (list pattern) + (let ([close (string-index-from pattern #\} (+ open 1))]) + (if (not close) + (list pattern) + (let* ([before (substring pattern 0 open)] + [body (substring pattern (+ open 1) close)] + [after (substring pattern (+ close 1) (string-length pattern))]) + (apply append + (map (lambda (part) + (expand-braces (string-append before part after))) + (split-on-char body #\,))))))))) + + ;; ------------------------------------------------------------------ + ;; Small utilities + + (def (ht-ref ht key default) + (if (hashtable? ht) + (hashtable-ref ht key default) + default)) + + (def (key->string key) + (cond + [(string? key) key] + [(symbol? key) (symbol->string key)] + [else (format "~a" key)])) + + (def (all pred xs) + (or (null? xs) + (and (pred (car xs)) (all pred (cdr xs))))) + + (def (any pred xs) + (and (pair? xs) + (or (pred (car xs)) (any pred (cdr xs))))) + + (def (string-prefix? prefix str) + (let ([plen (string-length prefix)] + [slen (string-length str)]) + (and (<= plen slen) + (string=? (substring str 0 plen) prefix)))) + + (def (string-suffix? suffix str) + (let ([suflen (string-length suffix)] + [slen (string-length str)]) + (and (<= suflen slen) + (string=? (substring str (- slen suflen) slen) suffix)))) + + (def (drop-suffix str suffix) + (substring str 0 (- (string-length str) (string-length suffix)))) + + (def (contains? haystack needle) + (and (string-index-substring haystack needle) #t)) + + (def (string-index str ch) + (string-index-from str ch 0)) + + (def (string-index-from str ch start) + (let ([len (string-length str)]) + (let loop ([i start]) + (cond + [(>= i len) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (+ i 1))])))) + + (def (last-index-of str ch) + (let loop ([i (- (string-length str) 1)]) + (cond + [(< i 0) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (- i 1))]))) + + (def (string-index-substring haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) i] + [else (loop (+ i 1))])))) + + (def (split-on-char str ch) + (let ([len (string-length str)]) + (let loop ([start 0] [i 0] [acc '()]) + (cond + [(>= i len) + (reverse (cons (substring str start len) acc))] + [(char=? (string-ref str i) ch) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))] + [else (loop start (+ i 1) acc)]))))) new file mode 100644 --- /dev/null +++ b/tests/test-security-profile.ss @@ -0,0 +1,84 @@ +#!chezscheme +;;; test-security-profile.ss -- Tests for (std security profile) + +(import (chezscheme) (std security profile)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") (write 'expr) + (display " => ") (write result) + (display " expected ") (write exp) (newline))))])) + +(define root "/tmp/jerboa-security-profile-test") +(define profile-dir (string-append root "/.jerboa")) +(define profile-path (string-append profile-dir "/security.json")) + +(define (mkdir-p path) + (guard (e [#t (void)]) (mkdir path))) + +(guard (e [#t (void)]) (delete-file profile-path)) +(guard (e [#t (void)]) (delete-directory profile-dir)) +(guard (e [#t (void)]) (delete-directory root)) +(mkdir-p root) +(mkdir-p profile-dir) + +(call-with-output-file profile-path + (lambda (p) + (display + "{\n\ + \"version\": 1,\n\ + \"repo\": \"profile-test\",\n\ + \"paths\": {\n\ + \"production\": [\"src/**\", \"lib/**/*.{ss,sls}\"],\n\ + \"tests\": [\"test/**\", \"**/*-test.ss\"],\n\ + \"generated\": [\"generated/**\"],\n\ + \"vendor\": [\"vendor/**\"],\n\ + \"docs\": [\"README*\", \"docs/**\"]\n\ + },\n\ + \"policy\": {\n\ + \"failOn\": [\"critical\", \"high\"],\n\ + \"eval\": { \"bareRead\": \"deny\" }\n\ + },\n\ + \"suppressions\": [\n\ + { \"rule\": \"bare-read\", \"path\": \"src/reader.ss\", \"reason\": \"trusted reader fixture\" }\n\ + ]\n\ + }\n" p)) + 'truncate) + +(define profile (load-security-profile root)) + +(check (security-profile? profile) => #t) +(check (discover-security-profile root) => profile-path) +(check (classify-path profile root (string-append root "/src/main.ss")) => 'production) +(check (classify-path profile root (string-append root "/lib/std/security/profile.ss")) => 'production) +(check (classify-path profile root (string-append root "/test/main-test.ss")) => 'tests) +(check (classify-path profile root (string-append root "/generated/table.ss")) => 'generated) +(check (classify-path profile root (string-append root "/vendor/pkg/foo.ss")) => 'vendor) +(check (classify-path profile root (string-append root "/README.md")) => 'docs) +(check (classify-path profile root (string-append root "/misc/file.txt")) => 'unknown) + +(check (profile-policy-ref profile '(eval bareRead)) => "deny") +(check (profile-policy-ref profile 'missing 'fallback) => 'fallback) +(check (finding-allowed? profile (string-append root "/src/reader.ss") "bare-read") => #f) +(check (finding-allowed? profile (string-append root "/src/reader.ss") "other-rule") => #t) +(check (finding-severity '((severity . high))) => 'high) + +(guard (e [#t (void)]) (delete-file profile-path)) +(guard (e [#t (void)]) (delete-directory profile-dir)) +(guard (e [#t (void)]) (delete-directory root)) + +(display " security-profile: ") +(display pass-count) (display " passed") +(when (> fail-count 0) + (display ", ") (display fail-count) (display " failed")) +(newline) +(when (> fail-count 0) (exit 1))