security: fetch SSRF blocklist + scheme allowlist + CRLF/body caps (P0)
ober
562eb9c91efa44748e3d0396fc417868c15f9a5b
--- a/src/jcode/tool/web.ss +++ b/src/jcode/tool/web.ss @@ -1,9 +1,15 @@ ;;; jcode web tool — HTTP/HTTPS fetch + isolated metasearch (jerbsearch) -(export init-web-tools) +(export init-web-tools + fetch-url + validate-fetch-url! + blocked-host? + ipv4-blocked? + header-value-safe?) (import :std/net/request :std/net/uri + :std/net/address :std/text/json :std/misc/string :jerbsearch/search @@ -71,23 +77,124 @@ (catch (e) (format "Error: ~a" (err->string e)))))) +;; ---- SSRF + header-injection guards ---- +;; fetch takes an LLM-supplied URL, so the numeric destination is validated +;; against a private/loopback/link-local/cloud-metadata blocklist before any +;; connection, the scheme is allowlisted to http/https, header values are +;; rejected on CR/LF/NUL, and the response body is capped. The underlying +;; request library does not follow redirects, so a 3xx is returned to the +;; caller rather than re-fetched (no redirect-based bypass). + +(def *fetch-max-body-bytes* (* 5 1024 1024)) + +(def (ipv4-octets ip) + (let ((parts (string-split ip #\.))) + (and (= (length parts) 4) + (let loop ((ps parts) (acc '())) + (cond + ((null? ps) (reverse acc)) + (else + (let ((n (string->number (car ps)))) + (and (integer? n) (<= 0 n 255) + (loop (cdr ps) (cons n acc)))))))))) + +(def (ipv4-blocked? ip) + (let ((o (ipv4-octets ip))) + (and o + (let ((a (car o)) (b (cadr o))) + (or (= a 0) ;; 0.0.0.0/8 + (= a 10) ;; 10.0.0.0/8 + (= a 127) ;; 127.0.0.0/8 loopback + (and (= a 169) (= b 254)) ;; 169.254.0.0/16 link-local + metadata + (and (= a 172) (>= b 16) (<= b 31)) ;; 172.16.0.0/12 + (and (= a 192) (= b 168)) ;; 192.168.0.0/16 + (and (= a 100) (>= b 64) (<= b 127)) ;; 100.64.0.0/10 CGNAT + (>= a 224)))))) ;; multicast / reserved + +(def (ipv6-blocked? ip) + (let ((low (string-downcase (string-trim ip)))) + (cond + ((or (string=? low "::1") (string=? low "::")) #t) + ((string-prefix? "fe80:" low) #t) ;; link-local + ((or (string-prefix? "fc" low) + (string-prefix? "fd" low)) #t) ;; ULA fc00::/7 + ((string-prefix? "::ffff:" low) ;; IPv4-mapped + (ipv4-blocked? (substring low 7 (string-length low)))) + (else #f)))) + +(def (blocked-host? host) + "True when HOST resolves to a private/loopback/link-local/metadata address. + Hostnames are resolved and the destination checked; resolution failures + fail closed (blocked)." + (cond + ((or (not (string? host)) (string=? host "")) #t) + ((or (string=? host "localhost") + (string-suffix? ".localhost" host)) #t) + ((ipv4-octets host) (ipv4-blocked? host)) + ((string-contains host ":") (ipv6-blocked? host)) + (else + (guard (e [else #t]) + (let ((resolved (resolve-hostname host))) + (or (not resolved) (blocked-host? resolved))))))) + +(def (validate-fetch-url! url) + (unless (and (string? url) + (let ((low (string-downcase url))) + (or (string-prefix? "http://" low) + (string-prefix? "https://" low)))) + (error 'fetch "URL scheme not allowed (http/https only)" url)) + (let ((parts (guard (e [else (error 'fetch "invalid URL" url)]) + (parse-url url)))) + (let ((host (url-parts-host parts))) + (when (or (not host) (string=? host "")) + (error 'fetch "URL has no host" url)) + (when (blocked-host? host) + (error 'fetch + "URL destination is a private/loopback/link-local/metadata address" + url))))) + +(def (header-value-safe? v) + (and (string? v) + (not (string-contains v "\r")) + (not (string-contains v "\n")) + (not (string-contains v "\x0;")))) + +(def (validate-headers! headers) + (for-each + (lambda (kv) + (unless (and (header-value-safe? (car kv)) + (header-value-safe? (cdr kv))) + (error 'fetch "header name or value contains CR/LF/NUL" (car kv)))) + headers)) + +(def (truncate-body text) + (let ((n (string-length text))) + (if (> n *fetch-max-body-bytes*) + (string-append (substring text 0 *fetch-max-body-bytes*) + "\n... [body truncated]") + text))) + (def (fetch-url url method body headers-json) + (validate-fetch-url! url) (let* ((extra-headers (if headers-json (let ((ht (string->json-object headers-json))) (map (lambda (k) (cons k (hash-ref ht k ""))) (hash-keys ht))) '())) - (resp - (if (equal? method "POST") - (http-post url extra-headers (or body "")) - (http-get url extra-headers #f)))) + (resp + (begin + (validate-headers! extra-headers) + (parameterize ((*http-max-body-size* *fetch-max-body-bytes*)) + (if (equal? method "POST") + (http-post url extra-headers (or body "")) + (http-get url extra-headers #f)))))) (dynamic-wind (lambda () (void)) (lambda () (let ((status (request-status resp)) (text (request-text resp))) - (format "Status: ~a\n~a" status text))) + (format "Status: ~a\n~a" status (truncate-body text)))) (lambda () (request-close resp))))) ;; ---- web_search (fresh-process jerbsearch) ---- --- a/test/security-regression.ss +++ b/test/security-regression.ss @@ -10,6 +10,7 @@ (jcode proxy server) (jcode core secrets) (jcode core secrets-import) + (jcode tool web) (std misc ports) (std misc string) (std net tcp)) @@ -285,6 +286,25 @@ (string=? "child-should-not-see" (getenv "JCODE_TEST_SECRET_VAR"))) (scrub-secret-env!) +;; ── (e) fetch SSRF + header injection ───────────────────────────────── +(check "fetch blocks loopback 127.0.0.1" + (refused? (lambda () (fetch-url "http://127.0.0.1/" "GET" #f #f)))) +(check "fetch blocks cloud metadata 169.254.169.254" + (refused? (lambda () (fetch-url "http://169.254.169.254/latest/meta-data" "GET" #f #f)))) +(check "fetch blocks RFC1918 10.0.0.1" + (refused? (lambda () (fetch-url "http://10.0.0.1/" "GET" #f #f)))) +(check "fetch blocks non-http(s) scheme" + (refused? (lambda () (fetch-url "file:///etc/passwd" "GET" #f #f)))) +(check "fetch rejects CRLF in header value" + (refused? (lambda () + (fetch-url "http://8.8.8.8/" "GET" #f + "{\"X-Evil\":\"a\\r\\nInjected: yes\"}")))) +(check "ipv4-blocked? flags loopback" (ipv4-blocked? "127.0.0.1")) +(check "ipv4-blocked? flags metadata" (ipv4-blocked? "169.254.169.254")) +(check "ipv4-blocked? allows public address" (not (ipv4-blocked? "8.8.8.8"))) +(check "header-value-safe? rejects CRLF" (not (header-value-safe? "a\r\nb"))) +(check "header-value-safe? accepts plain value" (header-value-safe? "application/json")) + (when (> failures 0) (error 'security-regression (format "~a security regression test(s) failed" failures))) (printf "Security regressions passed~n")