security: fix five P0 audit findings (ReDoS, path traversal, SSRF, taint, MCP framing)
ober
aa3efee37b5390633a594158ac338bf692015f9e
--- a/lib/std/net/httpd.ss +++ b/lib/std/net/httpd.ss @@ -11,6 +11,7 @@ httpd-listen-address httpd-listen-port httpd-active-connections httpd-config httpd-route httpd-route-prefix httpd-route-static + httpd-resolve-static-path make-router router-add! router-add-prefix! router-lookup http-req-method http-req-path http-req-query http-req-version http-req-headers http-req-header @@ -159,6 +160,82 @@ (def (httpd-route-prefix router prefix handler) (router-add-prefix! router prefix handler)) + ;; ========== Static file serving safety (P0 #2) ========== + ;; + ;; httpd-route-static must never serve a file outside its root directory. + ;; A request suffix is rejected when it (1) contains a ".." path segment, + ;; (2) contains a percent-encoded dot or slash (%2e / %2f, case-insensitive), + ;; a backslash, or a NUL byte, or (3) lexically escapes the serving directory + ;; once "." / ".." segments are resolved. Any rejection yields 403. + + (def (dotdot-segment? s) + (let ([n (string-length s)]) + (let loop ([i 0]) + (and (< i n) + (or (and (char=? (string-ref s i) #\.) + (< (+ i 1) n) + (char=? (string-ref s (+ i 1)) #\.) + (or (= i 0) (char=? (string-ref s (- i 1)) #\/)) + (or (= (+ i 2) n) (char=? (string-ref s (+ i 2)) #\/))) + (loop (+ i 1))))))) + + (def (static-forbidden? s) + (let ([n (string-length s)]) + (let loop ([i 0]) + (and (< i n) + (let ([c (string-ref s i)]) + (or (char=? c #\\) + (char=? c #\nul) + (and (char=? c #\%) + (< (+ i 2) n) + (let ([h (string-ref s (+ i 1))] + [l (string-ref s (+ i 2))]) + (or (and (char-ci=? h #\2) (char-ci=? l #\e)) + (and (char-ci=? h #\2) (char-ci=? l #\f))))) + (loop (+ i 1)))))))) + + ;; Split a path on "/" and lexically resolve "." / ".." segments. + (def (path->segments p) + (let ([n (string-length p)]) + (let loop ([i 0] [start 0] [stack '()]) + (let ([at-end? (= i n)] + [at-slash? (and (< i n) (char=? (string-ref p i) #\/))]) + (cond + [(and (not at-end?) (not at-slash?)) (loop (+ i 1) start stack)] + [else + (let* ([seg (substring p start i)] + [stack (cond + [(or (string=? seg "") (string=? seg ".")) stack] + [(string=? seg "..") + (if (and (pair? stack) + (not (string=? (car stack) ".."))) + (cdr stack) + (cons ".." stack))] + [else (cons seg stack)])]) + (if at-end? (reverse stack) (loop (+ i 1) (+ i 1) stack)))]))))) + + (def (segments-prefix? prefix segs) + (cond + [(null? prefix) #t] + [(null? segs) #f] + [(string=? (car prefix) (car segs)) + (segments-prefix? (cdr prefix) (cdr segs))] + [else #f])) + + (def (static-path-safe? directory suffix) + (and (not (dotdot-segment? suffix)) + (not (static-forbidden? suffix)) + (segments-prefix? (path->segments directory) + (path->segments + (string-append directory "/" suffix))))) + + ;; Resolve a static-serving suffix against DIRECTORY. Returns the joined + ;; path when it stays contained within DIRECTORY, or #f when the suffix + ;; attempts to escape. Exported so the containment guard is testable. + (def (httpd-resolve-static-path directory suffix) + (and (static-path-safe? directory suffix) + (string-append directory "/" suffix))) + (def (httpd-route-static router prefix directory) (router-add-prefix! router prefix (lambda (req) @@ -167,8 +244,10 @@ (string=? prefix (substring path 0 (string-length prefix)))) (substring path (string-length prefix) (string-length path)) "")] - [full-path (string-append directory "/" suffix)]) - (http-respond-file full-path))))) + [full-path (httpd-resolve-static-path directory suffix)]) + (if full-path + (http-respond-file full-path) + (http-respond-error 403 "Forbidden")))))) ;; ========== Request accessors ========== --- a/lib/std/net/request.ss +++ b/lib/std/net/request.ss @@ -18,7 +18,9 @@ alist->headers *http-max-header-size* *http-max-header-count* *http-max-body-size* *http-max-line-length* - *http-total-timeout-ms*) + *http-total-timeout-ms* + *http-ssrf-guard* ssrf-blocked-host? ssrf-private-ipv4? + http-framing-conflict?) (import (chezscheme) (std net tcp) @@ -33,6 +35,13 @@ (def *http-max-line-length* (make-parameter (* 8 1024))) (def *http-total-timeout-ms* (make-parameter 30000)) + ;; SSRF guard (P0 #3). Off by default for backward compatibility. When set + ;; to #t, http-request refuses to connect to loopback, link-local (incl. the + ;; 169.254.169.254 cloud-metadata address), RFC1918 private ranges, or the + ;; "localhost" / "::1" names. Callers that fetch untrusted URLs should + ;; enable it: (parameterize ([*http-ssrf-guard* #t]) ...). + (def *http-ssrf-guard* (make-parameter #f)) + (def (monotonic-ms) (let ([now (current-time 'time-monotonic)]) (+ (* (time-second now) 1000) @@ -48,6 +57,21 @@ (defstruct url-parts (scheme host port path)) + ;; Validate a numeric port string: must be an exact integer in (0, 65536). + (def (parse-port port-str url) + (let ([n (string->number port-str)]) + (unless (and (integer? n) (exact? n) (> n 0) (< n 65536)) + (error 'parse-url "invalid port in URL" url port-str)) + n)) + + ;; Index of the last occurrence of CH in STR, or #f. + (def (string-rfind 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 (parse-url url) (let* ([after-scheme (cond @@ -57,13 +81,20 @@ [scheme (car after-scheme)] [rest (cdr after-scheme)] [slash-pos (string-find rest #\/)] - [host+port (if slash-pos (substring rest 0 slash-pos) rest)] + [authority (if slash-pos (substring rest 0 slash-pos) rest)] [path (if slash-pos (substring rest slash-pos (string-length rest)) "/")] + ;; Strip any userinfo (user / user:pass) — the host is what follows + ;; the last '@'. Without this, http://ok@evil/ parsed host "ok@evil". + [at-pos (string-rfind authority #\@)] + [host+port (if at-pos + (substring authority (+ at-pos 1) (string-length authority)) + authority)] [colon-pos (string-find host+port #\:)] [host (if colon-pos (substring host+port 0 colon-pos) host+port)] [port (if colon-pos - (string->number - (substring host+port (+ colon-pos 1) (string-length host+port))) + (parse-port + (substring host+port (+ colon-pos 1) (string-length host+port)) + url) (if (string=? scheme "https") 443 80))]) (make-url-parts scheme host port path))) @@ -149,7 +180,9 @@ [host (url-parts-host parsed)] [port (url-parts-port parsed)] [path (url-parts-path parsed)]) - (if (string=? scheme "https") + (when (and (*http-ssrf-guard*) (ssrf-blocked-host? host)) + (error 'http-request "SSRF guard: refusing non-public host" host)) + (if (string=? scheme "https") (http-request-https method host port path headers data) (http-request-http method host port path headers data)))) @@ -347,6 +380,9 @@ (loop headers count)))))))) (def (read-body port headers) + (when (http-framing-conflict? headers) + (error 'http-request + "conflicting Content-Length / Transfer-Encoding framing headers")) (let* ([max-body (*http-max-body-size*)] [cl (assoc "content-length" headers)] [chunked? (let ([te (assoc "transfer-encoding" headers)]) @@ -442,6 +478,9 @@ (loop headers count)))))))) (def (read-body/bytes port headers) + (when (http-framing-conflict? headers) + (error 'http-request + "conflicting Content-Length / Transfer-Encoding framing headers")) (let* ([max-body (*http-max-body-size*)] [cl (assoc "content-length" headers)] [chunked? (let ([te (assoc "transfer-encoding" headers)]) @@ -508,6 +547,76 @@ (when (or (string-find s #\return) (string-find s #\newline)) (error who (string-append field " contains CRLF (possible injection)") s))) + ;; ========== Response-framing validation (P0 #3) ========== + ;; + ;; Duplicate Content-Length headers, or a Content-Length alongside a chunked + ;; Transfer-Encoding, let an attacker smuggle a second response past the + ;; parser. Reject any such ambiguity before the body is read. + + (def (count-header name headers) + (let loop ([hs headers] [n 0]) + (cond + [(null? hs) n] + [(string=? (caar hs) name) (loop (cdr hs) (+ n 1))] + [else (loop (cdr hs) n)]))) + + (def (any-chunked-te? headers) + (let loop ([hs headers]) + (cond + [(null? hs) #f] + [(and (string=? (caar hs) "transfer-encoding") + (string-contains (string-downcase (cdar hs)) "chunked")) #t] + [else (loop (cdr hs))]))) + + (def (http-framing-conflict? headers) + (or (> (count-header "content-length" headers) 1) + (and (assoc "content-length" headers) (any-chunked-te? headers)))) + + ;; ========== SSRF guard (P0 #3) ========== + ;; + ;; Predicate support for the opt-in *http-ssrf-guard*. Recognizes loopback, + ;; link-local (incl. the 169.254.169.254 metadata endpoint), RFC1918 private + ;; ranges, the unspecified address, and the localhost / ::1 names. + + (def (parse-ipv4 ip) + ;; Returns a 4-element list of octets, or #f if IP is not a dotted quad. + (let loop ([segs '()] [cur ""] [i 0] [n (string-length ip)]) + (cond + [(and (>= i n) (not (null? segs))) + (let ([segs (reverse (cons cur segs))]) + (and (= (length segs) 4) + (let octets ([ss segs] [out '()]) + (cond + [(null? ss) (reverse out)] + [else + (let ([o (string->number (car ss))]) + (and (integer? o) (exact? o) (>= o 0) (<= o 255) + (octets (cdr ss) (cons o out))))]))))] + [(>= i n) #f] + [(char=? (string-ref ip i) #\.) + (loop (cons cur segs) "" (+ i 1) n)] + [(char-numeric? (string-ref ip i)) + (loop segs (string-append cur (string (string-ref ip i))) (+ i 1) n)] + [else #f]))) + + (def (ssrf-private-ipv4? ip) + (let ([o (parse-ipv4 ip)]) + (and o + (let ([a (car o)] [b (cadr o)]) + (or (= a 127) ;; 127.0.0.0/8 loopback + (= a 10) ;; 10.0.0.0/8 + (and (= a 172) (>= b 16) (<= b 31)) ;; 172.16.0.0/12 + (and (= a 192) (= b 168)) ;; 192.168.0.0/16 + (and (= a 169) (= b 254)) ;; 169.254.0.0/16 link-local + (= a 0)))))) ;; 0.0.0.0/8 + + (def (ssrf-blocked-host? host) + (let ([h (string-downcase (string-trim host))]) + (or (string=? h "localhost") + (string=? h "::1") + (string=? h "[::1]") + (ssrf-private-ipv4? h)))) + (def (string-prefix? prefix str) (and (>= (string-length str) (string-length prefix)) (string=? (substring str 0 (string-length prefix)) prefix))) --- a/lib/std/regex.ss +++ b/lib/std/regex.ss @@ -97,6 +97,21 @@ (foreign-procedure "jerboa_regex_find_at" (unsigned-64 u8* size_t size_t u8* u8*) int) (lambda args (error 'c-native-find-at "native backend not available")))) + (def c-native-group-count + (if native-available? + (foreign-procedure "jerboa_regex_group_count" (unsigned-64) int) + (lambda args (error 'c-native-group-count "native backend not available")))) + (def c-native-captures + (if native-available? + (foreign-procedure "jerboa_regex_captures" + (unsigned-64 u8* size_t size_t u8* size_t) int) + (lambda args (error 'c-native-captures "native backend not available")))) + + ;; Upper bound on capture groups we are willing to materialize from the + ;; native engine in a single match. Mirrors the budget enforced by + ;; (std regex-native) so an untrusted pattern cannot drive an unbounded + ;; Scheme allocation. Patterns exceeding it fall back to pregexp. + (def native-max-groups 1024) ;; ========== Records ========== @@ -203,9 +218,9 @@ full-start full-end))) - ;; Internal search with explicit offset. + ;; Internal search with explicit offset (pregexp backtracking backend). ;; Returns re-match-object or #f. - (def (search-from r str start) + (def (pregexp-search-from r str start) (let* ([pat-str (re-object-pat-string r)] [named (re-object-named-groups r)] [subject (if (= start 0) str (substring str start (string-length str)))] @@ -218,6 +233,127 @@ raw-pos)]) (build-match-object str adj-pos named))))) + ;; ========== Native linear-time (ReDoS-safe) search backend ========== + ;; + ;; The native (Rust regex, Thompson NFA) engine matches in guaranteed + ;; linear time, so it cannot be driven into catastrophic backtracking. + ;; A pattern only has a native handle when the Rust engine accepted it; + ;; patterns that need backtracking-only features (backreferences, + ;; lookaround) fail to compile natively, leave the handle #f, and are + ;; therefore routed to pregexp automatically. The native FFI reports + ;; byte offsets; we only take the fast path for pure-ASCII subjects so + ;; byte offsets equal the character offsets the match-object API exposes + ;; (mirroring re-fold-positions). Non-ASCII subjects keep the pregexp + ;; path, exactly as before. + + ;; True when the native linear engine can serve this re/subject pair. + (def (native-linear-ok? r str) + (and native-available? + (re-object-native-handle r) + (ascii-only-string? str))) + + ;; True when the pattern's capture-group count is within the allocation + ;; budget. Only needed for capture-producing operations; full-match-only + ;; operations (find-all, split) do not require it. + (def (native-capture-ok? r) + (let ([count (c-native-group-count (re-object-native-handle r))]) + (and (>= count 1) (<= count native-max-groups)))) + + ;; Native capture search. Returns a char-based raw-positions list + ;; (list of (start . end) pairs, #f for unmatched optional groups, group 0 + ;; first) or #f when there is no match. Only valid when native-linear-ok? + ;; and native-capture-ok? hold (ASCII subject, byte offsets == char offsets). + (def (native-capture-positions r str start) + (let* ([handle (re-object-native-handle r)] + [bv (string->utf8 str)] + [bl (bytevector-length bv)] + [count (c-native-group-count handle)]) + (and (>= count 1) (<= count native-max-groups) + (let* ([slots (* count 2)] + [ov (make-bytevector (* slots 8))] + [written (c-native-captures handle bv bl start ov slots)]) + (and (> written 0) + (let loop ([i 0] [acc '()]) + (if (>= i written) + (reverse acc) + (let ([ms (bytevector-u64-native-ref ov (* i 16))] + [me (bytevector-u64-native-ref ov (+ (* i 16) 8))]) + (loop (+ i 1) + (cons (if (= ms 18446744073709551615) #f (cons ms me)) + acc)))))))))) + + ;; Native linear-time search returning a re-match-object or #f. + (def (native-search-from r str start) + (let ([raw-pos (native-capture-positions r str start)]) + (and raw-pos + (build-match-object str raw-pos (re-object-named-groups r))))) + + ;; Native full-match search returning a (start . end) char pair or #f. + (def (native-find-from r str start) + (let* ([handle (re-object-native-handle r)] + [bv (string->utf8 str)] + [bl (bytevector-length bv)] + [sbuf (make-bytevector 8)] + [ebuf (make-bytevector 8)]) + (and (<= start bl) + (let ([rc (c-native-find-at handle bv bl start sbuf ebuf)]) + (and (= rc 1) + (cons (bytevector-u64-native-ref sbuf 0) + (bytevector-u64-native-ref ebuf 0))))))) + + ;; Internal search with explicit offset. Routes through the native linear + ;; engine when safe (ReDoS-safe), otherwise the pregexp backtracking engine + ;; (required for backreferences / lookaround / non-ASCII subjects). + (def (search-from r str start) + (if (and (native-linear-ok? r str) (native-capture-ok? r)) + (native-search-from r str start) + (pregexp-search-from r str start))) + + ;; ========== Replacement-string interpretation (pregexp semantics) ========== + ;; + ;; Faithful port of pregexp-replace-aux so the native replace path produces + ;; byte-identical output to pregexp-replace / pregexp-replace*. `backrefs` + ;; is the raw-positions list (group 0 first); group text is taken from str. + + (def (replace-read-escaped-number s i n) + (and (< (+ i 1) n) + (let ([c (string-ref s (+ i 1))]) + (and (char-numeric? c) + (let loop ([i (+ i 2)] [r (list c)]) + (if (>= i n) + (list (string->number (list->string (reverse r))) i) + (let ([c (string-ref s i)]) + (if (char-numeric? c) + (loop (+ i 1) (cons c r)) + (list (string->number (list->string (reverse r))) i))))))))) + + (def (replace-list-ref lst i) + (let loop ([lst lst] [k 0]) + (cond [(null? lst) #f] + [(= k i) (car lst)] + [else (loop (cdr lst) (+ k 1))]))) + + (def (replace-aux str ins n backrefs) + (let loop ([i 0] [r ""]) + (if (>= i n) r + (let ([c (string-ref ins i)]) + (if (char=? c #\\) + (let* ([br-i (replace-read-escaped-number ins i n)] + [br (if br-i (car br-i) + (if (char=? (string-ref ins (+ i 1)) #\&) 0 #f))] + [i (if br-i (cadr br-i) + (if br (+ i 2) (+ i 1)))]) + (if (not br) + (let ([c2 (string-ref ins i)]) + (loop (+ i 1) + (if (char=? c2 #\$) r (string-append r (string c2))))) + (loop i + (let ([backref (replace-list-ref backrefs br)]) + (if backref + (string-append r (substring str (car backref) (cdr backref))) + r))))) + (loop (+ i 1) (string-append r (string c)))))))) + ;; ========== Public API ========== ;; Memoization caches for compiled patterns. Two layers: @@ -306,18 +442,39 @@ (let* ([r (re pat)] [pat-str (re-object-pat-string r)] [len (string-length str)]) - (let loop ([pos 0] [acc '()]) - (if (> pos len) - (reverse acc) - (let ([positions (pregexp-match-positions pat-str - (if (= pos 0) str (substring str pos len)))]) - (if (not positions) + (cond + [(native-linear-ok? r str) + ;; Native linear scan: full-match positions only, no backtracking. + (let* ([handle (re-object-native-handle r)] + [bv (string->utf8 str)] + [bl (bytevector-length bv)] + [sbuf (make-bytevector 8)] + [ebuf (make-bytevector 8)]) + (let loop ([pos 0] [acc '()]) + (cond + [(> pos bl) (reverse acc)] + [else + (let ([rc (c-native-find-at handle bv bl pos sbuf ebuf)]) + (cond + [(= rc 1) + (let* ([ms (bytevector-u64-native-ref sbuf 0)] + [me (bytevector-u64-native-ref ebuf 0)] + [next (if (> me ms) me (+ ms 1))]) + (loop next (cons (substring str ms me) acc)))] + [else (reverse acc)]))])))] + [else + (let loop ([pos 0] [acc '()]) + (if (> pos len) (reverse acc) - (let* ([mstart (+ pos (caar positions))] - [mend (+ pos (cdar positions))] - [matched (substring str mstart mend)] - [next (max (+ mstart 1) mend)]) - (loop next (cons matched acc))))))))) + (let ([positions (pregexp-match-positions pat-str + (if (= pos 0) str (substring str pos len)))]) + (if (not positions) + (reverse acc) + (let* ([mstart (+ pos (caar positions))] + [mend (+ pos (cdar positions))] + [matched (substring str mstart mend)] + [next (max (+ mstart 1) mend)]) + (loop next (cons matched acc)))))))]))) ;; re-groups: capture groups of first match as list, or #f if no match. ;; Does not include the full match (index 0); only capture groups 1..N. @@ -333,15 +490,64 @@ ;; re-replace: replace first match with replacement string. (def (re-replace pat str replacement) - (pregexp-replace (re-object-pat-string (re pat)) str replacement)) + (let* ([r (re pat)] + [n (string-length str)]) + (cond + [(and (native-linear-ok? r str) (native-capture-ok? r)) + (let ([pp (native-capture-positions r str 0)]) + (if (not pp) str + (string-append + (substring str 0 (caar pp)) + (replace-aux str replacement (string-length replacement) pp) + (substring str (cdar pp) n))))] + [else + (pregexp-replace (re-object-pat-string r) str replacement)]))) ;; re-replace-all: replace all non-overlapping matches. (def (re-replace-all pat str replacement) - (pregexp-replace* (re-object-pat-string (re pat)) str replacement)) + (let* ([r (re pat)] + [n (string-length str)] + [ins-len (string-length replacement)]) + (cond + [(and (native-linear-ok? r str) (native-capture-ok? r)) + (let loop ([i 0] [out ""]) + (if (>= i n) out + (let ([pp (native-capture-positions r str i)]) + (if (not pp) + (if (= i 0) str (string-append out (substring str i n))) + (let ([ms (caar pp)] + [me (cdar pp)]) + (loop (if (> me ms) me (+ ms 1)) + (string-append out + (substring str i ms) + (replace-aux str replacement ins-len pp))))))))] + [else + (pregexp-replace* (re-object-pat-string r) str replacement)]))) ;; re-split: split str on each match; returns list of strings. (def (re-split pat str) - (pregexp-split (re-object-pat-string (re pat)) str)) + (let* ([r (re pat)] + [n (string-length str)]) + (cond + [(native-linear-ok? r str) + ;; Replicates pregexp-split's loop, driving it with the native + ;; linear matcher (full-match positions only). + (let loop ([i 0] [acc '()] [picked? #f]) + (cond + [(>= i n) (reverse acc)] + [(native-find-from r str i) + => (lambda (jk) + (let ([j (car jk)] [k (cdr jk)]) + (cond + [(= j k) + (loop (+ k 1) (cons (substring str i (+ j 1)) acc) #t)] + [(and (= j i) picked?) + (loop k acc #f)] + [else + (loop k (cons (substring str i j) acc) #f)])))] + [else (loop n (cons (substring str i n) acc) #f)]))] + [else + (pregexp-split (re-object-pat-string r) str)]))) ;; ASCII-only check: returns #t iff every char in str has code <= 0x7F. ;; Used by re-fold-positions to decide whether the native (Rust regex, @@ -425,17 +631,32 @@ [pat-str (re-object-pat-string r)] [named (re-object-named-groups r)] [len (string-length str)]) - (let loop ([pos 0] [i 0] [acc knil]) - (if (> pos len) - acc - (let ([raw-pos (pregexp-match-positions pat-str str pos len)]) - (if (not raw-pos) + (cond + [(and (native-linear-ok? r str) (native-capture-ok? r)) + ;; Native linear scan with capture groups (ReDoS-safe). + (let loop ([pos 0] [i 0] [acc knil]) + (if (> pos len) + acc + (let ([raw-pos (native-capture-positions r str pos)]) + (if (not raw-pos) + acc + (let* ([m (build-match-object str raw-pos named)] + [mstart (re-match-object-start m)] + [mend (re-match-object-end m)] + [next (max (+ mstart 1) mend)]) + (loop next (+ i 1) (kons i m str acc)))))))] + [else + (let loop ([pos 0] [i 0] [acc knil]) + (if (> pos len) acc - (let* ([m (build-match-object str raw-pos named)] - [mstart (re-match-object-start m)] - [mend (re-match-object-end m)] - [next (max (+ mstart 1) mend)]) - (loop next (+ i 1) (kons i m str acc))))))))) + (let ([raw-pos (pregexp-match-positions pat-str str pos len)]) + (if (not raw-pos) + acc + (let* ([m (build-match-object str raw-pos named)] + [mstart (re-match-object-start m)] + [mend (re-match-object-end m)] + [next (max (+ mstart 1) mend)]) + (loop next (+ i 1) (kons i m str acc)))))))]))) ;; ========== Match object accessors ========== --- a/lib/std/security/taint.ss +++ b/lib/std/security/taint.ss @@ -32,6 +32,10 @@ tainted-string-ref tainted-substring tainted-string-length + tainted-string-upcase + tainted-string-downcase + tainted-string->number + tainted-format ;; Safe wrappers (auto-check taint at dangerous sinks) safe-open-input-file @@ -120,8 +124,10 @@ result))))) (def (tainted-string-ref s i) + ;; A character drawn from a tainted string is itself tainted; returning an + ;; untainted char here silently dropped taint and defeated sink checks. (if (tainted? s) - (string-ref (taint-value s) i) + (taint (taint-class s) (string-ref (taint-value s) i)) (string-ref s i))) (def (tainted-substring s start end) @@ -134,6 +140,38 @@ (string-length (taint-value s)) (string-length s))) + ;; Apply a string->string function F, propagating taint. Used to keep taint + ;; alive across the common case-changing / trimming transforms that would + ;; otherwise silently drop it (and defeat sink checks). + (def (tainted-string-transform f s) + (if (tainted? s) + (taint (taint-class s) (f (taint-value s))) + (f s))) + + (def (tainted-string-upcase s) (tainted-string-transform string-upcase s)) + (def (tainted-string-downcase s) (tainted-string-transform string-downcase s)) + + ;; string->number on a tainted string yields a tainted number (or #f), so a + ;; parsed-but-untrusted value still trips taint-checking sinks. + (def (tainted-string->number s . radix) + (let ([n (if (null? radix) + (string->number (untaint s)) + (string->number (untaint s) (car radix)))]) + (if (and n (tainted? s)) + (taint (taint-class s) n) + n))) + + ;; format propagates taint if any interpolated argument is tainted. + (def (tainted-format fmt . args) + (let ([cls (let loop ([as args]) + (cond + [(null? as) #f] + [(tainted? (car as)) (taint-class (car as))] + [else (loop (cdr as))]))]) + (let* ([vals (map (lambda (a) (if (tainted? a) (taint-value a) a)) args)] + [result (apply format #f fmt vals)]) + (if cls (taint cls result) result)))) + ;; ========== Safe Wrappers (auto-enforce taint at dangerous sinks) ========== ;; ;; These wrappers automatically reject tainted arguments at dangerous --- a/mcp/server.ss +++ b/mcp/server.ss @@ -1142,27 +1142,54 @@ (and (>= (string-length line) (string-length prefix)) (string-ci=? (substring line 0 (string-length prefix)) prefix)))) +(def *mcp-max-frame-size* (* 32 1024 1024)) ;; 32 MB framed-body cap +(def *mcp-max-line-length* (* 1 1024 1024)) ;; 1 MB non-framed line cap + (def (parse-content-length line) (let* ([prefix-len (string-length "Content-Length:")] [raw (substring line prefix-len (string-length line))] [n (string->number (string-trim raw))]) - (if (and (integer? n) (>= n 0)) - n - (error 'mcp-framing "invalid Content-Length" line)))) + (cond + [(not (and (integer? n) (exact? n) (>= n 0))) + (error 'mcp-framing "invalid Content-Length" line)] + ;; Reject oversized frames up front so a hostile Content-Length cannot + ;; drive an unbounded allocation (memory-exhaustion DoS). + [(> n *mcp-max-frame-size*) + (error 'mcp-framing "Content-Length exceeds maximum frame size" + n *mcp-max-frame-size*)] + [else n]))) (def (read-n-chars port n) - (let loop ([i 0] [out '()]) - (cond - [(= i n) (list->string (reverse out))] - [else - (let ([ch (get-char port)]) - (if (eof-object? ch) - (error 'mcp-framing "unexpected EOF while reading framed body") - (loop (+ i 1) (cons ch out))))]))) + ;; Read exactly N characters via get-string-n (a single bounded allocation) + ;; rather than building an N-element cons list char-by-char. + (let ([s (get-string-n port n)]) + (if (and (string? s) (= (string-length s) n)) + s + (error 'mcp-framing "unexpected EOF while reading framed body")))) + +(def (read-capped-line port max) + ;; get-line replacement that bounds the line length, so the non-framed path + ;; cannot be fed an unbounded line. + (let ([out (open-output-string)]) + (let loop ([n 0]) + (cond + [(> n max) (error 'mcp-framing "line exceeds maximum length" max)] + [else + (let ([ch (get-char port)]) + (cond + [(eof-object? ch) + (if (= n 0) ch (get-output-string out))] + [(char=? ch #\newline) + (let* ([s (get-output-string out)] + [len (string-length s)]) + (if (and (> len 0) (char=? (string-ref s (- len 1)) #\return)) + (substring s 0 (- len 1)) + s))] + [else (put-char out ch) (loop (+ n 1))]))])))) (def (consume-frame-headers port) (let loop () - (let ([line (get-line port)]) + (let ([line (read-capped-line port *mcp-max-line-length*)]) (cond [(eof-object? line) (error 'mcp-framing "unexpected EOF while reading framed headers")] @@ -1170,7 +1197,7 @@ [else (loop)])))) (def (read-mcp-message port) - (let ([line (get-line port)]) + (let ([line (read-capped-line port *mcp-max-line-length*)]) (cond [(eof-object? line) #f] [(content-length-header? line) @@ -3167,9 +3194,23 @@ (string-contains file "test-typed"))) (def (project-file-path project file) - (if (or (path-absolute? file) (not project)) - file - (path-join project file))) + (cond + [(path-absolute? file) file] + [(not project) file] + ;; Reject tool-supplied relative paths that try to climb out of the project + ;; root (P0 #5). path-parent-component? catches "../", "/../", "/.." and + ;; bare ".."; the canonicalized prefix check is defense in depth. + [(path-parent-component? file) + (error 'project-file-path "path traversal rejected" file)] + [else + (let* ([root (lexically-clean-path + (path-strip-trailing-directory-separator + (path-normalize project)))] + [full (lexically-clean-path (path-normalize file root))]) + (if (and (not (path-parent-component? full)) + (string-prefix? (string-append root "/") full)) + full + (error 'project-file-path "path escapes project root" file)))])) (def (contains-any? text needles) (any (lambda (needle) (string-contains text needle)) needles)) @@ -9687,4 +9728,7 @@ (when response (send response)))))) (loop)))) -(serve) +;; Setting JERBOA_MCP_NO_SERVE=1 loads all definitions without entering the +;; serve loop (used by the security unit tests to exercise internal helpers). +(unless (getenv "JERBOA_MCP_NO_SERVE") + (serve)) new file mode 100644 --- /dev/null +++ b/mcp/test/security-test.ss @@ -0,0 +1,80 @@ +#!chezscheme +;;; Security unit tests for mcp/server.ss (P0 #5). +;;; +;;; Loads the server with JERBOA_MCP_NO_SERVE=1 (serve loop suppressed) so the +;;; internal framing/path helpers can be exercised directly. +;;; - parse-content-length must cap the frame size (no unbounded alloc). +;;; - project-file-path must reject/contain tool-supplied "../" traversal. + +(import (chezscheme)) + +;; Run with JERBOA_MCP_NO_SERVE=1 so loading server.ss skips the serve loop. +(define repo-root (current-directory)) +(load (string-append repo-root "/mcp/server.ss")) + +(define ienv (interaction-environment)) + +(define pass 0) +(define fail 0) + +(define (check label ok?) + (if ok? + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" label)) + (begin (set! fail (+ fail 1)) (printf "FAIL ~a~%" label)))) + +(define (eval-raises? expr) + (guard (e [#t #t]) + (eval expr ienv) + #f)) + +(define (eval-val expr) + (guard (e [#t #f]) + (eval expr ienv))) + +(define (starts-with? s prefix) + (and (string? s) + (>= (string-length s) (string-length prefix)) + (string=? (substring s 0 (string-length prefix)) prefix))) + +(printf "--- mcp/server.ss security (framing + path containment) ---~%~%") + +;; (a) Content-Length framing cap. +(check "CL within cap accepted (=100)" + (= (eval-val '(parse-content-length "Content-Length: 100")) 100)) +(check "CL at cap accepted" + (= (eval-val `(parse-content-length + ,(string-append "Content-Length: " + (number->string (* 32 1024 1024))))) + (* 32 1024 1024))) +(check "CL above cap rejected (not allocated)" + (eval-raises? '(parse-content-length "Content-Length: 999999999"))) +(check "CL far above cap rejected" + (eval-raises? '(parse-content-length "Content-Length: 99999999999999"))) +(check "CL negative rejected" + (eval-raises? '(parse-content-length "Content-Length: -5"))) +(check "CL non-numeric rejected" + (eval-raises? '(parse-content-length "Content-Length: abc"))) + +;; read-n-chars uses a bounded get-string-n read. +(check "read-n-chars reads exact n" + (string=? (eval-val '(read-n-chars (open-input-string "hello") 5)) "hello")) +(check "read-n-chars short input errors" + (eval-raises? '(read-n-chars (open-input-string "hi") 5))) + +;; (b) project-file-path traversal containment. +(check "normal relative path stays under project" + (starts-with? (eval-val '(project-file-path "/proj" "src/foo.ss")) "/proj/")) +(check "absolute path passthrough" + (string=? (eval-val '(project-file-path "/proj" "/abs/x.ss")) "/abs/x.ss")) +(check "traversal ../ rejected" + (eval-raises? '(project-file-path "/proj" "../etc/passwd"))) +(check "traversal leading ../ rejected" + (eval-raises? '(project-file-path "/proj" "../../etc/passwd"))) +(check "traversal nested ../ rejected" + (eval-raises? '(project-file-path "/proj" "a/../../etc/passwd"))) +(check "traversal bare .. rejected" + (eval-raises? '(project-file-path "/proj" ".."))) + +(newline) +(printf "Results: ~a passed, ~a failed~%" pass fail) +(unless (zero? fail) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-httpd-static.ss @@ -0,0 +1,93 @@ +#!chezscheme +;;; Tests for (std net httpd) static-file path containment (P0 #2). +;;; +;;; httpd-route-static used to build "directory "/" suffix" straight from the +;;; request path with no ".." canonicalization, so GET /static/../../../etc/passwd +;;; could read arbitrary files. httpd-resolve-static-path must reject any suffix +;;; that escapes the serving directory ( ".." segments, percent-encoded %2e/%2f, +;;; backslash, NUL, or any lexical escape) by returning #f. + +(import (chezscheme) + (std net httpd)) + +(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)))))])) + +(define-syntax test-t (syntax-rules () [(_ name expr) (test name (if expr #t #f) #t)])) + +(printf "--- (std net httpd) static path containment ---~%~%") + +;; Build a temp tree: ROOT/public.txt (inside) and SECRET (one level up). +(define base (string-append "/tmp/jerboa-httpd-static-" + (number->string (time-nanosecond (current-time))))) +(define root (string-append base "/www")) +(define secret-path (string-append base "/secret.txt")) + +(mkdir base) +(mkdir root) +(call-with-output-file secret-path + (lambda (p) (display "TOP-SECRET" p))) +(call-with-output-file (string-append root "/public.txt") + (lambda (p) (display "public-content" p))) + +;; Mimic the static handler: serve file contents only when the resolver allows. +(define (serve suffix) + (let ([full (httpd-resolve-static-path root suffix)]) + (cond + [(not full) 'forbidden] + [(file-exists? full) + (call-with-input-file full + (lambda (p) + (let loop ([c (read-char p)] [acc '()]) + (if (eof-object? c) + (list->string (reverse acc)) + (loop (read-char p) (cons c acc))))))] + [else 'not-found]))) + +;; (a) Traversal suffixes must NOT return file contents outside the root. +(test "reject ../ secret" (serve "/../secret.txt") 'forbidden) +(test "reject ../../ etc" (serve "/../../etc/passwd") 'forbidden) +(test "reject bare ../" (serve "../secret.txt") 'forbidden) +(test "reject deep ../" (serve "/../../../etc/passwd") 'forbidden) + +;; Percent-encoded traversal (%2e%2e%2f and case variants) must be rejected. +(test "reject %2e%2e%2f" (serve "/%2e%2e%2fsecret.txt") 'forbidden) +(test "reject %2e%2e/" (serve "/%2e%2e/secret.txt") 'forbidden) +(test "reject uppercase %2E%2E" (serve "/%2E%2E%2Fsecret.txt") 'forbidden) + +;; Backslash / NUL injection rejected. +(test-t "reject backslash" (not (httpd-resolve-static-path root "/..\\secret.txt"))) + +;; Resolver returns #f (not a path) for every escape attempt. +(test "resolver #f on ../" (httpd-resolve-static-path root "/../secret.txt") #f) +(test "resolver #f on encoded" (httpd-resolve-static-path root "/%2e%2e%2fx") #f) + +;; (b) Legitimate paths still resolve and stay contained under the root. +(test "serve public file" (serve "/public.txt") "public-content") +(test-t "resolved stays under root" + (let ([full (httpd-resolve-static-path root "/public.txt")]) + (and full + (>= (string-length full) (string-length root)) + (string=? (substring full 0 (string-length root)) root)))) + +;; Cleanup +(for-each (lambda (f) (guard (e [#t (void)]) (delete-file f))) + (list secret-path (string-append root "/public.txt"))) +(guard (e [#t (void)]) (delete-directory root)) +(guard (e [#t (void)]) (delete-directory base)) + +(newline) +(printf "Results: ~a passed, ~a failed~%" pass fail) +(unless (zero? fail) (exit 1)) --- a/tests/test-regex.ss +++ b/tests/test-regex.ss @@ -171,6 +171,52 @@ (test "char range" (re-match? '(+ (/ #\a #\z)) "hello") #t) (test "nocase" (re-match? '(w/nocase (: alpha (+ alpha))) "HELLO") #t) +;;; ========== ReDoS regression (P0 #1) ========== +;;; +;;; The (std regex) facade must route the search/replace/split/fold API +;;; through the linear native (Rust Thompson-NFA) engine by default so +;;; catastrophic patterns cannot trigger exponential backtracking. Patterns +;;; needing backreferences/lookaround fall back to pregexp and keep working. + +(printf "~% -- ReDoS regression (native linear default) --~%") + +;; #t iff THUNK returns a value equal? to EXPECTED in under 2 seconds without +;; raising. Before the fix the catastrophic patterns below routed through +;; pregexp and raised "backtracking limit exceeded" (a denial of service). +(define (redos-safe? thunk expected) + (guard (exn [#t #f]) + (let* ([t0 (current-time)] + [res (thunk)] + [t1 (current-time)] + [dt (+ (- (time-second t1) (time-second t0)) + (/ (- (time-nanosecond t1) (time-nanosecond t0)) 1e9))]) + (and (equal? res expected) (< dt 2.0))))) + +(define redos-haystack (string-append (make-string 40 #\a) "b")) + +;; (a) Catastrophic patterns complete quickly with a clean result. +(test-t "ReDoS: re-search (a+)+$ -> #f, fast" + (redos-safe? (lambda () (re-search "(a+)+$" redos-haystack)) #f)) +(test-t "ReDoS: re-find-all (a+)+$ -> (), fast" + (redos-safe? (lambda () (re-find-all "(a+)+$" redos-haystack)) '())) +(test-t "ReDoS: re-replace-all (a+)+$ unchanged, fast" + (redos-safe? (lambda () (re-replace-all "(a+)+$" redos-haystack "X")) redos-haystack)) +(test-t "ReDoS: re-split (a+)+$ fast"