security: pin resolved IP in SSRF guard to close DNS-rebinding TOCTOU

ober

e939ed1ce1b620a787f6d881d96ea3a859d196e9

diff --git a/lib/std/net/request.ss b/lib/std/net/request.ss
index 59f3e56..0797c7d 100644
--- a/lib/std/net/request.ss
+++ b/lib/std/net/request.ss
@@ -20,6 +20,8 @@
     *http-max-body-size* *http-max-line-length*
     *http-total-timeout-ms*
     *http-ssrf-guard* ssrf-blocked-host? ssrf-private-ipv4?
+    ssrf-resolve-safe-ip resolve-host-addresses getaddrinfo-addresses
+    *ssrf-resolver*
     http-framing-conflict?)
 
   (import (chezscheme)
@@ -179,17 +181,20 @@
            [scheme  (url-parts-scheme parsed)]
            [host    (url-parts-host   parsed)]
            [port    (url-parts-port   parsed)]
-           [path    (url-parts-path   parsed)])
-       (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))))
+           [path    (url-parts-path   parsed)]
+           ;; SSRF guard (DNS-rebinding safe): resolve the host ONCE, validate the
+           ;; concrete IP(s), and pin the resolution. The connect path uses this IP
+           ;; (not the hostname), so the IP that was validated is exactly the IP
+           ;; connected to. #f when the guard is off — connect by hostname as before.
+           [connect-host (and (*http-ssrf-guard*) (ssrf-resolve-safe-ip host))])
+      (if (string=? scheme "https")
+       (http-request-https method host connect-host port path headers data)
+       (http-request-http  method host connect-host port path headers data))))
 
   ;; ========== HTTP (plain TCP) ==========
 
-  (def (http-request-http method host port path headers data)
-    (let-values ([(in out) (tcp-connect-binary host port)])
+  (def (http-request-http method host connect-host port path headers data)
+    (let-values ([(in out) (tcp-connect-binary (or connect-host host) port)])
       (dynamic-wind
         (lambda () (void))
         (lambda ()
@@ -245,7 +250,7 @@
 
   ;; ========== HTTPS (Rust rustls TLS) ==========
 
-  (def (http-request-https method host port path headers data)
+  (def (http-request-https method host connect-host port path headers data)
     (let* ([handle #f]
            [timeout-ms (*http-total-timeout-ms*)]
            [_ (unless (and (integer? timeout-ms) (> timeout-ms 0))
@@ -255,7 +260,9 @@
       (dynamic-wind
         (lambda () (void))
         (lambda ()
-          (set! handle (rustls-connect host port timeout-ms))
+          (set! handle (if connect-host
+                         (rustls-connect-address host connect-host port timeout-ms)
+                         (rustls-connect host port timeout-ms)))
           (let ([remaining (remaining-request-ms 'http-request deadline)])
             (rustls-set-timeout handle remaining remaining))
           (send-https-request handle method host path headers data)
@@ -663,9 +670,10 @@
   ;; 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.
+  ;; This is a string check on a single address or name. The connect path applies
+  ;; it to the concrete IP(s) returned by ssrf-resolve-safe-ip, which resolves the
+  ;; host once and pins the validated address — closing the DNS-rebinding gap that
+  ;; a name-only check would leave open.
   (def (ssrf-blocked-host? host)
     (let* ([h (string-downcase (string-trim host))]
            [h (strip-ipv6-brackets h)])
@@ -676,6 +684,137 @@
           (let ([mapped (ipv4-mapped-ipv6-tail h)])
             (and mapped (ssrf-private-ipv4? mapped))))))
 
+  ;; ========== SSRF resolve + validate + pin (DNS-rebinding fix) ==========
+  ;;
+  ;; ssrf-blocked-host? above is a string check on the host name; on its own it
+  ;; cannot stop DNS rebinding, where a host resolves public at validation time
+  ;; but loopback at connect time. Close that TOCTOU by resolving the host ONCE
+  ;; to concrete addresses, validating every resolved address against the
+  ;; blocklist, and pinning a validated address for the connection. The connect
+  ;; path uses the pinned IP and never re-resolves the hostname, so the IP that
+  ;; was validated is exactly the IP connected to.
+
+  (def _libc-loaded
+    (let ((v (getenv "JERBOA_STATIC")))
+      (if (and v (not (string=? v "")) (not (string=? v "0")))
+          #f
+          (load-shared-object #f))))
+
+  (def c-getaddrinfo
+    (foreign-procedure "getaddrinfo" (string string void* void*) int))
+  (def c-freeaddrinfo
+    (foreign-procedure "freeaddrinfo" (void*) void))
+  (def c-inet-ntop
+    (foreign-procedure "inet_ntop" (int void* u8* int) void*))
+
+  (def AF_INET 2)
+  (def AF_UNSPEC 0)
+  (def SOCK_STREAM 1)
+  (def INET_ADDRSTRLEN 16)
+  (def INET6_ADDRSTRLEN 46)
+
+  ;; struct addrinfo field offsets. ai_family and ai_next are stable across the
+  ;; supported platforms; only ai_addr moves (BSD/macOS place ai_canonname before
+  ;; ai_addr, glibc after).
+  (def ai-addr-offset
+    (let* ([mt   (symbol->string (machine-type))]
+           [has? (lambda (sub)
+                   (let ([ml (string-length mt)] [sl (string-length sub)])
+                     (let loop ([i 0])
+                       (cond
+                         [(> (+ i sl) ml) #f]
+                         [(string=? sub (substring mt i (+ i sl))) #t]
+                         [else (loop (+ i 1))]))))])
+      (cond
+        [(or (has? "osx") (has? "darwin") (has? "fb") (has? "ob") (has? "nb")) 32]
+        [else 24])))
+  (def ai-family-offset 4)
+  (def ai-next-offset 40)
+
+  ;; Render one sockaddr to a numeric IP string. AF_INET is 2 everywhere; for any
+  ;; other family (AF_INET6, whose value differs by OS) the family is passed
+  ;; straight to inet_ntop so the OS constant is used. in_addr sits at offset 4 of
+  ;; sockaddr_in and in6_addr at offset 8 of sockaddr_in6 on every supported OS.
+  (def (sockaddr->ip-string family addr-ptr)
+    (let-values ([(src len) (if (= family AF_INET)
+                              (values (+ addr-ptr 4) INET_ADDRSTRLEN)
+                              (values (+ addr-ptr 8) INET6_ADDRSTRLEN))])
+      (let ([buf (make-bytevector len 0)])
+        (let ([p (c-inet-ntop family src buf len)])
+          (and (not (= p 0))
+               (let loop ([i 0])
+                 (cond
+                   [(= i len) #f]
+                   [(= (bytevector-u8-ref buf i) 0)
+                    (utf8->string
+                      (let ([b (make-bytevector i)])
+                        (bytevector-copy! buf 0 b 0 i) b))]
+                   [else (loop (+ i 1))])))))))
+
+  ;; Walk the getaddrinfo result list, collecting every numeric address (v4+v6).
+  (def (collect-addresses head)
+    (let loop ([node head] [acc '()])
+      (if (= node 0)
+        (reverse acc)
+        (let* ([family   (foreign-ref 'int node ai-family-offset)]
+               [addr-ptr (foreign-ref 'void* node ai-addr-offset)]
+               [ip       (and (not (= addr-ptr 0))
+                              (sockaddr->ip-string family addr-ptr))]
+               [next     (foreign-ref 'void* node ai-next-offset)])
+          (loop next (if ip (cons ip acc) acc))))))
+
+  ;; Resolve HOSTNAME to all of its concrete IP addresses (IPv4 and IPv6) via a
+  ;; single getaddrinfo(AF_UNSPEC) call.
+  (def (getaddrinfo-addresses hostname)
+    (let ([hints (foreign-alloc 48)])
+      (do ([i 0 (+ i 1)]) ((= i 48)) (foreign-set! 'unsigned-8 hints i 0))
+      (foreign-set! 'int hints 4 AF_UNSPEC)
+      (foreign-set! 'int hints 8 SOCK_STREAM)
+      (let ([result-ptr (foreign-alloc 8)])
+        (foreign-set! 'void* result-ptr 0 0)
+        (let ([rc (c-getaddrinfo hostname #f hints result-ptr)])
+          (foreign-free hints)
+          (cond
+            [(not (= rc 0))
+             (foreign-free result-ptr)
+             (error 'ssrf-resolve-safe-ip "DNS resolution failed" hostname rc)]
+            [else
+              (let* ([result (foreign-ref 'void* result-ptr 0)]
+                     [ips    (collect-addresses result)])
+                (foreign-free result-ptr)
+                (unless (= result 0) (c-freeaddrinfo result))
+                ips)])))))
+
+  ;; Resolve HOST to a list of concrete IP address strings. IP literals (v4 or
+  ;; v6) are returned as-is without a DNS lookup; "localhost" maps to loopback.
+  (def (resolve-host-addresses host)
+    (let ([h (strip-ipv6-brackets (string-trim host))])
+      (cond
+        [(or (string=? h "") (string=? h "localhost")) '("127.0.0.1")]
+        [(parse-ipv4 h)      (list h)]
+        [(string-find h #\:) (list h)]
+        [else                (getaddrinfo-addresses h)])))
+
+  ;; Injectable resolver so the resolve+validate+pin path is testable without
+  ;; live DNS. Defaults to the real getaddrinfo resolver.
+  (def *ssrf-resolver* (make-parameter resolve-host-addresses))
+
+  ;; Resolve HOST once, validate every resolved address against the blocklist,
+  ;; and return a single validated address to connect to (pinning the resolution).
+  ;; Rejects the host if ANY resolved address is non-public — a host that resolves
+  ;; to both a public and a private address is treated as hostile. This is the
+  ;; DNS-rebinding-safe replacement for the string-only ssrf-blocked-host? check.
+  (def (ssrf-resolve-safe-ip host)
+    (let ([ips ((*ssrf-resolver*) host)])
+      (when (null? ips)
+        (error 'ssrf-resolve-safe-ip "host resolved to no addresses" host))
+      (for-each
+        (lambda (ip)
+          (when (ssrf-blocked-host? ip)
+            (error 'ssrf-resolve-safe-ip "refusing non-public host" host ip)))
+        ips)
+      (car ips)))
+
   (def (string-prefix? prefix str)
     (and (>= (string-length str) (string-length prefix))
          (string=? (substring str 0 (string-length prefix)) prefix)))
diff --git a/tests/test-request-url.ss b/tests/test-request-url.ss
index a371235..36bda8b 100644
--- a/tests/test-request-url.ss
+++ b/tests/test-request-url.ss
@@ -92,6 +92,86 @@
 (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"))
 
+;; (e) DNS-rebinding-safe resolve + validate + pin.
+;;
+;; The old guard validated the HOST STRING and re-resolved at connect time, so a
+;; rebinding host (public at validation, loopback at connect) slipped through.
+;; ssrf-resolve-safe-ip resolves ONCE, validates every concrete IP, and pins a
+;; validated IP for the connection — the validated IP is exactly the connected IP.
+
+;; Literal addresses need no DNS: a public IP is returned for connection, a
+;; loopback / metadata / private IP is rejected.
+(test       "pin returns public IPv4"      (ssrf-resolve-safe-ip "8.8.8.8") "8.8.8.8")
+(test       "pin returns public IPv6"      (ssrf-resolve-safe-ip "2606:4700:4700::1111")
+                                            "2606:4700:4700::1111")
+(test-error "pin rejects loopback IPv4"    (ssrf-resolve-safe-ip "127.0.0.1"))
+(test-error "pin rejects metadata IP"      (ssrf-resolve-safe-ip "169.254.169.254"))
+(test-error "pin rejects 10/8"             (ssrf-resolve-safe-ip "10.1.2.3"))
+(test-error "pin rejects loopback IPv6"    (ssrf-resolve-safe-ip "::1"))
+
+;; The RESOLVED IP — not the hostname string — is what gets validated. A benign
+;; name whose resolution is loopback is rejected; a name resolving public returns
+;; that concrete IP for connection.
+(test-error "hostname resolving to loopback rejected"
+  (parameterize ([*ssrf-resolver* (lambda (h) '("127.0.0.1"))])
+    (ssrf-resolve-safe-ip "benign-name.example")))
+(test "hostname resolving to public returns that IP"
+  (parameterize ([*ssrf-resolver* (lambda (h) '("93.184.216.34"))])
+    (ssrf-resolve-safe-ip "benign-name.example"))
+  "93.184.216.34")
+
+;; Multiple addresses: every one is validated; the host is rejected if ANY
+;; resolved address is non-public, otherwise a validated one is pinned.
+(test "multi-addr all-public pins first"
+  (parameterize ([*ssrf-resolver* (lambda (h) '("93.184.216.34" "8.8.8.8"))])
+    (ssrf-resolve-safe-ip "multi.example"))
+  "93.184.216.34")
+(test-error "multi-addr with one loopback rejected"
+  (parameterize ([*ssrf-resolver* (lambda (h) '("93.184.216.34" "127.0.0.1"))])
+    (ssrf-resolve-safe-ip "multi.example")))
+(test-error "multi-addr leading private rejected"
+  (parameterize ([*ssrf-resolver* (lambda (h) '("10.0.0.1" "93.184.216.34"))])
+    (ssrf-resolve-safe-ip "multi.example")))
+
+;; Rebinding host: resolves public on the first lookup, loopback on the second.
+;; The helper resolves ONCE and pins the validated public IP; a re-resolution
+;; (which the old connect path performed) now flips to loopback, but that flip
+;; never reaches the socket because the connection uses the pinned IP.
+(let* ([calls 0]
+       [rebind (lambda (h)
+                 (set! calls (+ calls 1))
+                 (if (= calls 1) '("93.184.216.34") '("127.0.0.1")))]
+       [pinned (parameterize ([*ssrf-resolver* rebind])
+                 (ssrf-resolve-safe-ip "rebind.example"))])
+  (test "rebind: pins the validated public IP" pinned "93.184.216.34")
+  (test "rebind: resolved exactly once (no re-resolve)" calls 1)
+  (test "rebind: a 2nd lookup flips to loopback (bypass attempt)"
+    (car (rebind "rebind.example")) "127.0.0.1"))
+
+;; Real getaddrinfo path: resolves localhost to its concrete loopback address(es),
+;; iterating both IPv4 and IPv6. Every resolved address is a blocked loopback, so
+;; the guard rejects the host no matter which family the platform returns. On
+;; dual-stack hosts the IPv6 sockaddr must parse to exactly "::1".
+(define (has-colon? s)
+  (let loop ([i 0])
+    (cond [(= i (string-length s)) #f]
+          [(char=? (string-ref s i) #\:) #t]
+          [else (loop (+ i 1))])))
+(define (all-blocked? ips)
+  (or (null? ips)
+      (and (ssrf-blocked-host? (car ips)) (all-blocked? (cdr ips)))))
+(define (any-ipv6? ips)
+  (and (pair? ips) (or (has-colon? (car ips)) (any-ipv6? (cdr ips)))))
+
+(let ([ips (getaddrinfo-addresses "localhost")])
+  (test-t "getaddrinfo resolves localhost" (pair? ips))
+  (test-t "getaddrinfo localhost all loopback" (all-blocked? ips))
+  (test-t "getaddrinfo parses IPv6 ::1 when present"
+    (if (any-ipv6? ips) (and (member "::1" ips) #t) #t)))
+(test-error "pin localhost via real getaddrinfo rejected"
+  (parameterize ([*ssrf-resolver* getaddrinfo-addresses])
+    (ssrf-resolve-safe-ip "localhost")))
+
 (newline)
 (printf "Results: ~a passed, ~a failed~%" pass fail)
 (unless (zero? fail) (exit 1))