Add pure Jerboa migration audit
ober
8ffa882d2e7bfdae1965f72898f1eb4dfbea545d
--- a/Makefile +++ b/Makefile @@ -24,8 +24,10 @@ CHEZ_EXT_DIR ?= $(HOME)/src CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$(CHEZ_EXT_DIR)/chez-zlib/src:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll/src:$(CHEZ_EXT_DIR)/chez-inotify/src:$(CHEZ_EXT_DIR)/chez-crypto/src:$(CHEZ_EXT_DIR)/chez-sqlite/src:$(CHEZ_EXT_DIR)/chez-postgresql/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 +PURE_AUDIT_ROOT ?= $(HOME)/mine +PURE_AUDIT_ARGS ?= --summary --discover $(PURE_AUDIT_ROOT) -.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 +.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded 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-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>" @@ -43,6 +45,7 @@ help: @echo " clean Remove compiled .so and .wpo artifacts" @echo " clean-native Remove Rust build artifacts" @echo " audit-native Run cargo audit on Rust native library" + @echo " pure-audit Scan jerboa-* repos for non-pure runtime surfaces" @echo "" @echo "Test (core):" @echo " test Run core test suite (reader, stdlib, ffi, regex)" @@ -61,6 +64,7 @@ help: @echo " test-repl REPL tests" @echo " test-functional Functional tests (I/O, fork, signals)" @echo " test-gaps Gap coverage tests" + @echo " test-pure-audit Pure Jerboa migration scanner tests" @echo "" @echo "Test (features):" @echo " test-features Phase 2 + Phase 3 feature tests" @@ -286,7 +290,10 @@ binary-cross: chez build chez-cross CC="$(CROSS_CC)" \ support/build-binary.sh $(BINARY_ENTRY) $(BINARY_OUTPUT)-$(CHEZ_TARGET_MACHINE) -test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all +test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all test-pure-audit + +pure-audit: + @$(SCHEME) --libdirs $(LIBDIRS) --script support/pure-audit.ss $(PURE_AUDIT_ARGS) check-docs: @SCHEME=$(SCHEME) tools/check-doc-examples.sh @@ -327,6 +334,9 @@ test-expanded: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-expanded-stdlib.ss; \ fi +test-pure-audit: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-pure-audit.ss + # --- Regex / rx / peg test suite --- test-rawstring: $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-reader-rawstring.ss --- a/docs/pure-jerboa-migration.md +++ b/docs/pure-jerboa-migration.md @@ -41,6 +41,8 @@ Finding categories: |---|---|---| | `rust-build` | `Cargo.toml` in the project | Remove handwritten crate use, or make it a generated Typed Jerboa backend crate | | `rust-source` | `.rs` source file | Rewrite as dynamic or Typed Jerboa; keep only generated Rust or an explicit native boundary | +| `generated-rust` | Rust generated from Typed Jerboa | Treat as informational; add drift checks and never hand edit | +| `typed-jerboa-source` | `(typed-library ...)` source | Treat as pure source; compile through typed backend tests | | `rust-wrapper` | Jerboa module imports Rust-backed code | Replace with pure modules or keep as an explicit boundary | | `c-native` | C/C++ source or headers | Replace with Jerboa or an audited OS boundary | | `ffi-boundary` | Direct FFI declarations | Remove direct FFI or narrow it behind a capability module | new file mode 100644 --- /dev/null +++ b/lib/jerboa/pure/audit.ss @@ -0,0 +1,418 @@ +#!chezscheme +;;; (jerboa pure audit) -- inventory non-Jerboa surfaces in a project +;;; +;;; This scanner answers the first migration question for jerboa-* projects: +;;; which files and source lines still depend on Rust, Node, C/FFI, native +;;; shared objects, or external processes? + +(library (jerboa pure audit) + (export + scan-project + scan-projects + discover-jerboa-projects + pure-report->markdown + pure-report->summary-line + pure-report-clean? + pure-report-blocking-findings + pure-report-summary + pure-report-root + pure-report-files + pure-report-findings + pure-finding? + pure-finding-project + pure-finding-file + pure-finding-line + pure-finding-category + pure-finding-severity + pure-finding-evidence + pure-finding-recommendation) + + (import (chezscheme)) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted migration scanner + + (define-record-type pure-finding + (fields project file line category severity evidence recommendation)) + + (define-record-type pure-report + (fields root files findings)) + + (define skip-directory-names + '(".git" ".hg" ".svn" ".chez" "target" "node_modules" "dist" "build" + ".cache" ".idea" ".vscode")) + + (define source-suffixes + '(".ss" ".sls" ".scm" ".rs" ".c" ".h" ".cc" ".cpp" ".hpp" + ".toml" ".json" ".js" ".ts" ".tsx" ".jsx" ".sh")) + + (define (string-prefix? prefix s) + (let ((plen (string-length prefix)) (slen (string-length s))) + (and (<= plen slen) + (string=? prefix (substring s 0 plen))))) + + (define (string-suffix? suffix s) + (let ((slen (string-length s)) (flen (string-length suffix))) + (and (<= flen slen) + (string=? suffix (substring s (- slen flen) slen))))) + + (define (substring-present? haystack needle) + (let ((hlen (string-length haystack)) (nlen (string-length needle))) + (cond + ((= nlen 0) #t) + ((> nlen hlen) #f) + (else + (let loop ((i 0)) + (cond + ((> (+ i nlen) hlen) #f) + ((string=? (substring haystack i (+ i nlen)) needle) #t) + (else (loop (+ i 1))))))))) + + (define (string-trim-left s) + (let ((s-length (string-length s))) + (let loop ((i 0)) + (cond + ((>= i s-length) "") + ((char-whitespace? (string-ref s i)) (loop (+ i 1))) + (else (substring s i s-length)))))) + + (define (ignored-source-line? line) + (let ((trimmed (string-trim-left line))) + (or (string=? trimmed "") + (string-prefix? ";" trimmed) + (string-prefix? "//" trimmed) + (string-prefix? "#" trimmed)))) + + (define (path-join a b) + (cond + ((string=? a "") b) + ((string=? b "") a) + ((char=? (string-ref a (- (string-length a) 1)) #\/) + (string-append a b)) + (else (string-append a "/" b)))) + + (define (basename path) + (let ((path-length (string-length path))) + (let loop ((i (- path-length 1))) + (cond + ((< i 0) path) + ((char=? (string-ref path i) #\/) (substring path (+ i 1) path-length)) + (else (loop (- i 1))))))) + + (define (skip-directory? name) + (let loop ((xs skip-directory-names)) + (cond + ((null? xs) #f) + ((string=? name (car xs)) #t) + (else (loop (cdr xs)))))) + + ;; Display-only prefix test for shortening report paths. Do not use for + ;; authorization or sandbox decisions. + (define (display-path-prefix? prefix path) + (let ((plen (string-length prefix)) (path-len (string-length path))) + (and (<= plen path-len) + (string=? prefix (substring path 0 plen))))) + + (define (project-relative root path) + (let ((prefix (if (and (> (string-length root) 0) + (char=? (string-ref root (- (string-length root) 1)) #\/)) + root + (string-append root "/")))) + (if (display-path-prefix? prefix path) + (substring path (string-length prefix) (string-length path)) + path))) + + (define (source-file? path) + (or (string=? (basename path) "Cargo.toml") + (string=? (basename path) "package.json") + (let loop ((suffixes source-suffixes)) + (cond + ((null? suffixes) #f) + ((string-suffix? (car suffixes) path) #t) + (else (loop (cdr suffixes))))))) + + (define (generated-typed-backend-path? path) + (or (substring-present? path "/build/typed/") + (substring-present? path "/generated/typed/") + (substring-present? path "/typed/generated/"))) + + (define generated-rust-markers + '("Generated by Jerboa's safe Rust target" + "Generated by Typed Jerboa" + "Generated by Jerboa's typed Rust backend")) + + (define (any-substring-present? text needles) + (let loop ((xs needles)) + (cond + ((null? xs) #f) + ((substring-present? text (car xs)) #t) + (else (loop (cdr xs)))))) + + (define (file-prefix-contains-any? path markers max-lines) + (guard (exn (#t #f)) + (call-with-input-file path + (lambda (port) + (let loop ((n 0)) + (cond + ((>= n max-lines) #f) + (else + (let ((line (get-line port))) + (cond + ((eof-object? line) #f) + ((any-substring-present? line markers) #t) + (else (loop (+ n 1)))))))))))) + + (define (generated-rust-file? path) + (or (generated-typed-backend-path? path) + (file-prefix-contains-any? path generated-rust-markers 12))) + + (define (directory-entries dir) + (guard (exn (#t '())) + (map (lambda (x) (format "~a" x)) (directory-list dir)))) + + (define (find-project-files root) + (let ((results '())) + (let scan ((dir root)) + (for-each + (lambda (entry) + (unless (or (string=? entry ".") (string=? entry "..")) + (let ((full (path-join dir entry))) + (cond + ((and (file-directory? full) (not (skip-directory? entry))) + (scan full)) + ((and (not (file-directory? full)) (source-file? full)) + (set! results (cons full results))))))) + (directory-entries dir))) + (sort string<? (reverse results)))) + + (define (make-path-finding root path category severity evidence recommendation) + (make-pure-finding root (project-relative root path) #f category severity evidence recommendation)) + + (define (make-line-finding root path line category severity evidence recommendation) + (make-pure-finding root (project-relative root path) line category severity evidence recommendation)) + + (define (append-map f xs) + (let loop ((xs xs) (acc '())) + (if (null? xs) + (reverse acc) + (let inner ((ys (f (car xs))) (acc acc)) + (if (null? ys) + (loop (cdr xs) acc) + (inner (cdr ys) (cons (car ys) acc))))))) + + (define (classify-path root path) + (let ((base (basename path))) + (cond + ((and (string=? base "Cargo.toml") + (generated-typed-backend-path? path)) + (list (make-path-finding root path 'generated-rust 'info + "Generated Typed Jerboa Rust crate" + "Treat this as a build artifact; verify it with drift checks rather than hand editing it."))) + ((string=? base "Cargo.toml") + (list (make-path-finding root path 'rust-build 'high + "Cargo.toml" + "Remove handwritten Cargo use, or make it a generated Typed Jerboa backend crate."))) + ((and (string-suffix? ".rs" path) + (generated-rust-file? path)) + (list (make-path-finding root path 'generated-rust 'info + "Generated Rust backend artifact" + "Keep Typed Jerboa as the source of truth and regenerate this file."))) + ((string-suffix? ".rs" path) + (list (make-path-finding root path 'rust-source 'high + "Rust source file" + "Rewrite as dynamic or Typed Jerboa; keep only generated Rust or an explicit native boundary."))) + ((string=? base "package.json") + (list (make-path-finding root path 'node-build 'medium + "package.json" + "Replace Node tooling/runtime dependencies with Jerboa scripts or document as build-only."))) + ((or (string-suffix? ".ts" path) (string-suffix? ".tsx" path) + (string-suffix? ".js" path) (string-suffix? ".jsx" path)) + (list (make-path-finding root path 'node-source 'medium + "JavaScript/TypeScript source file" + "Port runtime code to Jerboa or isolate as generated/static assets."))) + ((or (string-suffix? ".c" path) (string-suffix? ".h" path) + (string-suffix? ".cc" path) (string-suffix? ".cpp" path) + (string-suffix? ".hpp" path)) + (list (make-path-finding root path 'c-native 'high + "C/C++ source file" + "Replace native code with Jerboa, generated safe Rust, or a deliberately audited OS boundary."))) + ((substring-present? base "-native.ss") + (list (make-path-finding root path 'native-wrapper 'high + "native wrapper module name" + "Replace this wrapper with a pure Jerboa implementation or a pure capability module."))) + (else '())))) + + (define (pattern-finding root path line text pattern category severity recommendation) + (and (substring-present? text pattern) + (make-line-finding root path line category severity pattern recommendation))) + + (define (line-findings root path line text) + (if (ignored-source-line? text) + '() + (let ((patterns + (list + (list "foreign-procedure" 'ffi-boundary 'high + "Replace direct FFI with a pure Jerboa module or a narrow generated boundary.") + (list "load-shared-object" 'native-loader 'high + "Remove dynamic native loading for pure Jerboa; route through pure modules.") + (list "begin-ffi" 'ffi-boundary 'high + "Remove inline FFI declarations for pure Jerboa.") + (list "define-c-lambda" 'ffi-boundary 'high + "Replace C lambda bindings with Jerboa implementations.") + (list "c-declare" 'ffi-boundary 'high + "Remove embedded C declarations for pure Jerboa.") + (list "native-rust" 'rust-wrapper 'high + "Replace Rust-backed module imports with pure Jerboa equivalents.") + (list "tls-rustls" 'rust-wrapper 'high + "Use pure Jerboa protocol code only when the threat model permits; otherwise keep TLS as an audited non-pure boundary.") + (list "open-process-ports" 'external-process 'medium + "Replace shell/process orchestration with Jerboa APIs where possible.") + (list "(system" 'external-process 'medium + "Replace shell/process orchestration with Jerboa APIs where possible.") + (list "(typed-library" 'typed-jerboa-source 'info + "Typed Jerboa source is pure source input; compile it through typed backend tests.")))) + (let loop ((ps patterns) (out '())) + (if (null? ps) + (reverse out) + (let* ((p (car ps)) + (finding (pattern-finding root path line text + (car p) (cadr p) (caddr p) (cadddr p)))) + (loop (cdr ps) (if finding (cons finding out) out)))))))) + + (define (scan-file-lines root path) + (guard (exn (#t '())) + (call-with-input-file path + (lambda (port) + (let loop ((line-no 1) (acc '())) + (let ((line (get-line port))) + (if (eof-object? line) + (reverse acc) + (loop (+ line-no 1) + (append (reverse (line-findings root path line-no line)) acc))))))))) + + (define (finding-key f) + (format "~a:~a:~a:~a" + (pure-finding-file f) + (or (pure-finding-line f) 0) + (pure-finding-category f) + (pure-finding-evidence f))) + + (define (dedupe-findings findings) + (let loop ((xs findings) (seen '()) (out '())) + (cond + ((null? xs) (reverse out)) + (else + (let ((key (finding-key (car xs)))) + (if (member key seen) + (loop (cdr xs) seen out) + (loop (cdr xs) (cons key seen) (cons (car xs) out)))))))) + + (define (severity-rank severity) + (case severity + ((critical) 0) + ((high) 1) + ((medium) 2) + ((low) 3) + ((info) 4) + (else 4))) + + (define (sort-findings findings) + (sort + (lambda (a b) + (let ((ra (severity-rank (pure-finding-severity a))) + (rb (severity-rank (pure-finding-severity b)))) + (if (= ra rb) + (string<? (finding-key a) (finding-key b)) + (< ra rb)))) + findings)) + + (define (scan-project root) + (let* ((files (find-project-files root)) + (path-findings (append-map (lambda (path) (classify-path root path)) files)) + (line-findings* (append-map (lambda (path) (scan-file-lines root path)) files)) + (findings (sort-findings (dedupe-findings (append path-findings line-findings*))))) + (make-pure-report root files findings))) + + (define (scan-projects roots) + (map scan-project roots)) + + (define (discover-jerboa-projects parent) + (let ((projects '())) + (for-each + (lambda (entry) + (let ((full (path-join parent entry))) + (when (and (file-directory? full) + (string-prefix? "jerboa-" entry)) + (set! projects (cons full projects))))) + (directory-entries parent)) + (sort string<? (reverse projects)))) + + (define (blocking-finding? finding) + (not (eq? (pure-finding-severity finding) 'info))) + + (define (pure-report-blocking-findings report) + (filter blocking-finding? (pure-report-findings report))) + + (define (pure-report-clean? report) + (null? (pure-report-blocking-findings report))) + + (define (increment-count key counts) + (let ((cell (assq key counts))) + (if cell + (begin (set-cdr! cell (+ (cdr cell) 1)) counts) + (cons (cons key 1) counts)))) + + (define (pure-report-summary report) + (let loop ((findings (pure-report-findings report)) (counts '())) + (if (null? findings) + (sort (lambda (a b) (string<? (symbol->string (car a)) + (symbol->string (car b)))) + counts) + (loop (cdr findings) + (increment-count (pure-finding-category (car findings)) counts))))) + + (define (finding-location f) + (if (pure-finding-line f) + (format "~a:~a" (pure-finding-file f) (pure-finding-line f)) + (pure-finding-file f))) + + (define (pure-report->markdown report) + (call-with-string-output-port + (lambda (out) + (fprintf out "# Pure Jerboa Migration Audit~%~%") + (fprintf out "Project: `~a`~%~%" (pure-report-root report)) + (fprintf out "- Files scanned: ~a~%" (length (pure-report-files report))) + (fprintf out "- Findings: ~a~%" (length (pure-report-findings report))) + (fprintf out "- Blocking findings: ~a~%" (length (pure-report-blocking-findings report))) + (fprintf out "- Pure Jerboa ready: ~a~%~%" (if (pure-report-clean? report) "yes" "no")) + (unless (null? (pure-report-summary report)) + (fprintf out "## Summary~%~%") + (for-each + (lambda (entry) + (fprintf out "- `~a`: ~a~%" (car entry) (cdr entry))) + (pure-report-summary report)) + (fprintf out "~%")) + (unless (null? (pure-report-findings report)) + (fprintf out "## Findings~%~%") + (for-each + (lambda (f) + (fprintf out "- **~a** `~a` at `~a`: ~a~% Recommendation: ~a~%" + (pure-finding-severity f) + (pure-finding-category f) + (finding-location f) + (pure-finding-evidence f) + (pure-finding-recommendation f))) + (pure-report-findings report)))))) + + (define (pure-report->summary-line report) + (call-with-string-output-port + (lambda (out) + (fprintf out "~a files=~a findings=~a pure=~a" + (pure-report-root report) + (length (pure-report-files report)) + (length (pure-report-findings report)) + (if (pure-report-clean? report) "yes" "no")) + (fprintf out " blockers=~a" (length (pure-report-blocking-findings report))) + (for-each + (lambda (entry) + (fprintf out " ~a=~a" (car entry) (cdr entry))) + (pure-report-summary report))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/support/pure-audit.ss @@ -0,0 +1,54 @@ +#!chezscheme +;;; Pure Jerboa migration audit CLI +;;; +;;; Usage: +;;; scheme --libdirs lib --script support/pure-audit.ss <project>... +;;; scheme --libdirs lib --script support/pure-audit.ss --discover /Users/user/mine +;;; scheme --libdirs lib --script support/pure-audit.ss --summary --discover /Users/user/mine + +(import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted repository CLI + (jerboa pure audit)) + +(define (usage) + (display "Usage:\n") + (display " scheme --libdirs lib --script support/pure-audit.ss <project>...\n") + (display " scheme --libdirs lib --script support/pure-audit.ss --discover <parent-dir>\n") + (display " scheme --libdirs lib --script support/pure-audit.ss --summary <project>...\n") + (display " scheme --libdirs lib --script support/pure-audit.ss --summary --discover <parent-dir>\n")) + +(define (print-report path) + (display (pure-report->markdown (scan-project path))) + (newline)) + +(define (print-summary path) + (display (pure-report->summary-line (scan-project path))) + (newline)) + +(define (project-args args) + (cond + ((null? args) #f) + ((string=? (car args) "--discover") + (if (or (null? (cdr args)) (not (null? (cddr args)))) + #f + (discover-jerboa-projects (cadr args)))) + (else args))) + +(define (run-with printer args) + (let ((projects (project-args args))) + (if projects + (for-each printer projects) + (begin + (usage) + (exit 2))))) + +(define (main args) + (cond + ((null? args) + (usage) + (exit 2)) + ((string=? (car args) "--summary") + (run-with print-summary (cdr args))) + (else + (run-with print-report args)))) + +(main (cdr (command-line))) new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-generated/generated/typed/rust/Cargo.toml @@ -0,0 +1,7 @@ +[package] +name = "jerboa-typed-generated-fixture" +version = "0.1.0" +edition = "2021" + +[lib] +crate-type = ["cdylib"] new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-generated/generated/typed/rust/src/lib.rs @@ -0,0 +1,8 @@ +#![forbid(unsafe_code)] + +// Generated by Typed Jerboa. +// Source fixture: sample-generated/split-tree.ss + +pub fn split_count(left: u64, right: u64) -> u64 { + left + right +} new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-generated/split-tree.ss @@ -0,0 +1,7 @@ +#!chezscheme + +(typed-library (sample generated split-tree) + (export split-count) + + (def (split-count [left : Nat] [right : Nat]) : Nat + (+ left right))) new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-native/Cargo.toml @@ -0,0 +1,7 @@ +[package] +name = "sample-native" +version = "0.1.0" +edition = "2021" + +[dependencies] +ring = "0.17" new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-native/main.ss @@ -0,0 +1,11 @@ +#!chezscheme +(import (chezscheme) + (std crypto native-rust)) + +(load-shared-object "libsample_native.so") + +(define c-native-add + (foreign-procedure "native_add" (int int) int)) + +(define (run-shell cmd) + (open-process-ports cmd 'block (native-transcoder))) new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-native/package.json @@ -0,0 +1,8 @@ +{ + "scripts": { + "build": "tsc" + }, + "dependencies": { + "typescript": "^5.0.0" + } +} new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-native/src/lib.rs @@ -0,0 +1,3 @@ +pub fn native_add(a: i32, b: i32) -> i32 { + a + b +} new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-native/tool.ts @@ -0,0 +1,3 @@ +export function normalizeName(name: string): string { + return name.trim().toLowerCase(); +} new file mode 100644 --- /dev/null +++ b/tests/fixtures/pure-audit/sample-pure/main.ss @@ -0,0 +1,5 @@ +#!chezscheme +(import (jerboa prelude)) + +(def (double x) + (+ x x)) new file mode 100644 --- /dev/null +++ b/tests/test-pure-audit.ss @@ -0,0 +1,114 @@ +#!chezscheme +;;; Tests for (jerboa pure audit) -- pure Jerboa migration scanner + +(import (chezscheme) + (jerboa pure audit)) + +(define pass 0) +(define fail 0) + +(define (test name got expected) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))) + +(define (category-present? report category) + (let loop ((findings (pure-report-findings report))) + (cond + ((null? findings) #f) + ((eq? (pure-finding-category (car findings)) category) #t) + (else (loop (cdr findings)))))) + +(define pure-report + (scan-project "tests/fixtures/pure-audit/sample-pure")) + +(define native-report + (scan-project "tests/fixtures/pure-audit/sample-native")) + +(define generated-report + (scan-project "tests/fixtures/pure-audit/sample-generated")) + +(printf "--- Pure Jerboa Migration Audit ---~%~%") + +(test "pure fixture is clean" + (pure-report-clean? pure-report) + #t) + +(test "native fixture is not clean" + (pure-report-clean? native-report) + #f) + +(test "generated typed backend fixture is clean" + (pure-report-clean? generated-report) + #t) + +(test "generated fixture has no blocking findings" + (length (pure-report-blocking-findings generated-report)) + 0) + +(test "detects Cargo.toml" + (category-present? native-report 'rust-build) + #t) + +(test "detects Rust source" + (category-present? native-report 'rust-source) + #t) + +(test "detects direct FFI" + (category-present? native-report 'ffi-boundary) + #t) + +(test "detects native loader" + (category-present? native-report 'native-loader) + #t) + +(test "detects Rust wrapper import" + (category-present? native-report 'rust-wrapper) + #t) + +(test "detects Node build" + (category-present? native-report 'node-build) + #t) + +(test "detects Node source" + (category-present? native-report 'node-source) + #t) + +(test "detects external process" + (category-present? native-report 'external-process) + #t) + +(test "detects generated Rust as informational" + (category-present? generated-report 'generated-rust) + #t) + +(test "detects typed Jerboa source as informational" + (category-present? generated-report 'typed-jerboa-source) + #t) + +(test "markdown mentions project" + (let ((md (pure-report->markdown native-report))) + (and (string? md) + (let ((needle "sample-native")) + (let loop ((i 0)) + (cond + ((> (+ i (string-length needle)) (string-length md)) #f) + ((string=? (substring md i (+ i (string-length needle))) needle) #t) + (else (loop (+ i 1)))))))) + #t) + +(test "summary line reports blocker count" + (let ((line (pure-report->summary-line native-report))) + (and (string? line) + (let ((needle "blockers=")) + (let loop ((i 0)) + (cond + ((> (+ i (string-length needle)) (string-length line)) #f) + ((string=? (substring line i (+ i (string-length needle))) needle) #t) + (else (loop (+ i 1)))))))) + #t) + +(printf "~%Pure Audit: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) + (exit 1))