Add safe-by-default prelude, finalizer safety net, lint rules, SQL injection detection
ober
fc5f6f7610eecccda16872191ac02ceecead3314
new file mode 100644 --- /dev/null +++ b/lib/jerboa/prelude/safe.sls @@ -0,0 +1,199 @@ +#!chezscheme +;;; (jerboa prelude safe) — Safe-by-default prelude +;;; +;;; Import this instead of (jerboa prelude) to get safety for free. +;;; All dangerous APIs are replaced with contract-checked, timeout-enforced, +;;; resource-safe equivalents under the STANDARD names: +;;; +;;; (import (jerboa prelude safe)) +;;; (with-resource ([db (sqlite-open "test.db")]) +;;; (sqlite-exec db "CREATE TABLE t(x)") +;;; (sqlite-query db "SELECT * FROM t")) +;;; +;;; The safe versions: +;;; - Validate arguments before FFI calls +;;; - Return structured error conditions instead of bare (error ...) +;;; - Support automatic resource cleanup via with-resource +;;; - Enforce timeouts on blocking operations +;;; - Reject unsafe FASL deserialization +;;; - Do NOT export raw FFI forms (c-lambda, foreign-procedure, etc.) + +(library (jerboa prelude safe) + (export + ;; ---- Everything from (jerboa prelude) EXCEPT raw FFI ---- + ;; Core macros + def def* defrule defrules + defstruct defclass defmethod + match + try catch finally + while until + + ;; hash constructors + hash-literal hash-eq-literal + let-hash + + ;; Runtime + ~ bind-method! call-method + make-hash-table make-hash-table-eq + hash-ref hash-get hash-put! hash-update! hash-remove! + hash-key? hash->list hash->plist hash-for-each hash-map hash-fold + hash-find hash-keys hash-values hash-copy hash-clear! + hash-merge hash-merge! hash-length hash-table? + list->hash-table plist->hash-table + keyword? keyword->string string->keyword make-keyword + error-message error-irritants error-trace + displayln 1+ 1- + iota last-pair + *method-tables* + register-struct-type! *struct-types* + struct-predicate struct-field-ref struct-field-set! + struct-type-info + + ;; std/sort + sort sort! stable-sort stable-sort! + + ;; std/format + format printf fprintf eprintf + + ;; std/error + Error ContractViolation + + ;; std/sugar + chain chain-and assert! + + ;; std/text/json — safe wrappers under standard names + read-json write-json json-object->string string->json-object + + ;; std/os/path + path-expand path-normalize path-directory path-strip-directory + path-extension path-strip-extension + path-join path-absolute? + + ;; std/misc/string + string-split string-join string-trim + string-prefix? string-suffix? + string-contains string-index + string-empty? + + ;; std/misc/list + flatten unique snoc + take drop + every any + filter-map + group-by + zip + + ;; std/misc/alist + agetq agetv aget + asetq! asetv! aset! + pgetq pgetv pget + alist->hash-table + + ;; std/misc/ports + read-all-as-string read-all-as-lines + read-file-string read-file-lines + write-file-string + with-input-from-string with-output-to-string + + ;; ---- Safe APIs under STANDARD names ---- + + ;; SQLite (safe wrappers, renamed to standard names) + sqlite-open sqlite-close sqlite-exec sqlite-execute sqlite-query + sqlite-prepare sqlite-finalize sqlite-step sqlite-bind + + ;; TCP (safe wrappers, renamed to standard names) + tcp-connect tcp-listen tcp-accept tcp-close + tcp-read tcp-write tcp-write-string + + ;; File I/O (safe wrappers, renamed to standard names) + open-safe-input-file open-safe-output-file + call-with-safe-input-file call-with-safe-output-file + + ;; Resource management + with-resource with-resource1 + register-resource-cleanup! + call-with-resource + + ;; Error conditions (full hierarchy) + &jerboa jerboa-condition? jerboa-condition-subsystem + db-error? network-error? timeout-error? parse-error? resource-error? + db-connection-error? db-query-error? db-constraint-violation? + connection-refused? connection-timeout? + resource-leak? resource-already-closed? resource-exhausted? + + ;; Timeout + with-timeout *default-timeout* + + ;; Safe FASL + safe-fasl-write safe-fasl-read + safe-fasl-write-bytevector safe-fasl-read-bytevector + register-safe-record-type! unregister-safe-record-type! + *fasl-allow-procedures* *fasl-max-object-count* *fasl-max-byte-size* + + ;; Safe mode control + *safe-mode*) + + (import + (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1-) + (jerboa core) + ;; No (jerboa ffi) — raw FFI is intentionally excluded + (std sort) + (std format) + (except (std error) error-message error-irritants error-trace error? + with-exception-handler) + (except (std sugar) try catch finally while until + hash-literal hash-eq-literal let-hash + defrule defrules) + (std text json) + (std os path) + (std misc string) + (std misc list) + (std misc alist) + (std misc ports) + ;; Safety modules + (prefix (std safe) safe:) + (std resource) + (std error conditions) + (std safe-timeout) + (std safe-fasl)) + + ;; ========================================================================= + ;; Re-export safe APIs under standard names + ;; ========================================================================= + + ;; SQLite + (define sqlite-open safe:safe-sqlite-open) + (define sqlite-close safe:safe-sqlite-close) + (define sqlite-exec safe:safe-sqlite-exec) + (define sqlite-execute safe:safe-sqlite-execute) + (define sqlite-query safe:safe-sqlite-query) + (define sqlite-prepare safe:safe-sqlite-prepare) + (define sqlite-finalize safe:safe-sqlite-finalize) + (define sqlite-step safe:safe-sqlite-step) + (define sqlite-bind safe:safe-sqlite-bind) + + ;; TCP + (define tcp-connect safe:safe-tcp-connect) + (define tcp-listen safe:safe-tcp-listen) + (define tcp-accept safe:safe-tcp-accept) + (define tcp-close safe:safe-tcp-close) + (define tcp-read safe:safe-tcp-read) + (define tcp-write safe:safe-tcp-write) + (define tcp-write-string safe:safe-tcp-write-string) + + ;; File I/O + (define open-safe-input-file safe:safe-open-input-file) + (define open-safe-output-file safe:safe-open-output-file) + (define call-with-safe-input-file safe:safe-call-with-input-file) + (define call-with-safe-output-file safe:safe-call-with-output-file) + + ;; Mode control + (define *safe-mode* safe:*safe-mode*) + +) ;; end library --- a/lib/std/lint.sls +++ b/lib/std/lint.sls @@ -282,6 +282,121 @@ (let ([v (f (car l))]) (loop (cdr l) (if v (cons v acc) acc)))))) + ;;; ---- unsafe-import rule ---- + ;; + ;; Warns when code imports raw unsafe modules that have safe equivalents. + ;; e.g. (import (std db sqlite-native)) should be (import (jerboa prelude safe)) + ;; or at minimum (import (std safe)) + + (define %unsafe-modules + '(((std db sqlite-native) "(std safe) or (jerboa prelude safe)") + ((std db postgresql-native) "(std safe) or (jerboa prelude safe)") + ((std net tcp-raw) "(std safe) or (jerboa prelude safe)"))) + + (define (%rule-unsafe-import forms) + (let loop ([fs forms] [results '()]) + (if (null? fs) (reverse results) + (let ([f (car fs)]) + (loop (cdr fs) + (if (and (pair? f) + (or (eq? (car f) 'import) + (eq? (car f) 'library))) + (append results (check-imports-in-form f)) + results)))))) + + (define (check-imports-in-form form) + ;; Walk the form looking for module references that match unsafe-modules + (let loop ([parts (cdr form)] [results '()]) + (if (null? parts) results + (let* ([part (car parts)] + [hit (find-unsafe-module part)]) + (loop (cdr parts) + (if hit + (cons (make-result severity-warn + (format "unsafe import ~s; use ~a instead" + (car hit) (cadr hit)) + 'unsafe-import) + results) + results)))))) + + (define (find-unsafe-module spec) + ;; Check if spec (or a wrapped spec like (except ...)) matches an unsafe module + (let ([mod-name (extract-module-name spec)]) + (and mod-name + (let loop ([unsafe %unsafe-modules]) + (if (null? unsafe) #f + (if (equal? mod-name (caar unsafe)) + (car unsafe) + (loop (cdr unsafe)))))))) + + (define (extract-module-name spec) + ;; Unwrap (except (mod) ...), (only (mod) ...), (prefix (mod) p), etc. + (cond + [(and (pair? spec) (memq (car spec) '(except only prefix rename))) + (and (pair? (cdr spec)) (extract-module-name (cadr spec)))] + [(and (pair? spec) (symbol? (car spec))) + spec] ;; bare module name like (std db sqlite-native) + [else #f])) + + ;;; ---- bare-error rule ---- + ;; + ;; Warns on bare (error 'who "msg" ...) calls. Suggests using structured + ;; conditions from (std error conditions) instead. + + (define (%rule-bare-error forms) + (let ([results '()]) + (define (walk f) + (when (pair? f) + (when (and (eq? (car f) 'error) + (pair? (cdr f)) + ;; Distinguish (error 'who "msg") from (error? x) + ;; Note: 'sym reads as (quote sym) + (or (symbol? (cadr f)) + (string? (cadr f)) + (and (pair? (cadr f)) + (eq? (caadr f) 'quote)))) + (set! results + (cons (make-result severity-info + (format "bare (error ...) call; consider structured conditions from (std error conditions)" + ) + 'bare-error) + results))) + (for-each walk f))) + (for-each walk forms) + (reverse results))) + + ;;; ---- sql-interpolation rule ---- + ;; + ;; Warns when SQL-looking strings are built via string-append or format + ;; inside sqlite-*/safe-sqlite-* calls. This catches: + ;; (sqlite-exec db (string-append "SELECT * FROM " table)) + ;; (sqlite-query db (format "SELECT * FROM ~a" table)) + + (define %sql-functions + '(sqlite-exec sqlite-query sqlite-execute sqlite-prepare + safe-sqlite-exec safe-sqlite-query safe-sqlite-execute safe-sqlite-prepare)) + + (define (%rule-sql-interpolation forms) + (let ([results '()]) + (define (walk f) + (when (pair? f) + (when (and (memq (car f) %sql-functions) + (>= (length f) 3)) + ;; Check the SQL argument (second arg after db handle) + (let ([sql-arg (caddr f)]) + (when (and (pair? sql-arg) + (memq (car sql-arg) + '(string-append format string-concatenate))) + (set! results + (cons (make-result severity-warn + (format "SQL built via ~a — use parameterized queries instead" + (car sql-arg)) + 'sql-interpolation) + results))))) + (for-each walk f))) + (for-each walk forms) + (reverse results))) + (define %builtin-rules (list (cons 'empty-begin %rule-empty-begin) @@ -292,7 +407,10 @@ (cons 'redefine-builtin %rule-redefine-builtin) (cons 'magic-number %rule-magic-number) (cons 'shadowed-define %rule-shadowed-define) - (cons 'unused-define %rule-unused-define))) + (cons 'unused-define %rule-unused-define) + (cons 'unsafe-import %rule-unsafe-import) + (cons 'bare-error %rule-bare-error) + (cons 'sql-interpolation %rule-sql-interpolation))) ;;; ---- default-linter ---- --- a/lib/std/safe.sls +++ b/lib/std/safe.sls @@ -58,7 +58,11 @@ ;; Error conditions (re-export) db-error? network-error? timeout-error? parse-error? - resource-error?) + resource-error? + + ;; Finalizer safety net + *resource-finalizer-log* + poll-resource-finalizers!) (import (chezscheme) (std error conditions) @@ -78,6 +82,62 @@ (when (eq? (*safe-mode*) 'check) body ...)])) + ;; ========================================================================= + ;; Finalizer safety net — guardian-based resource leak detection + ;; ========================================================================= + ;; + ;; When a resource handle is GC'd without being explicitly closed, the + ;; guardian fires and we log a warning. This catches the common pattern: + ;; (let ([db (sqlite-open "x.db")]) ...) ; forgot to close! + ;; + ;; Warnings are logged to *resource-finalizer-log* (a parameter holding + ;; a procedure). Default: display to current-error-port. + ;; Call poll-resource-finalizers! periodically or at shutdown. + + (define *resource-guardian* (make-guardian)) + + ;; Each entry in the guardian is (cons type-symbol info-string) + ;; so we know what leaked when the guardian fires. + (define *resource-finalizer-log* + (make-parameter + (lambda (type info) + (fprintf (current-error-port) + "WARNING: ~a handle GC'd without close! (~a)~%" + type info)))) + + (define (register-guarded-resource! handle type info cleanup-proc) + ;; Track the resource. When GC'd without explicit close, we warn + clean. + (let ([entry (vector type info cleanup-proc #f)]) ;; #f = not-yet-closed + (*resource-guardian* entry) + entry)) + + (define (mark-resource-closed! entry) + ;; Mark as closed so the guardian callback won't warn. + (when entry + (vector-set! entry 3 #t))) + + (define (poll-resource-finalizers!) + ;; Call this periodically (or at shutdown) to process GC'd resources. + ;; Returns the number of leaked resources found. + (let loop ([count 0]) + (let ([entry (*resource-guardian*)]) + (if (not entry) + count + (begin + (unless (vector-ref entry 3) ;; not already closed? + (let ([type (vector-ref entry 0)] + [info (vector-ref entry 1)] + [cleanup (vector-ref entry 2)]) + ((*resource-finalizer-log*) type info) + ;; Best-effort cleanup + (guard (exn [#t (void)]) + (when cleanup (cleanup))))) + (loop (+ count 1))))))) + + ;; ========================================================================= + ;; Argument checking + ;; ========================================================================= + (define (check-arg! who pred val type-name) (when (eq? (*safe-mode*) 'check) (unless (pred val) @@ -119,11 +179,11 @@ (define raw-sqlite-bind-null #f) (define raw-sqlite-errmsg #f) - ;; Try to load sqlite bindings at library init time + ;; Try to load sqlite bindings at library init time. + ;; Set sqlite-available? LAST so partial failure leaves it #f. (define _init-sqlite - (guard (exn [#t (void)]) + (guard (exn [#t (set! sqlite-available? #f) (void)]) (let ([env (environment '(std db sqlite-native))]) - (set! sqlite-available? #t) (set! raw-sqlite-open (eval 'sqlite-open env)) (set! raw-sqlite-close (eval 'sqlite-close env)) (set! raw-sqlite-exec (eval 'sqlite-exec env)) @@ -136,7 +196,9 @@ (set! raw-sqlite-bind-double (eval 'sqlite-bind-double env)) (set! raw-sqlite-bind-text (eval 'sqlite-bind-text env)) (set! raw-sqlite-bind-null (eval 'sqlite-bind-null env)) - (set! raw-sqlite-errmsg (eval 'sqlite-errmsg env))))) + (set! raw-sqlite-errmsg (eval 'sqlite-errmsg env)) + ;; Only mark available after ALL evals succeed + (set! sqlite-available? #t)))) (define (ensure-sqlite! who) (unless sqlite-available? @@ -145,9 +207,59 @@ (make-message-condition (format #f "~a: SQLite not available — libjerboa_native.so not loaded" who)))))) + ;; ---- SQL injection heuristic detection ---- + ;; Reject SQL strings that look like they were built by concatenation. + ;; Heuristic: flag strings containing common injection markers that + ;; suggest runtime string building rather than parameterized queries. + + (define (check-sql-safety! who sql) + (when (eq? (*safe-mode*) 'check) + ;; Check for obviously unsafe patterns: + ;; 1. Unbalanced quotes (sign of string injection) + ;; 2. Multiple semicolons (multi-statement injection) + ;; 3. Comment markers that could hide injected SQL + (let ([len (string-length sql)]) + ;; Multiple statements via semicolons (allowing trailing ;) + (let ([semis (let count ([i 0] [n 0]) + (if (>= i len) n + (count (+ i 1) + (if (char=? (string-ref sql i) #\;) (+ n 1) n))))]) + (when (> semis 1) + (raise (condition + (make-db-query-error 'db 'sqlite sql) + (make-message-condition + (format #f "~a: SQL contains ~a semicolons — use separate queries or parameterized statements" + who semis)))))) + ;; SQL comment injection: -- or /* outside of string literals + (when (or (string-contains-outside-quotes? sql "--") + (string-contains-outside-quotes? sql "/*")) + (raise (condition + (make-db-query-error 'db 'sqlite sql) + (make-message-condition + (format #f "~a: SQL contains comment markers — possible injection" + who)))))))) + + (define (string-contains-outside-quotes? str pattern) + ;; Simple scan: check if pattern appears outside single-quoted SQL strings. + (let ([slen (string-length str)] + [plen (string-length pattern)]) + (let loop ([i 0] [in-quote? #f]) + (cond + [(> (+ i plen) slen) #f] + [(char=? (string-ref str i) #\') + (loop (+ i 1) (not in-quote?))] + [(and (not in-quote?) + (string=? (substring str i (+ i plen)) pattern)) + #t] + [else (loop (+ i 1) in-quote?)])))) + + ;; Track sqlite handle → guardian entry for leak detection + (define *sqlite-handle-entries* (make-hashtable equal-hash equal?)) + (define (safe-sqlite-open path) ;; Pre: path must be a string ;; Post: returns a valid db handle (non-negative fixnum) + ;; Safety: registers handle with guardian for leak detection (check-string! 'safe-sqlite-open path) (ensure-sqlite! 'safe-sqlite-open) (let ([handle (raw-sqlite-open path)]) @@ -157,12 +269,22 @@ (make-db-connection-error 'db 'sqlite) (make-message-condition (format #f "failed to open database: ~a" path)))))) + ;; Register with guardian for leak detection + (let ([entry (register-guarded-resource! + handle 'sqlite path + (and raw-sqlite-close + (lambda () (raw-sqlite-close handle))))]) + (hashtable-set! *sqlite-handle-entries* handle entry)) handle)) (define (safe-sqlite-close db) ;; Pre: db must be a fixnum handle (check-fixnum! 'safe-sqlite-close db) (ensure-sqlite! 'safe-sqlite-close) + ;; Mark as closed so guardian won't warn + (let ([entry (hashtable-ref *sqlite-handle-entries* db #f)]) + (mark-resource-closed! entry) + (hashtable-delete! *sqlite-handle-entries* db)) (raw-sqlite-close db)) (define (safe-sqlite-exec db sql) @@ -170,6 +292,7 @@ ;; Post: returns 0 on success (check-fixnum! 'safe-sqlite-exec db) (check-string! 'safe-sqlite-exec sql) + (check-sql-safety! 'safe-sqlite-exec sql) (ensure-sqlite! 'safe-sqlite-exec) (let ([rc (raw-sqlite-exec db sql)]) (when-checking @@ -187,6 +310,7 @@ ;; Pre: db is fixnum handle, sql is string, params is list (check-fixnum! 'safe-sqlite-execute db) (check-string! 'safe-sqlite-execute sql) + (check-sql-safety! 'safe-sqlite-execute sql) (ensure-sqlite! 'safe-sqlite-execute) (apply raw-sqlite-execute db sql params)) @@ -195,6 +319,7 @@ ;; Post: returns a list of alists (check-fixnum! 'safe-sqlite-query db) (check-string! 'safe-sqlite-query sql) + (check-sql-safety! 'safe-sqlite-query sql) (ensure-sqlite! 'safe-sqlite-query) (let ([result (apply raw-sqlite-query db sql params)]) (when-checking @@ -207,6 +332,7 @@ (define (safe-sqlite-prepare db sql) (check-fixnum! 'safe-sqlite-prepare db) (check-string! 'safe-sqlite-prepare sql) + (check-sql-safety! 'safe-sqlite-prepare sql) (ensure-sqlite! 'safe-sqlite-prepare) (let ([stmt (raw-sqlite-prepare db sql)]) (when-checking @@ -261,17 +387,19 @@ (define raw-tcp-write #f) (define raw-tcp-write-string #f) + ;; Set tcp-raw-available? LAST so partial failure leaves it #f. (define _init-tcp - (guard (exn [#t (void)]) + (guard (exn [#t (set! tcp-raw-available? #f) (void)]) (let ([env (environment '(std net tcp-raw))]) - (set! tcp-raw-available? #t) (set! raw-tcp-connect (eval 'tcp-connect env)) (set! raw-tcp-listen (eval 'tcp-listen env)) (set! raw-tcp-accept (eval 'tcp-accept env)) (set! raw-tcp-close (eval 'tcp-close env)) (set! raw-tcp-read (eval 'tcp-read env)) (set! raw-tcp-write (eval 'tcp-write env)) - (set! raw-tcp-write-string (eval 'tcp-write-string env))))) + (set! raw-tcp-write-string (eval 'tcp-write-string env)) + ;; Only mark available after ALL evals succeed + (set! tcp-raw-available? #t)))) (define (ensure-tcp! who) (unless tcp-raw-available? @@ -280,6 +408,9 @@ (make-message-condition (format #f "~a: TCP not available" who)))))) + ;; Track tcp fd → guardian entry for leak detection + (define *tcp-handle-entries* (make-hashtable equal-hash equal?)) + (define (safe-tcp-connect address port) (check-string! 'safe-tcp-connect address) (check-fixnum! 'safe-tcp-connect port) @@ -294,6 +425,11 @@ (make-connection-refused 'network address port) (make-message-condition (format #f "connection refused: ~a:~a" address port)))))) + ;; Register with guardian for leak detection + (let ([entry (register-guarded-resource! + fd 'tcp (format #f "~a:~a" address port) + (and raw-tcp-close (lambda () (raw-tcp-close fd))))]) + (hashtable-set! *tcp-handle-entries* fd entry)) fd)) (define (safe-tcp-listen address port . rest) @@ -313,6 +449,10 @@ (define (safe-tcp-close fd) (check-fixnum! 'safe-tcp-close fd) (ensure-tcp! 'safe-tcp-close) + ;; Mark as closed so guardian won't warn + (let ([entry (hashtable-ref *tcp-handle-entries* fd #f)]) + (mark-resource-closed! entry) + (hashtable-delete! *tcp-handle-entries* fd)) (raw-tcp-close fd)) (define (safe-tcp-read fd buf len) @@ -385,12 +525,13 @@ (define raw-read-json #f) (define raw-string->json-object #f) + ;; Set json-available? LAST so partial failure leaves it #f. (define _init-json - (guard (exn [#t (void)]) + (guard (exn [#t (set! json-available? #f) (void)]) (let ([env (environment '(std text json))]) - (set! json-available? #t) (set! raw-read-json (eval 'read-json env)) - (set! raw-string->json-object (eval 'string->json-object env))))) + (set! raw-string->json-object (eval 'string->json-object env)) + (set! json-available? #t)))) (define (safe-read-json port) (when-checking new file mode 100644 --- /dev/null +++ b/tests/test-safe-prelude.ss @@ -0,0 +1,232 @@ +#!chezscheme +;;; Tests for safe-by-default prelude, finalizer safety net, lint rules, +;;; and SQL injection detection. + +(import (chezscheme) + (std safe) + (std lint) + (std error conditions)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (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)))))])) + +(printf "--- Safe Prelude & Safety Net Tests ---~%~%") + +;; ========================================================================= +;; 1. Finalizer safety net infrastructure +;; ========================================================================= + +(printf "~%-- Finalizer safety net --~%") + +(test "poll-resource-finalizers! returns 0 when clean" + (begin (collect) (poll-resource-finalizers!)) + 0) + +(test "*resource-finalizer-log* is a parameter" + (procedure? *resource-finalizer-log*) + #t) + +(test "custom finalizer log captures warnings" + (let ([warnings '()]) + (parameterize ([*resource-finalizer-log* + (lambda (type info) + (set! warnings (cons (cons type info) warnings)))]) + ;; Polling with nothing pending should be fine + (poll-resource-finalizers!) + (null? warnings))) + #t) + +;; ========================================================================= +;; 2. Lint: unsafe-import rule +;; ========================================================================= + +(printf "~%-- Lint: unsafe-import rule --~%") + +(test "unsafe-import: sqlite-native flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(import (std db sqlite-native))")] + [rules (map lint-result-rule results)]) + (if (memq 'unsafe-import rules) #t #f)) + #t) + +(test "unsafe-import: tcp-raw flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(import (std net tcp-raw))")] + [rules (map lint-result-rule results)]) + (if (memq 'unsafe-import rules) #t #f)) + #t) + +(test "unsafe-import: wrapped import still flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(import (except (std db sqlite-native) sqlite-close))")] + [rules (map lint-result-rule results)]) + (if (memq 'unsafe-import rules) #t #f)) + #t) + +(test "unsafe-import: safe import not flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(import (std safe))")] + [rules (map lint-result-rule results)]) + (if (memq 'unsafe-import rules) #f #t)) + #t) + +(test "unsafe-import: jerboa prelude safe not flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(import (jerboa prelude safe))")] + [rules (map lint-result-rule results)]) + (if (memq 'unsafe-import rules) #f #t)) + #t) + +;; ========================================================================= +;; 3. Lint: bare-error rule +;; ========================================================================= + +(printf "~%-- Lint: bare-error rule --~%") + +(test "bare-error: (error 'who msg) flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(error 'test \"something broke\")")] + [rules (map lint-result-rule results)]) + (if (memq 'bare-error rules) #t #f)) + #t) + +(test "bare-error: (error? x) not flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(error? x)")] + [rules (map lint-result-rule results)]) + (if (memq 'bare-error rules) #f #t)) + #t) + +(test "bare-error: raise with condition not flagged" + (let* ([linter (make-linter)] + [results (lint-string linter "(raise (condition (make-db-error 'db 'sqlite)))")] + [rules (map lint-result-rule results)]) + (if (memq 'bare-error rules) #f #t)) + #t) + +;; ========================================================================= +;; 4. Lint: sql-interpolation rule +;; ========================================================================= + +(printf "~%-- Lint: sql-interpolation rule --~%") + +(test "sql-interpolation: string-append flagged" + (let* ([linter (make-linter)] + [results (lint-string linter + "(sqlite-exec db (string-append \"SELECT * FROM \" table))")] + [rules (map lint-result-rule results)]) + (if (memq 'sql-interpolation rules) #t #f)) + #t) + +(test "sql-interpolation: format flagged" + (let* ([linter (make-linter)] + [results (lint-string linter + "(sqlite-query db (format \"SELECT * FROM ~a\" table) )")] + [rules (map lint-result-rule results)]) + (if (memq 'sql-interpolation rules) #t #f)) + #t) + +(test "sql-interpolation: safe-sqlite-exec flagged too" + (let* ([linter (make-linter)] + [results (lint-string linter + "(safe-sqlite-exec db (string-append \"DROP TABLE \" t))")] + [rules (map lint-result-rule results)]) + (if (memq 'sql-interpolation rules) #t #f)) + #t) + +(test "sql-interpolation: literal string not flagged" + (let* ([linter (make-linter)] + [results (lint-string linter + "(sqlite-query db \"SELECT * FROM users WHERE id = ?\" user-id)")] + [rules (map lint-result-rule results)]) + (if (memq 'sql-interpolation rules) #f #t)) + #t) + +;; ========================================================================= +;; 5. SQL safety runtime checks +;; ========================================================================= + +(printf "~%-- SQL safety runtime checks --~%") + +(test "check-sql-safety!: clean SQL passes" + (guard (exn [#t #f]) + ;; Internal function, but we can test via the safe-sqlite wrappers. + ;; Since sqlite may not be loaded, test the check indirectly: + ;; A clean SQL string should not raise from the safety check itself. + ;; We use *safe-mode* = 'check and call with a deliberately unavailable db + ;; — the sql-safety check runs before the ensure-sqlite! check. + (parameterize ([*safe-mode* 'check]) + (guard (exn + [(db-error? exn) #t] ;; expected: sqlite not available + [#t #f]) + (safe-sqlite-exec 0 "SELECT 1") + #t))) + #t) + +(test "check-sql-safety!: multi-semicolon rejected" + (guard (exn + [(and (db-query-error? exn) + (message-condition? exn)) + (let ([msg (condition-message exn)]) + (and (string? msg) + ;; Should mention semicolons + (> (string-length msg) 0)))] + [#t #f]) + (parameterize ([*safe-mode* 'check]) + (safe-sqlite-exec 0 "DROP TABLE users; DELETE FROM logs; --") + #f)) + #t) + +(test "check-sql-safety!: comment injection rejected" + (guard (exn + [(and (db-query-error? exn) + (message-condition? exn)) + #t] + [#t #f]) + (parameterize ([*safe-mode* 'check]) + (safe-sqlite-exec 0 "SELECT * FROM users WHERE 1=1 -- AND password='x'") + #f)) + #t) + +(test "check-sql-safety!: release mode skips check" + (guard (exn + [(db-error? exn) #t] ;; sqlite not available — that's fine + [#t #f]) + (parameterize ([*safe-mode* 'release]) + ;; In release mode, the SQL safety check is skipped + (safe-sqlite-exec 0 "DROP TABLE users; DELETE FROM logs; --") + #t)) + #t) + +;; ========================================================================= +;; 6. Lint rule enumeration +;; ========================================================================= + +(printf "~%-- Rule enumeration --~%") + +(test "new rules present in default linter" + (let ([names (lint-rule-names (make-linter))]) + (and (memq 'unsafe-import names) + (memq 'bare-error names) + (memq 'sql-interpolation names) + #t)) + #t) + +;; ========================================================================= +;; Summary +;; ========================================================================= + +(printf "~%Safe prelude tests: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1))