security: harden P0 fixes (non-ASCII ReDoS, httpd symlink, SSRF IPv6, taint format)
ober
a3c7fa64d76590016522bbc8c52db081e380daef
--- a/lib/std/net/httpd.ss +++ b/lib/std/net/httpd.ss @@ -229,12 +229,64 @@ (path->segments (string-append directory "/" suffix))))) + ;; Symlink resolution (P0 #2 follow-up). The lexical check above canonicalizes + ;; "." / ".." segments but cannot see through a symbolic link placed inside the + ;; serving directory that points outside it (e.g. www/link -> /etc/passwd). + ;; realpath(3) expands every symlink component, so we resolve both the serving + ;; directory and the joined candidate and require the candidate's real path to + ;; remain under the directory's real path. The original (un-resolved) joined + ;; path is still what gets served, so callers see the path they constructed. + (def c-realpath + (guard (exn [#t #f]) + (foreign-procedure "realpath" (string u8*) void*))) + + (def realpath-buf-size 4096) + + (def (realpath-str path) + (and c-realpath + (guard (exn [#t #f]) + (let ([buf (make-bytevector realpath-buf-size 0)]) + (let ([res (c-realpath path buf)]) + (and (not (= res 0)) + (let loop ([i 0] [chars '()]) + (cond + [(= i realpath-buf-size) #f] + [(= (bytevector-u8-ref buf i) 0) + (list->string (reverse chars))] + [else (loop (+ i 1) + (cons (integer->char (bytevector-u8-ref buf i)) + chars))])))))))) + + (def (string-has-prefix? pre s) + (let ([np (string-length pre)] [ns (string-length s)]) + (and (<= np ns) (string=? pre (substring s 0 np))))) + + ;; #t iff JOINED, after symlink expansion, stays within DIRECTORY. When realpath + ;; is unavailable or a path does not exist yet, falls back to allowing the + ;; (already lexically-validated) path — a missing target simply 404s, and an + ;; escape only matters once the symlink target actually exists. + (def (symlink-contained? directory joined) + (if (not c-realpath) + #t + (let ([rdir (realpath-str directory)]) + (if (not rdir) + #t + (let ([rjoined (realpath-str joined)]) + (if (not rjoined) + #t + (or (string=? rjoined rdir) + (string-has-prefix? (string-append rdir "/") rjoined)))))))) + ;; 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. + ;; attempts to escape — lexically ("..", %2e/%2f, backslash, NUL) or via a + ;; symbolic link that resolves outside DIRECTORY. Exported so the guard is + ;; testable. (def (httpd-resolve-static-path directory suffix) (and (static-path-safe? directory suffix) - (string-append directory "/" suffix))) + (let ([joined (string-append directory "/" suffix)]) + (and (symlink-contained? directory joined) + joined)))) (def (httpd-route-static router prefix directory) (router-add-prefix! router prefix --- a/lib/std/net/request.ss +++ b/lib/std/net/request.ss @@ -610,12 +610,71 @@ (and (= a 169) (= b 254)) ;; 169.254.0.0/16 link-local (= a 0)))))) ;; 0.0.0.0/8 + ;; Strip one pair of surrounding brackets from an IPv6 literal: "[::1]" -> "::1". + (def (strip-ipv6-brackets h) + (let ([n (string-length h)]) + (if (and (>= n 2) + (char=? (string-ref h 0) #\[) + (char=? (string-ref h (- n 1)) #\])) + (substring h 1 (- n 1)) + h))) + + (def (split-on-colon s) + (let ([n (string-length s)]) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(>= i n) (reverse (cons (substring s start n) acc))] + [(char=? (string-ref s i) #\:) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else (loop (+ i 1) start acc)])))) + + ;; #t iff H (lowercased, bracket-stripped) is the IPv6 loopback ::1 in any + ;; common spelling: every colon-separated group before the last is "0" or an + ;; empty (:: -compressed) group and the final group is "1". Conservative — it + ;; never matches an address with a non-zero leading group, so public IPv6 + ;; addresses are not blocked. + (def (ipv6-loopback? h) + (and (string-find h #\:) + (let ([groups (split-on-colon h)]) + (and (not (null? groups)) + (let loop ([gs groups]) + (cond + [(null? (cdr gs)) (string=? (car gs) "1")] + [else (and (or (string=? (car gs) "0") (string=? (car gs) "")) + (loop (cdr gs)))])))))) + + ;; #t iff H is an IPv6 link-local (fe80::/10) or unique-local (fc00::/7) + ;; address, by its first-hextet prefix. + (def (ipv6-link-local-or-ula? h) + (and (string-find h #\:) + (or (string-prefix? "fe8" h) (string-prefix? "fe9" h) + (string-prefix? "fea" h) (string-prefix? "feb" h) + (string-prefix? "fc" h) (string-prefix? "fd" h)))) + + ;; For an IPv4-mapped IPv6 address such as "::ffff:127.0.0.1", return the + ;; embedded dotted quad ("127.0.0.1"); otherwise #f. + (def (ipv4-mapped-ipv6-tail h) + (let ([p (string-contains h "::ffff:")]) + (and p + (let ([tail (substring h (+ p 7) (string-length h))]) + (and (parse-ipv4 tail) tail))))) + + ;; Recognizes loopback, link-local (incl. the 169.254.169.254 metadata + ;; endpoint), RFC1918 private ranges, the unspecified address, the + ;; localhost / ::1 names, and the IPv6 spellings that map onto them + ;; (bracketed literals, ::ffff:a.b.c.d IPv4-mapped, fe80::/10, fc00::/7). + ;; NOTE: this is a string-based guard. It cannot catch a public hostname that + ;; DNS-resolves to a private address (DNS rebinding); a fully robust guard + ;; must re-check the resolved IP at connect time. (def (ssrf-blocked-host? host) - (let ([h (string-downcase (string-trim host))]) + (let* ([h (string-downcase (string-trim host))] + [h (strip-ipv6-brackets h)]) (or (string=? h "localhost") - (string=? h "::1") - (string=? h "[::1]") - (ssrf-private-ipv4? h)))) + (ssrf-private-ipv4? h) + (ipv6-loopback? h) + (ipv6-link-local-or-ula? h) + (let ([mapped (ipv4-mapped-ipv6-tail h)]) + (and mapped (ssrf-private-ipv4? mapped)))))) (def (string-prefix? prefix str) (and (>= (string-length str) (string-length prefix)) --- a/lib/std/regex.ss +++ b/lib/std/regex.ss @@ -247,10 +247,55 @@ ;; path, exactly as before. ;; True when the native linear engine can serve this re/subject pair. + ;; The native (Rust Thompson-NFA) engine is ReDoS-safe for ANY subject, + ;; ASCII or not; the only requirement is that the pattern compiled natively + ;; (handle present). Non-ASCII subjects are handled by translating the + ;; engine's UTF-8 byte offsets to/from character offsets via an off-map + ;; (see string->off-map), so the linear engine — not the pregexp backtracking + ;; engine — serves them. This closes the ReDoS bypass where a hostile + ;; non-ASCII subject previously forced the catastrophic pregexp path. (def (native-linear-ok? r str) (and native-available? - (re-object-native-handle r) - (ascii-only-string? str))) + (re-object-native-handle r))) + + ;; Byte<->character offset translation for a subject string. + ;; + ;; The native engine reports match positions as UTF-8 byte offsets, while + ;; the public match-object API (substring, re-match-start/end) works in + ;; character offsets. For pure-ASCII subjects the two coincide, so the + ;; off-map is the identity and allocates nothing (preserving the fast path + ;; exactly). For non-ASCII subjects we build two vectors once per operation: + ;; b2c[byte-i] = char index of the character beginning at byte-i + ;; c2b[char-i] = byte offset where char-i begins (c2b[n] = byte length) + ;; Native offsets always land on character boundaries, so b2c[off] is exact. + (defstruct off-map (b2c c2b ascii?)) + + (def (string->off-map str bv) + (if (ascii-only-string? str) + (make-off-map #f #f #t) + (let* ([bl (bytevector-length bv)] + [n (string-length str)] + [b2c (make-vector (+ bl 1) n)] + [c2b (make-vector (+ n 1) bl)]) + (let loop ([ci 0] [bi 0]) + (if (>= ci n) + (begin (vector-set! b2c bl n) + (vector-set! c2b n bl) + (make-off-map b2c c2b #f)) + (let* ([cp (char->integer (string-ref str ci))] + [len (cond [(fx<= cp #x7f) 1] + [(fx<= cp #x7ff) 2] + [(fx<= cp #xffff) 3] + [else 4])]) + (vector-set! b2c bi ci) + (vector-set! c2b ci bi) + (loop (fx+ ci 1) (fx+ bi len)))))))) + + (def (off-map->char om byte-off) + (if (off-map-ascii? om) byte-off (vector-ref (off-map-b2c om) byte-off))) + + (def (off-map->byte om char-off) + (if (off-map-ascii? om) char-off (vector-ref (off-map-c2b om) char-off))) ;; True when the pattern's capture-group count is within the allocation ;; budget. Only needed for capture-producing operations; full-match-only @@ -262,16 +307,18 @@ ;; 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) + ;; and native-capture-ok? hold. `start` is a CHARACTER offset; the native + ;; engine is driven with the equivalent byte offset (off-map->byte) and its + ;; byte-offset results are translated back to character offsets + ;; (off-map->char), so this is correct for ASCII and non-ASCII alike. + (def (native-capture-positions r str start om bv bl) + (let* ([handle (re-object-native-handle r)] + [start-b (off-map->byte om start)] + [count (c-native-group-count handle)]) + (and (>= count 1) (<= count native-max-groups) (<= start-b bl) (let* ([slots (* count 2)] [ov (make-bytevector (* slots 8))] - [written (c-native-captures handle bv bl start ov slots)]) + [written (c-native-captures handle bv bl start-b ov slots)]) (and (> written 0) (let loop ([i 0] [acc '()]) (if (>= i written) @@ -279,34 +326,40 @@ (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)) + (cons (if (= ms 18446744073709551615) #f + (cons (off-map->char om ms) + (off-map->char om 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)]) + (def (native-search-from r str start om bv bl) + (let ([raw-pos (native-capture-positions r str start om bv bl)]) (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)]) + ;; Native full-match search returning a (start . end) CHARACTER pair or #f. + ;; `start` is a character offset; translated to a byte offset for the engine + ;; and the byte-offset result translated back to character offsets. + (def (native-find-from r str start om bv bl) + (let* ([handle (re-object-native-handle r)] + [start-b (off-map->byte om start)] + [sbuf (make-bytevector 8)] + [ebuf (make-bytevector 8)]) + (and (<= start-b bl) + (let ([rc (c-native-find-at handle bv bl start-b sbuf ebuf)]) (and (= rc 1) - (cons (bytevector-u64-native-ref sbuf 0) - (bytevector-u64-native-ref ebuf 0))))))) + (cons (off-map->char om (bytevector-u64-native-ref sbuf 0)) + (off-map->char om (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). + ;; (required for backreferences / lookaround, which fail native compile). (def (search-from r str start) (if (and (native-linear-ok? r str) (native-capture-ok? r)) - (native-search-from r str start) + (let* ([bv (string->utf8 str)] + [bl (bytevector-length bv)] + [om (string->off-map str bv)]) + (native-search-from r str start om bv bl)) (pregexp-search-from r str start))) ;; ========== Replacement-string interpretation (pregexp semantics) ========== @@ -445,21 +498,31 @@ (cond [(native-linear-ok? r str) ;; Native linear scan: full-match positions only, no backtracking. + ;; The loop cursor is a BYTE offset (what the engine consumes); each + ;; match's byte offsets are translated to character offsets for + ;; substring. Empty matches advance to the next character boundary + ;; (not +1 byte, which could land mid-codepoint in non-ASCII). (let* ([handle (re-object-native-handle r)] [bv (string->utf8 str)] [bl (bytevector-length bv)] + [om (string->off-map str bv)] [sbuf (make-bytevector 8)] [ebuf (make-bytevector 8)]) - (let loop ([pos 0] [acc '()]) + (let loop ([bpos 0] [acc '()]) (cond - [(> pos bl) (reverse acc)] + [(> bpos bl) (reverse acc)] [else - (let ([rc (c-native-find-at handle bv bl pos sbuf ebuf)]) + (let ([rc (c-native-find-at handle bv bl bpos 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))]) + (let* ([ms-b (bytevector-u64-native-ref sbuf 0)] + [me-b (bytevector-u64-native-ref ebuf 0)] + [ms (off-map->char om ms-b)] + [me (off-map->char om me-b)] + [next (if (> me-b ms-b) me-b + (let ([c (off-map->char om ms-b)]) + (if (>= c len) (+ bl 1) + (off-map->byte om (+ c 1)))))]) (loop next (cons (substring str ms me) acc)))] [else (reverse acc)]))])))] [else @@ -494,7 +557,10 @@ [n (string-length str)]) (cond [(and (native-linear-ok? r str) (native-capture-ok? r)) - (let ([pp (native-capture-positions r str 0)]) + (let* ([bv (string->utf8 str)] + [bl (bytevector-length bv)] + [om (string->off-map str bv)] + [pp (native-capture-positions r str 0 om bv bl)]) (if (not pp) str (string-append (substring str 0 (caar pp)) @@ -510,17 +576,20 @@ [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))))))))] + (let* ([bv (string->utf8 str)] + [bl (bytevector-length bv)] + [om (string->off-map str bv)]) + (let loop ([i 0] [out ""]) + (if (>= i n) out + (let ([pp (native-capture-positions r str i om bv bl)]) + (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)]))) @@ -531,21 +600,26 @@ (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)]))] + ;; linear matcher (full-match positions only). All cursors (i, j, k) + ;; are character offsets; native-find-from translates to/from the + ;; engine's byte offsets internally, so this is correct for non-ASCII. + (let* ([bv (string->utf8 str)] + [bl (bytevector-length bv)] + [om (string->off-map str bv)]) + (let loop ([i 0] [acc '()] [picked? #f]) + (cond + [(>= i n) (reverse acc)] + [(native-find-from r str i om bv bl) + => (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)]))) @@ -633,18 +707,23 @@ [len (string-length str)]) (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)))))))] + ;; Native linear scan with capture groups (ReDoS-safe). `pos` is a + ;; character offset; native-capture-positions translates to/from the + ;; engine's byte offsets internally, so this is correct for non-ASCII. + (let* ([bv (string->utf8 str)] + [bl (bytevector-length bv)] + [om (string->off-map str bv)]) + (let loop ([pos 0] [i 0] [acc knil]) + (if (> pos len) + acc + (let ([raw-pos (native-capture-positions r str pos om bv bl)]) + (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) --- a/lib/std/security/taint.ss +++ b/lib/std/security/taint.ss @@ -161,14 +161,17 @@ (taint (taint-class s) n) n))) - ;; format propagates taint if any interpolated argument is tainted. + ;; format propagates taint if the format string or any interpolated argument + ;; is tainted. The format string itself is untainted before being handed to + ;; format (a tainted-value is not a string and would otherwise raise). (def (tainted-format fmt . args) - (let ([cls (let loop ([as args]) + (let ([cls (let loop ([as (cons fmt 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)] + (let* ([fmt (untaint fmt)] + [vals (map (lambda (a) (if (tainted? a) (taint-value a) a)) args)] [result (apply format #f fmt vals)]) (if cls (taint cls result) result)))) --- a/tests/test-httpd-static.ss +++ b/tests/test-httpd-static.ss @@ -82,6 +82,22 @@ (>= (string-length full) (string-length root)) (string=? (substring full 0 (string-length root)) root)))) +;; (c) Symbolic-link escape: a link placed inside the root that points outside +;; must be rejected. The lexical check cannot see through symlinks, so the +;; resolver expands both the root and the candidate with realpath(3) and +;; requires the candidate's real path to stay under the root's real path. +(define link-path (string-append root "/link")) +(guard (exn [#t (printf " (skip symlink test: cannot create link)~%")]) + (system (string-append "ln -s " secret-path " " link-path)) + (test "reject symlink escaping root" (serve "/link") 'forbidden) + (test "resolver #f on symlink escape" (httpd-resolve-static-path root "/link") #f) + ;; An internal symlink (target stays under the root) is still served. + (let ([alias (string-append root "/alias.txt")]) + (system (string-append "ln -s " root "/public.txt " alias)) + (test "serve internal symlink" (serve "/alias.txt") "public-content") + (guard (e [#t (void)]) (delete-file alias))) + (guard (e [#t (void)]) (delete-file link-path))) + ;; Cleanup (for-each (lambda (f) (guard (e [#t (void)]) (delete-file f))) (list secret-path (string-append root "/public.txt"))) --- a/tests/test-regex.ss +++ b/tests/test-regex.ss @@ -217,6 +217,38 @@ (test "normal: re-split" (re-split "[,;]" "a,b;c") '("a" "b" "c")) (test "normal: re-find-all" (re-find-all "\\d+" "a1b22c333") '("1" "22" "333")) +;; (d) Non-ASCII subjects must ALSO route through the linear native engine. +;; Before the offset-translation fix, any non-ASCII subject forced the pregexp +;; fallback, so a hostile subject with a single multibyte char + a catastrophic +;; pattern raised "backtracking limit exceeded" (a ReDoS bypass). The native +;; engine's UTF-8 byte offsets are now translated to/from character offsets. +(define non-ascii-redos (string-append (make-string 40 #\a) (string (integer->char #xe9)))) +(test-t "ReDoS: non-ASCII re-search (a+)+$ -> #f, fast" + (redos-safe? (lambda () (re-search "(a+)+$" non-ascii-redos)) #f)) +(test-t "ReDoS: non-ASCII re-find-all (a+)+$ -> (), fast" + (redos-safe? (lambda () (re-find-all "(a+)+$" non-ascii-redos)) '())) +(test-t "ReDoS: non-ASCII re-replace-all (a+)+$ unchanged, fast" + (redos-safe? (lambda () (re-replace-all "(a+)+$" non-ascii-redos "X")) non-ascii-redos)) + +;; (e) Non-ASCII matching stays correct: char offsets, groups, replace, split. +(define e-acute (string (integer->char #xe9))) ;; 2-byte UTF-8 +(define emoji (string (integer->char #x1F600))) ;; 4-byte UTF-8 +(define cafe (string-append "caf" e-acute)) ;; "café": chars c,a,f,é +(let ([m (re-search e-acute cafe)]) + (test "non-ASCII: search multibyte full" (and m (re-match-full m)) e-acute) + (test "non-ASCII: search multibyte start" (and m (re-match-start m)) 3) + (test "non-ASCII: search multibyte end" (and m (re-match-end m)) 4)) +(test "non-ASCII: find-all multibyte" (re-find-all e-acute (string-append e-acute "x" e-acute)) + (list e-acute e-acute)) +(test "non-ASCII: replace multibyte" (re-replace e-acute cafe "!") "caf!") +(test "non-ASCII: replace-all multibyte" (re-replace-all e-acute (string-append e-acute "x" e-acute) "!") "!x!") +(test "non-ASCII: split on multibyte" (re-split e-acute (string-append "a" e-acute "b" e-acute "c")) '("a" "b" "c")) +(let ([m (re-search emoji (string-append "ab" emoji "cd"))]) + (test "non-ASCII: 4-byte emoji start" (and m (re-match-start m)) 2) + (test "non-ASCII: 4-byte emoji end" (and m (re-match-end m)) 3)) +(test "non-ASCII: search with start offset" + (let ([m (re-search "[0-9]" (string-append "1" e-acute "2") 1)]) (and m (re-match-full m))) "2") + ;;; ========== Summary ========== (newline) (printf "Results: ~a passed, ~a failed~%" pass fail) --- a/tests/test-request-url.ss +++ b/tests/test-request-url.ss @@ -81,6 +81,17 @@ (test-f "ssrf allows public name" (ssrf-blocked-host? "example.com")) (test-f "ssrf 172.32 not private" (ssrf-blocked-host? "172.32.0.1")) +;; IPv6 spellings that map onto private/loopback addresses must also be blocked +;; (otherwise the guard is bypassed with ::ffff:127.0.0.1, [::1], fe80::, etc.). +(test-t "ssrf blocks IPv4-mapped IPv6" (ssrf-blocked-host? "::ffff:127.0.0.1")) +(test-t "ssrf blocks bracketed IPv4-mapped" (ssrf-blocked-host? "[::ffff:169.254.169.254]")) +(test-t "ssrf blocks expanded ::1" (ssrf-blocked-host? "[0:0:0:0:0:0:0:1]")) +(test-t "ssrf blocks bracketed ::1" (ssrf-blocked-host? "[::1]")) +(test-t "ssrf blocks IPv6 link-local" (ssrf-blocked-host? "fe80::1")) +(test-t "ssrf blocks IPv6 ULA" (ssrf-blocked-host? "fd00::1")) +(test-f "ssrf allows public IPv6" (ssrf-blocked-host? "2606:4700:4700::1111")) +(test-f "ssrf allows public IPv6 2001:db8" (ssrf-blocked-host? "2001:db8::1")) + (newline) (printf "Results: ~a passed, ~a failed~%" pass fail) (unless (zero? fail) (exit 1)) --- a/tests/test-security-taint.ss +++ b/tests/test-security-taint.ss @@ -51,6 +51,9 @@ (test "string->number value" (taint-value (tainted-string->number (taint-http "42"))) 42) (test-t "format keeps taint" (tainted? (tainted-format "v=~a" (taint-http "1")))) (test-f "format clean stays clean" (tainted? (tainted-format "v=~a" "1"))) +;; A tainted FORMAT string must not crash tainted-format and must propagate taint. +(test-t "tainted format string keeps taint" (tainted? (tainted-format (taint-http "v=~a") "1"))) +(test "tainted format string value" (taint-value (tainted-format (taint-http "v=~a") "1")) "v=1") (test-f "upcase clean stays clean" (tainted? (tainted-string-upcase "abc"))) ;; (c) THE regression: a tainted string run through string-upcase then passed --- a/vendor/ChezScheme/c/alloc.c +++ b/vendor/ChezScheme/c/alloc.c @@ -207,7 +207,7 @@ ptr S_bytes_finalized() { /* called with alloc mutex */ static void maybe_queue_fire_collector(thread_gc *tgc) { uptr trip = S_G.collect_trip_bytes; -#ifdef PTHREADS +#if defined(PTHREADS) && defined(ENABLE_GC_TELEMETRY) if (S_gc_adaptive_trip_enabled() && S_collect_waiting_threads > 3) { trip = trip / (S_collect_waiting_threads / 3); if (trip < bytes_per_segment * 4) trip = bytes_per_segment * 4; --- a/vendor/ChezScheme/c/externs.h +++ b/vendor/ChezScheme/c/externs.h @@ -385,9 +385,9 @@ extern void S_register_scheme_signal(iptr sig); extern void S_fire_collector(void); extern void S_gc_telemetry_mark_prewrite_slot(ptr loc, ptr new_value); typedef void (*S_gc_mark_bitmap_apply_proc)(void *data, ptr p); -extern IBOOL S_gc_adaptive_trip_enabled(void); #ifdef ENABLE_GC_TELEMETRY extern void S_gc_telemetry_request(void); +extern IBOOL S_gc_adaptive_trip_enabled(void); extern void S_gc_telemetry_begin(const char *path, const char *reason, IGEN max_cg, IGEN min_tg, IGEN max_tg); extern void S_gc_telemetry_phase(const char *phase, uptr us); extern void S_gc_telemetry_subphase(const char *phase, uptr us);