security: fix all P0-P5 issues from security review
ober
72b4726e5afb366a8d0ee19b21b2d136858f259b
--- a/data/anti-patterns.sexp +++ b/data/anti-patterns.sexp @@ -5088,4 +5088,55 @@ ("title" . "Applying a perf optimization that changes observable semantics without a safety gate") - ("tools" "jerboa_howto"))) + ("tools" "jerboa_howto")) + (("advice" + . + "Capture parameter values in the parent thread and re-parameterize inside the spawned thunk, at every spawn site. After any security-mode refactor, grep all spawn sites for parameter capture. See cookbook recipe spawn-thread-parameter-capture.") + ("avoid" + . + "Storing security modes/scopes/allowlists in Chez parameters and reading them inside spawned threads, assuming parameterize bindings cross thread creation. Chez parameters reset to defaults in new threads — the child silently sees defaults.") + ("id" . "chez-parameter-not-inherited-by-spawn") + ("kinds" "debug" "review" "refactor") + ("pattern" . "parameterize.*spawn|spawn.*current-") + ("severity" . "high") + ("tags" "spawn" "thread" "parameterize" "plan-mode" + "sandbox") + ("title" + . + "Assuming Chez parameters are inherited by spawned threads") + ("tools" "jerboa_howto" "jerboa_verify")) + (("advice" + . + "Narrow guard conditions (error? and specific who), re-raise conditions that signal policy/budget violations (e.g. (raise e) for known sentinels), and rate-limited-log every swallowed path. See kimi-3-massive-scan.md theme #2.") + ("avoid" + . + "Wrapping security-relevant operations (auth checks, archive-budget limits, dir-locals application, backup writes, fetch fan-outs) in catch-all guards that return #f/(void) with no logging. Auth failures, attacks, and corruption become invisible; several findings were fail-OPEN because of this (virus scan budget, secmon handler, gitsafe skips, smtp session errors).") + ("id" . "catch-all-guard-swallow-security") + ("kinds" "review" "debug") + ("pattern" + . + "guard \\(e \\[#t|with-catch \\(lambda \\(e\\) #f|catch \\(e\\) #f") + ("severity" . "high") + ("tags" "guard" "with-catch" "swallowed-exceptions" + "fail-open" "logging") + ("title" + . + "Catch-all exception swallowing on security-relevant paths") + ("tools" "jerboa_security_scan" "jerboa_howto")) + (("advice" + . + "Operate on fds not paths: openat(O_NOFOLLOW)/fchmodat(AT_SYMLINK_NOFOLLOW)/dirfd walks, or re-lstat the OPEN fd and compare dev/ino. Model implementations: coreutils_remove_tree (openat), jerboa-search mmap fstat, shred.ss O_NOFOLLOW.") + ("avoid" + . + "Classifying a path with lstat/file-exists?/file-directory? and then acting on the same path by name (chmod, open, copy, delete) — an attacker swaps in a symlink between the two calls. Found in coreutils chmod/chown/cp -r, gitsafe walker, virus scan, virii infect, jemacs backup, temp-home rm-rf recursion.") + ("id" . "lstat-then-path-act-toctou") + ("kinds" "review" "debug") + ("pattern" + . + "lstat.*chmod|file-exists\\\\?.*open|file-directory\\\\?.*recurs") + ("severity" . "high") + ("tags" "toctou" "symlink" "lstat" "openat" "O_NOFOLLOW") + ("title" + . + "lstat-then-act-by-pathname TOCTOU on filesystem operations") + ("tools" "jerboa_security_scan"))) --- a/data/cookbooks.sexp +++ b/data/cookbooks.sexp @@ -7090,4 +7090,40 @@ "integrity" "seal") ("title" . - "Append-only hash-chained incremental sealing (O(delta) integrity)"))) + "Append-only hash-chained incremental sealing (O(delta) integrity)")) + (("code" + . + "(import (jerboa prelude))\n(import (std misc thread))\n\n;; WRONG: parameters rebind to defaults inside the spawned thread\n;; (parameterize ([current-mode 'plan])\n;; (spawn (lambda () (current-mode)))) ;; => 'build (default!), NOT 'plan\n;; This silently disabled jerboa-code's read-only PLAN mode (tui.ss:1635):\n;; the agent-loop worker saw the default mode and write/bash tools ran.\n\n;; RIGHT: capture values OUTSIDE, re-parameterize INSIDE the thunk\n(def (spawn-with-params thunk)\n (let ([mode (current-mode)] ;; capture in parent thread\n [scope (current-write-scope)])\n (spawn\n (lambda ()\n (parameterize ([current-mode mode] ;; re-bind in child thread\n [current-write-scope scope])\n (thunk))))))\n\n;; For real parameters substitute your own; the point is the capture/\n;; re-parameterize pair at EVERY spawn site (worker loops, parallel tool\n;; batches, serve-mode handlers, sub-agent tasks — all 4 were buggy in\n;; jerboa-code: tui.ss, agent.ss, batch.ss, serve.ss, task.ss).\n") ("id" . "spawn-thread-parameter-capture") + ("imports" "(jerboa prelude)" "(std misc thread)") + ("notes" + . + "Chez parameters are thread-local; `spawn` (std misc thread) starts the thunk with DEFAULT parameter values, not the parent's dynamic bindings. This bit jerboa-code's PLAN mode (read-only safety control silently off), write scopes, and disabled-tools lists. Applies to every concurrency primitive built on Chez threads. Fiber parameters (make-fiber-parameter) have the same non-inheritance property — see fiber-semaphore-local-storage recipe. Audit any security mode/scope stored in a parameter whenever a spawn site is added.") + ("tags" "spawn" "thread" "parameterize" "current-mode" + "plan-mode" "std-misc-thread") + ("title" + . + "Chez parameters are NOT inherited by spawned threads — capture and re-parameterize")) + (("code" + . + "(import (chezscheme))\n\n;; A C shim returning NULL void* gives Scheme the INTEGER 0.\n;; 0 is TRUTHY in Scheme — (if handle ...) succeeds on failure!\n;;\n;; (def handle (c-spawn ...))\n;; (if handle ...use...) ;; WRONG: handle = 0 passes, later ops crash\n;;\n;; Seen in jerboa-term alacritty-term.ss:252 — spawn failure wrapped\n;; handle 0 into a live session; jt-last-error never surfaced.\n\n;; RIGHT: explicit zero check on every FFI handle/pointer return\n(def c-spawn (foreign-procedure \"jt_spawn\" (string) void*))\n\n(def (spawn-checked cmd)\n (let ([h (c-spawn cmd)])\n (if (and h (not (= h 0)))\n h\n (error 'spawn \"native spawn failed\" cmd))))\n\n;; When you control the shim, prefer `uptr` for raw pointer returns and\n;; compare against 0 (see jerboa-rust-ffi-uptr-not-void recipe).\n") ("id" . "ffi-null-handle-truthiness") + ("imports" "(chezscheme)") + ("notes" + . + "Applies to void*, uptr, and any integer-returning FFI status/handle. For `string` return types NULL is worse — it can segfault before Scheme sees it (see chez-ffi-null-c-string-gotcha). Fix shims to return 0/\"\" and check explicitly; truthiness is never a NULL check in Scheme.") + ("tags" "ffi" "foreign-procedure" "null" "void-pointer" + "truthy" "handle") + ("title" + . + "FFI NULL handle returns as integer 0 — truthy in Scheme, check (= h 0)")) + (("code" + . + "(import (jerboa prelude))\n(import (std os temp))\n\n;; WRONG (found across the fleet: jerboa core shell.ss, jemacs, shell-extras):\n;; (def p (string-append \"/tmp/myapp-\" (number->string (random 999999999))))\n;; (with-output-to-file p ...) ;; follows pre-planted symlinks, umask perms\n;; Problems: predictable names (unseeded random is identical across process\n;; starts), symlink clobber via > redirection, world-readable contents,\n;; leaked on exception.\n\n;; RIGHT: mkstemp-style creation from (std os temp)\n(def (with-private-temp-file proc)\n (call-with-temporary-file\n (lambda (path port)\n ;; path is O_EXCL-created, mode 0600, owned by us\n (proc path port))))\n\n;; One-shot handles (arity 0 or 1):\n(def p (make-temporary-file)) ;; or (make-temporary-file \"myapp-\")\n\n;; Whole private directories (0700) for runtime state:\n(call-with-temporary-directory\n (lambda (dir)\n (displayln dir)))\n\n;; For secrets: write via the returned port/path, never chmod-after-write\n;; (that's a race window); delete in finally if the file must not persist.\n") ("id" . "secure-temp-file-mkstemp") + ("imports" "(jerboa prelude)" "(std os temp)") + ("notes" + . + "Classic /tmp attacks need three properties removed: predictability, symlink-following, and permissive modes — mkstemp-style O_EXCL creation removes all three atomically. chmod-after-write still leaves a umask window. When writing into a shared dir yourself instead, use O_CREAT|O_EXCL|O_NOFOLLOW with mode 0600 at open time (see jerboa-shell histfile for the model implementation: O_WRONLY|O_CREAT|O_TRUNC|O_NOFOLLOW, 0600, atomic).") + ("tags" "temp-file" "mkstemp" "symlink" "O_EXCL" "0600" + "std-os-temp") + ("title" + . + "Secure temp files via (std os temp) — never hand-roll /tmp names"))) --- a/data/features.sexp +++ b/data/features.sexp @@ -3866,4 +3866,37 @@ ("use_case" . "Enforcing that every repo in a workspace has lint and security gates, or finding gaps after onboarding new repos.") - ("votes" . 0))) + ("votes" . 0)) + (("description" + . + "A fleet audit today required 10 hand-orchestrated subagents to review ~60 jerboa* repos. jerboa_security_scan only accepts one project_path/file_path per call. Add either (a) a project_paths array parameter, or (b) a jerboa_fleet_scan tool that scans multiple repos, dedupes by pattern id, and emits one aggregate report grouped by repo and severity.") + ("estimated_token_reduction" + . + "eliminates 10+ tool calls and manual aggregation per fleet scan") + ("example_scenario" + . + "User asks 'scan all ~/mine/jerboa* repos for security issues'. Today: spawn agents or call jerboa_security_scan 60 times and merge JSON by hand. With this: one call returns the merged, severity-sorted report.") + ("id" . "fleet-security-scan") ("impact" . "high") + ("status" . "proposed") + ("tags" "security" "fleet" "multi-repo" "aggregate" "scan") + ("title" . "Multi-repo/fleet security scan mode") + ("use_case" + . + "Auditing many sibling repos in one pass (release gate, fleet-wide hygiene review, cross-repo pattern dedup).") + ("votes" . 0)) + (("description" + . + "jerboa_anti_pattern_lookup currently throws 'Exception in string-downcase: (\"FileNotFoundException.*\\\\\\\\.csv|AssetManager.*open|box_types\") is not a string' on every query — at least one entry in data/anti-patterns.sexp has a list-valued pattern (or another string) field. Load-time schema validation should reject or report the offending entry id instead of crashing all lookups.") + ("estimated_token_reduction" + . + "restores a broken tool; avoids repeated failed calls") + ("example_scenario" + . + "Call jerboa_anti_pattern_lookup with any task — it errors instead of returning matches, so agents can't dedupe-check before anti_pattern_add.") + ("id" . "anti-pattern-schema-validation") + ("impact" . "medium") ("status" . "proposed") + ("tags" "anti-patterns" "validation" "data-quality" "bug") + ("title" + . + "Validate anti-patterns.sexp schema at load (lookup currently crashes)") + ("use_case" . "") ("votes" . 0))) --- a/data/security-rules.sexp +++ b/data/security-rules.sexp @@ -1244,4 +1244,29 @@ . "content-hash|sha256.*truncat|subvector.*0.*8|bytevector-copy.*0.*8") ("scope" . "scheme") + ("severity" . "medium")) + (("id" . "guard-swallow-all-conditions") + ("message" + . + "Catch-all guard/with-catch swallowing every condition to #f or (void). On security-relevant paths (auth, budget/limit enforcement, persistence) this hides attacks and turns fail-closed into fail-open. Fleet findings: virus/scan.ss budget swallow (detection evasion), secmon listener guard (invisible brute-force), smtp session errors, gitsafe silent skips.") + ("pattern" + . + "\\\\(guard \\\\(e \\\\[#t|\\\\(with-catch \\\\(lambda \\\\([a-zA-Z_]*\\\\) \\\\(#f|\\\\(void\\\\)\\\\)") + ("scope" . "scheme") + ("severity" . "medium")) + (("id" . "collect-safe-unpinned-bytevector") + ("message" + . + "foreign-procedure declared __collect_safe receives raw Scheme bytevectors/strings. During a long collect-safe call, Chez's moving collector can relocate the object — the C side then reads freed/moved heap (UAF/crash). Found in jerboa-treesitter ffi.ss:204 (5s parse timeout on unpinned source bytevector). jerboa-scintilla documents and fixes this exact hazard via pinning.") + ("pattern" . "__collect_safe") + ("scope" . "ffi-boundary") + ("severity" . "high")) + (("id" . "secret-via-argv-flag") + ("message" + . + "Secret accepted as a command-line flag value — visible to all local users via ps//proc/*/cmdline and persisted in shell history. Found in jerboa-shell-extras yubi.ss (ykman -p), webex --secret, drive --access-token/--refresh-token/--totp-code, wormhole --code, jerboa-code serve --token.") + ("pattern" + . + "\"--?(token|secret|password|passwd|api[-_]?key|access[-_]?token|refresh[-_]?token|totp[-_]?code|webhook[-_]?secret)\"") + ("scope" . "scheme") ("severity" . "medium"))) new file mode 100644 --- /dev/null +++ b/jpkg.lock @@ -0,0 +1,7 @@ +;; jpkg.lock — generated by jpkg; records the exact resolved +;; dependency graph. Do not edit by hand. +(lock + (version 1) + (packages + ()) + ) --- a/lib/std/crypto/native-rust.ss +++ b/lib/std/crypto/native-rust.ss @@ -230,7 +230,7 @@ ;; Converts N to log2(N) for the Rust API. (def (rust-scrypt password salt output-len n r p) (let* ([pw (if (string? password) (string->utf8 password) password)] - [s (if (string? password) (string->utf8 salt) salt)] + [s (if (string? salt) (string->utf8 salt) salt)] [log-n (bitwise-length (- n 1))] ;; log2(16384) = 14 [out (make-bytevector output-len)]) (let ([rc (c-jerboa-scrypt pw (bytevector-length pw) --- a/lib/std/crypto/password.ss +++ b/lib/std/crypto/password.ss @@ -52,6 +52,12 @@ (def default-argon2id-t-cost 2) ;; 2 iterations (def default-argon2id-p-cost 1) ;; 1 thread + ;; Upper bounds to prevent resource exhaustion attacks + (def max-argon2id-m-cost 1048576) ;; 1 GiB (1,048,576 KiB) + (def max-argon2id-t-cost 1000000) ;; 1M iterations + (def max-argon2id-p-cost 1024) ;; max parallelism + (def max-pbkdf2-iterations 1000000) ;; 1M iterations + ;; ========== Public API ========== (def default-iterations 600000) ;; OWASP 2023 recommendation for PBKDF2-SHA256 @@ -73,6 +79,13 @@ [p-cost (kwarg 'parallelism: opts default-argon2id-p-cost)] [salt (kwarg 'salt: opts (make-password-salt))] [out (make-bytevector default-key-len)]) + ;; Enforce upper bounds to prevent resource exhaustion attacks + (when (> m-cost max-argon2id-m-cost) + (error 'password-hash-argon2id "memory cost exceeds maximum")) + (when (> t-cost max-argon2id-t-cost) + (error 'password-hash-argon2id "time cost exceeds maximum")) + (when (> p-cost max-argon2id-p-cost) + (error 'password-hash-argon2id "parallelism exceeds maximum")) (let ([rc (c-jerboa-argon2id-hash pass-bv (bytevector-length pass-bv) salt (bytevector-length salt) m-cost t-cost p-cost @@ -93,7 +106,8 @@ (let ([parts (string-split-dollar hash-string)]) (unless (and (>= (length parts) 5) (string=? (cadr parts) "argon2id")) - (error 'password-verify-argon2id "invalid hash format" hash-string)) + ;; Security: Don't leak hash string in error message + (error 'password-verify-argon2id "invalid hash format")) (let* ([params-str (caddr parts)] [m-cost (parse-argon2-param params-str "m=")] [t-cost (parse-argon2-param params-str "t=")] @@ -101,6 +115,13 @@ [salt (hex->bytevector (cadddr parts))] [expected (hex->bytevector (list-ref parts 4))] [pass-bv (if (string? password) (string->utf8 password) password)]) + ;; Enforce upper bounds to prevent resource exhaustion attacks + (when (> m-cost max-argon2id-m-cost) + (error 'password-verify-argon2id "memory cost exceeds maximum")) + (when (> t-cost max-argon2id-t-cost) + (error 'password-verify-argon2id "time cost exceeds maximum")) + (when (> p-cost max-argon2id-p-cost) + (error 'password-verify-argon2id "parallelism exceeds maximum")) (let ([rc (c-jerboa-argon2id-verify pass-bv (bytevector-length pass-bv) salt (bytevector-length salt) m-cost t-cost p-cost @@ -138,6 +159,9 @@ [salt (kwarg 'salt: opts (make-password-salt))] [out (rust-pbkdf2-derive pass-bv salt iterations default-key-len)]) + ;; Enforce upper bounds to prevent resource exhaustion attacks + (when (> iterations max-pbkdf2-iterations) + (error 'password-hash-pbkdf2 "iterations exceed maximum")) (string-append "$pbkdf2-sha256$" (number->string iterations) "$" (bytevector->hex salt) "$" @@ -155,7 +179,8 @@ (string=? (cadr parts) "pbkdf2-sha256")) (password-verify-pbkdf2 password parts)] [else - (error 'password-verify "unknown hash format" hash-string)]))) + ;; Security: Don't leak hash string in error message + (error 'password-verify "unknown hash format")]))) (def (password-verify-pbkdf2 password parts) (let* ([iterations (string->number (caddr parts))] --- a/lib/std/db/conpool.ss +++ b/lib/std/db/conpool.ss @@ -65,7 +65,10 @@ [cv (connection-pool-available-cv pool)]) (mutex-acquire mtx) (let loop () - (pool-check-open pool 'pool-acquire) + ;; Check pool is open — release mutex before raising to avoid deadlock + (when (connection-pool-closed? pool) + (mutex-release mtx) + (error 'pool-acquire "connection pool is closed")) (let ([idle (connection-pool-idle pool)]) (cond ;; Idle connection available: take it @@ -83,9 +86,21 @@ (connection-pool-total-set! pool (fx+ (connection-pool-total pool) 1)) (mutex-release mtx) - ;; Create connection outside the lock - (let ([conn ((connection-pool-connector pool))]) - conn)] + ;; Create connection outside the lock + (let ([result + (try + ((connection-pool-connector pool)) + (catch (e) + (mutex-acquire mtx) + (connection-pool-active-set! pool + (fx- (connection-pool-active pool) 1)) + (connection-pool-total-set! pool + (fx- (connection-pool-total pool) 1)) + (mutex-release mtx) + (cons 'error e)))]) + (if (and (pair? result) (eq? (car result) 'error)) + (raise (cdr result)) + result))] ;; At capacity — wait [else (condition-wait cv mtx) --- a/lib/std/db/query-compile.ss +++ b/lib/std/db/query-compile.ss @@ -142,10 +142,29 @@ "?") (def (col->sql col) - (cond - [(symbol? col) (symbol->string col)] - [(string? col) col] - [else (error 'compile-query "invalid column reference" col)])) + ;; Security: Validate column names to prevent SQL injection. + ;; Only alphanumeric characters and underscores are allowed. + (let ([s (cond + [(symbol? col) (symbol->string col)] + [(string? col) col] + [else (error 'compile-query "invalid column reference" col)])]) + (unless (valid-identifier? s) + (error 'compile-query "invalid column identifier (must be alphanumeric or underscore)" s)) + s)) + + (def (valid-identifier? s) + ;; Check that identifier only contains safe characters: [a-zA-Z0-9_] + (let ([n (string-length s)]) + (let loop ([i 0]) + (cond + [(= i n) #t] ; All characters valid + [else + (let ([c (string-ref s i)]) + (if (or (char-alphabetic? c) + (char-numeric? c) + (char=? c #\_)) + (loop (+ i 1)) + #f))])))) (def (op->sql op) (case op --- a/lib/std/net/thread-httpd.ss +++ b/lib/std/net/thread-httpd.ss @@ -630,6 +630,20 @@ [else (loop (+ i 1) (+ i 1) (cons part acc))]))] [else (loop (+ i 1) start acc)])))) + (def (sanitize-header-value s) + ;; Prevent CRLF injection by removing \r and \n characters. + ;; HTTP response splitting attacks rely on injecting \r\n to add + ;; fake headers or terminate the response early. + (let ([n (string-length s)]) + (let loop ([i 0] [chars '()]) + (cond + [(= i n) (list->string (reverse chars))] + [else + (let ([c (string-ref s i)]) + (if (or (char=? c #\return) (char=? c #\newline)) + (loop (+ i 1) chars) ; Skip CRLF characters + (loop (+ i 1) (cons c chars))))])))) + (def (string-trim s) (let* ([n (string-length s)] [start (let lp ([i 0]) @@ -727,9 +741,10 @@ (for-each (lambda (p) (display (car p) out) - (display ": " out) - (display (cdr p) out) - (display "\r\n" out)) + (display ": " out) + ;; Security: Sanitize header values to prevent CRLF injection + (display (sanitize-header-value (cdr p)) out) + (display "\r\n" out)) headers) (display "Content-Length: " out) (display body-len out) --- a/lib/std/os/shell.ss +++ b/lib/std/os/shell.ss @@ -79,9 +79,10 @@ [(cmd) (shell/status cmd #f)] [(cmd dir) (let* ([full (if dir (string-append "cd " (sq dir) " && " cmd) cmd)] - ;; Redirect to temp files and capture exit code - [stdout-file (format "/tmp/jerboa-sh-out-~a" (random 999999999))] - [stderr-file (format "/tmp/jerboa-sh-err-~a" (random 999999999))] + ;; Redirect to temp files and capture exit code + ;; Use crypto-secure random for temp file names + [stdout-file (format "/tmp/jerboa-sh-out-~a" (random-hex 16))] + [stderr-file (format "/tmp/jerboa-sh-err-~a" (random-hex 16))] [wrapper (format "(~a) >~a 2>~a; echo $?" full (sq stdout-file) (sq stderr-file))] ) (let-values ([(to-stdin from-stdout from-stderr pid) @@ -153,17 +154,18 @@ ;; ========== Helpers ========== (def (sq s) - ;; Single-quote shell escaping + ;; Single-quote shell escaping with full metacharacter protection (if (and (> (string-length s) 0) - (not (string-contains-char? s #\')) - (not (string-contains-char? s #\space)) - (not (string-contains-char? s #\$)) - (not (string-contains-char? s #\`)) - (not (string-contains-char? s #\\)) - (not (string-contains-char? s #\"))) + (not (string-contains-any-char? s shell-metachars))) s (string-append "'" (string-replace-all* s "'" "'\"'\"'") "'"))) + (def shell-metachars + ;; Shell metacharacters that require quoting + ;; $ ` \ " ' space | & ; > < ( ) ~ { } * ? [ ] ! # = newline + (list #\' #\space #\$ #\` #\\ #\" #\| #\& #\; #\> #\< #\( #\) + #\~ #\{ #\} #\* #\? #\[ #\! #\# #\= #\newline)) + (def (string-contains-char? s c) (let ([n (string-length s)]) (let loop ([i 0]) @@ -172,6 +174,21 @@ [(char=? (string-ref s i) c) #t] [else (loop (+ i 1))])))) + (def (string-contains-any-char? s chars) + (let ([n (string-length s)]) + (let loop ([i 0]) + (cond + [(= i n) #f] + [(char-in-list? (string-ref s i) chars) #t] + [else (loop (+ i 1))])))) + + (def (char-in-list? c chars) + (let loop ([lst chars]) + (cond + [(null? lst) #f] + [(char=? c (car lst)) #t] + [else (loop (cdr lst))]))) + (def (string-replace-all* s old new) (let ([olen (string-length old)] [slen (string-length s)]) @@ -218,6 +235,33 @@ (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] [else (loop (+ i 1) start acc)])))) + ;; Crypto-secure random hex string for temp file names + (def (random-hex n) + ;; Read n bytes from /dev/urandom and convert to hex + (let ([bytes (read-urandom-bytes n)]) + (bytes->hex bytes))) + + (def (read-urandom-bytes n) + (call-with-port + (open-file-input-port "/dev/urandom") + (lambda (p) + (get-bytevector-n p n)))) + + (def (bytes->hex bv) + (let ([n (bytevector-length bv)]) + (let loop ([i 0] [chars '()]) + (if (= i n) + (list->string (reverse chars)) + (let ([b (bytevector-u8-ref bv i)]) + (loop (+ i 1) + (cons (hex-digit (remainder b 16)) + (cons (hex-digit (quotient b 16)) chars)))))))) + + (def (hex-digit d) + (cond + [(< d 10) (integer->char (+ d 48))] ; '0' = 48 + [else (integer->char (+ d 55))])) ; 'A' = 65, so 10 -> 65 (55 = 65-10) + (def (strip-trailing-newline s) (let ([n (string-length s)]) (if (and (> n 0) (char=? (string-ref s (- n 1)) #\newline)) --- a/lib/std/os/temp-home.ss +++ b/lib/std/os/temp-home.ss @@ -138,19 +138,41 @@ (def c-unlink (foreign-procedure "unlink" (string) int)) (def c-rmdir (foreign-procedure "rmdir" (string) int)) + (def c-lstat (foreign-procedure "lstat" (string void*) int)) (def (rm-rf path) + ;; Security: Check for symlinks before deletion to prevent + ;; directory traversal attacks (cond [(not (file-exists? path)) (void)] + [(symbolic-link? path) + ;; Don't follow symlinks - just remove the symlink itself + (c-unlink path)] [(file-directory? path) (for-each (lambda (entry) - (rm-rf (join path entry))) + (let ([entry-path (join path entry)]) + ;; Check each entry before recursing + (if (symbolic-link? entry-path) + (c-unlink entry-path) + (rm-rf entry-path)))) (try (directory-list path) (catch (e) '()))) (c-rmdir path)] [else (c-unlink path)])) + (def (symbolic-link? path) + ;; Check if path is a symbolic link using lstat + ;; Returns #t if it's a symlink, #f otherwise + (try + (let ([stat-buf (make-bytevector 144)]) ; Size for struct stat + (and (zero? (c-lstat path stat-buf)) + ;; Check S_IFLNK mode (0120000 in octal = 40960 decimal) + ;; The mode is at offset 16 for most platforms + (let ([mode (bytevector-u16-native-ref stat-buf 16)]) + (= (bitwise-and mode #o170000) #o120000)))) + (catch (e) #f))) + ;; ---------- Public API ---------- (def open-temp-home --- a/lib/std/os/temporaries.ss +++ b/lib/std/os/temporaries.ss @@ -21,8 +21,35 @@ (def (make-temporary-file-name . rest) (let ((prefix (if (pair? rest) (car rest) "jerboa")) (dir (or (getenv "TMPDIR") "/tmp"))) - (set! *temp-counter* (+ *temp-counter* 1)) - (format "~a/~a-~a-~a" dir prefix (getpid) *temp-counter*))) + ;; Use crypto-secure random instead of predictable counter+pid + (format "~a/~a-~a" dir prefix (random-hex 16)))) + + ;; Crypto-secure random hex string for temp file names + (def (random-hex n) + ;; Read n bytes from /dev/urandom and convert to hex + (let ([bytes (read-urandom-bytes n)]) + (bytes->hex bytes))) + + (def (read-urandom-bytes n) + (call-with-port + (open-file-input-port "/dev/urandom") + (lambda (p) + (get-bytevector-n p n)))) + + (def (bytes->hex bv) + (let ([n (bytevector-length bv)]) + (let loop ([i 0] [chars '()]) + (if (= i n) + (list->string (reverse chars)) + (let ([b (bytevector-u8-ref bv i)]) + (loop (+ i 1) + (cons (hex-digit (remainder b 16)) + (cons (hex-digit (quotient b 16)) chars)))))))) + + (def (hex-digit d) + (cond + [(< d 10) (integer->char (+ d 48))] ; '0' = 48 + [else (integer->char (+ d 55))])) ; 'A' = 65, so 10 -> 65 (55 = 65-10)) ;; Parameter for temp directory (respects TMPDIR) (def temporary-file-directory --- a/lib/std/security/import-audit.ss +++ b/lib/std/security/import-audit.ss @@ -55,7 +55,7 @@ ;; ========== File Scanning ========== (def (audit-imports-file filepath) - ;; Scan a single .sls file for forbidden imports. + ;; Scan a single .sls or .ss file for forbidden imports. ;; Returns a list of import-violation records. ;; Trusted modules (matching *trusted-modules* prefixes) are exempt. (if (trusted-path? filepath) @@ -85,14 +85,14 @@ (loop (+ line-num 1))))))))) (def (audit-imports-directory dirpath) - ;; Scan all .sls files under a directory for forbidden imports. + ;; Scan all .sls and .ss files under a directory for forbidden imports. ;; Returns a list of import-violation records. (let ([violations '()]) (for-each (lambda (filepath) (let ([file-violations (audit-imports-file filepath)]) (set! violations (append violations file-violations)))) - (find-sls-files dirpath)) + (find-source-files dirpath)) violations)) ;; ========== Helpers ========== @@ -124,8 +124,8 @@ [(char-whitespace? (string-ref s i)) (lp (+ i 1))] [else (substring s i len)])))) - (def (find-sls-files dirpath) - ;; Recursively find all .sls files under dirpath. + (def (find-source-files dirpath) + ;; Recursively find all .sls and .ss files under dirpath. (let ([results '()]) (let scan ([dir dirpath]) (for-each @@ -137,6 +137,11 @@ (string-length entry)) ".sls")) (set! results (cons full results))] + [(and (> (string-length entry) 3) + (string=? (substring entry (- (string-length entry) 3) + (string-length entry)) + ".ss")) + (set! results (cons full results))] [(and (not (string=? entry ".")) (not (string=? entry "..")) (file-directory? full)) --- a/lib/std/text/html-parse.ss +++ b/lib/std/text/html-parse.ss @@ -74,6 +74,12 @@ (when (pstate-prefix? p prefix) (pstate-pos-set! p (+ (pstate-pos p) (string-length prefix))))) + ;; ========== Depth guard ========== + + ;; Maximum nesting depth for recursive parse to prevent stack overflow / DoS. + (def *max-parse-depth* + (make-parameter 64)) + ;; ========== Whitespace and identifier helpers ========== (def (whitespace? c) @@ -264,8 +270,10 @@ ;; Also stops when encountering any close tag (ill-nested), letting parent handle it. ;; `open-stack` is the list of currently-open element names from outer to inner. - (def (parse-children p open-stack) - (let loop ([acc '()]) + (def (parse-children p open-stack (depth 0)) + (when (> depth (*max-parse-depth*)) + (error 'parse-children "max parse depth exceeded" depth)) + (let loop ([acc '()] [depth depth]) (cond [(pstate-eof? p) (reverse acc)] [(eqv? (pstate-peek p) #\<) @@ -273,15 +281,15 @@ [(pstate-prefix? p "<!--") (pstate-pos-set! p (+ (pstate-pos p) 4)) (skip-comment! p) - (loop acc)] + (loop acc depth)] [(pstate-prefix? p "<!") (pstate-pos-set! p (+ (pstate-pos p) 2)) (skip-doctype! p) - (loop acc)] + (loop acc depth)] [(pstate-prefix? p "<?") (pstate-pos-set! p (+ (pstate-pos p) 2)) (skip-until-string! p "?>") - (loop acc)] + (loop acc depth)] [(pstate-prefix? p "</") ;; Close tag — does it match anything in our open stack? (let ([saved (pstate-pos p)]) @@ -292,28 +300,29 @@ (cond [(member name open-stack) ;; Match: rewind and let outer parse_children handle it - ;; ... actually consume since we already did. Return what we have. (pstate-pos-set! p saved) ;; rewind so caller sees the close tag (reverse acc)] [else ;; Unknown close tag — discard and continue - (loop acc)])))] - [else - ;; Open tag - (let ([node (parse-element p open-stack)]) - (cond - [(eq? node 'parent-close) (reverse acc)] ;; signaled by inner - [(not node) (loop acc)] - [else (loop (cons node acc))]))])] + (loop acc depth)])))] + [else + ;; Open tag + (let ([node (parse-element p open-stack depth)]) + (cond + [(eq? node 'parent-close) (reverse acc)] ;; signaled by inner + [(not node) (loop acc depth)] + [else (loop (cons node acc) depth)]))])] [else (let ([txt (read-text-until-tag! p)]) (if txt - (loop (cons txt acc)) - (loop acc)))]))) + (loop (cons txt acc) depth) + (loop acc depth)))]))) ;; Returns a node, or 'parent-close (caller should stop and rewind handled), ;; or #f (couldn't parse). - (def (parse-element p open-stack) + (def (parse-element p open-stack (depth 0)) + (when (> depth (*max-parse-depth*)) + (error 'parse-element "max parse depth exceeded" depth)) ;; Already at < (pstate-advance! p) ;; eat < (let ([name (read-tag-name! p)]) @@ -344,7 +353,7 @@ [else (pstate-advance! p) (loop)])))) (build-node name attrs (if raw (list raw) '())))] [else - (let ([children (parse-children p (cons name open-stack))]) + (let ([children (parse-children p (cons name open-stack) (+ depth 1))]) ;; Consume matching close tag if present (when (pstate-prefix? p (string-append "</" name)) (pstate-pos-set! p (+ (pstate-pos p) (+ 2 (string-length name)))) @@ -382,11 +391,11 @@ (def (parse-html html) (let ([p (make-pstate html 0)]) - (cons '*TOP* (parse-children p '())))) + (cons '*TOP* (parse-children p '() 0)))) (def (parse-html-fragment html) (let ([p (make-pstate html 0)]) - (parse-children p '()))) + (parse-children p '() 0))) ;; ========== SXML accessors ========== --- a/lib/std/text/yaml/reader.ss +++ b/lib/std/text/yaml/reader.ss @@ -15,6 +15,9 @@ ;; --------------------------------------------------------------------------- (defstruct pstate (lines total i anchors)) ;; hashtable: anchor-name(string) -> yaml-node + ;; Maximum nesting depth to prevent stack overflow from malicious YAML + (def *max-parse-depth* (make-parameter 128)) + (def (ps-done? ps) (>= (pstate-i ps) (pstate-total ps))) (def (ps-line ps) @@ -653,7 +656,10 @@ ;; Parse a node at the given minimum indentation. ;; Returns a yaml-node or #f if no content at this indent level. - (def (parse-node ps min-indent) + (def (parse-node ps min-indent (depth 0)) + ;; Security: Check max depth to prevent stack overflow from malicious YAML + (when (> depth (*max-parse-depth*)) + (error 'parse-node "YAML nesting depth exceeds maximum" depth)) (let ((pre (collect-pre-comments ps min-indent))) (cond ((ps-done? ps) @@ -720,7 +726,7 @@ ((string=? rest-trimmed "") ;; anchor/tag on its own line, value on next line (ps-advance! ps) - (let ((val (parse-node ps (+ indent 1)))) + (let ((val (parse-node ps (+ indent 1) (+ depth 1)))) (if val (apply-anchor-tag val anchor tag pre ps) (let ((node (make-yaml-scalar "" 'plain tag anchor pre #f))) @@ -920,7 +926,7 @@ (cond ;; Empty value -- look for block value on next lines ((string=? val-trimmed "") - (let ((block-val (parse-node ps (+ indent 1)))) + (let ((block-val (parse-node ps (+ indent 1) (+ depth 1)))) (values key-node (or block-val (make-yaml-scalar "" 'plain #f #f '() eol)) eol))) @@ -970,7 +976,7 @@ (let ((rest-t (string-trim rest))) (if (string=? rest-t "") ;; Value on next line - (let ((block-val (parse-node ps (+ indent 1)))) + (let ((block-val (parse-node ps (+ indent 1) (+ depth 1)))) (let ((val (or block-val (make-yaml-scalar "" 'plain v-tag v-anchor '() eol)))) (values key-node (apply-anchor-tag val v-anchor v-tag '() ps) @@ -1064,7 +1070,7 @@ ((and (= (+ li 1) (string-length line)) (char=? (string-ref line li) #\-)) (ps-advance! ps) - (let ((item (parse-node ps (+ indent 1)))) + (let ((item (parse-node ps (+ indent 1) (+ depth 1)))) (let ((item-with-pre (if item (apply-pre-comments item entry-pre)