Use fibers for TCP DNS handling
ober
1ce3a17ff057aea5b063b20552d2f76124adc162
--- a/README.md +++ b/README.md @@ -22,6 +22,11 @@ make static-freebsd supplementary groups with `setgroups(0, NULL)`, applies `setgid`/`setuid` when configured, and then applies platform filesystem restrictions. +TCP handling uses Jerboa fibers over nonblocking sockets when the fiber runtime +is available before chroot. Embedded static builds can fall back to bounded +nonblocking OS-thread tasks instead of failing at startup. TCP clients are capped +at 128 concurrent sessions, and idle TCP reads/writes time out after 15 seconds. + Filesystem sandbox setup fails closed by default. For local development only, you can allow a weaker fallback with either: --- a/lib/jerboa-dns/server.sls +++ b/lib/jerboa-dns/server.sls @@ -58,6 +58,7 @@ (define *machine-type-str* (symbol->string (machine-type))) (define *on-freebsd* (string-contains-substr *machine-type-str* "fb")) (define *on-linux* (string-contains-substr *machine-type-str* "le")) + (define *on-macos* (string-contains-substr *machine-type-str* "osx")) ;; ========== Server Configuration ========== @@ -93,6 +94,7 @@ (define c-accept (foreign-procedure __collect_safe "accept" (int void* void*) int)) ; jerboa-security: suppress missing-eintr-retry (define c-recv (foreign-procedure __collect_safe "recv" (int void* size_t int) ssize_t)) ; jerboa-security: suppress missing-eintr-retry (define c-send (foreign-procedure __collect_safe "send" (int void* size_t int) ssize_t)) ; jerboa-security: suppress missing-eintr-retry + (define c-fcntl (foreign-procedure "fcntl" (int int int) int)) (define c-setsockopt (foreign-procedure "setsockopt" (int int int void* int) int)) (define c-htons (foreign-procedure "htons" (unsigned-short) unsigned-short)) (define c-ntohs (foreign-procedure "ntohs" (unsigned-short) unsigned-short)) @@ -132,18 +134,36 @@ (define SOCK_DGRAM 2) (define SOCK_STREAM 1) (define EINTR 4) + (define EAGAIN (if *on-linux* 11 35)) + (define EWOULDBLOCK EAGAIN) (define SIGPIPE 13) + (define F_GETFL 3) + (define F_SETFL 4) + (define O_NONBLOCK (if *on-linux* #x800 #x0004)) ;; SOL_SOCKET: 0xffff on FreeBSD/macOS, 1 on Linux - (define SOL_SOCKET (if *on-freebsd* #xffff 1)) - ;; SO_REUSEADDR: 4 on FreeBSD, 2 on Linux - (define SO_REUSEADDR (if *on-freebsd* 4 2)) + (define SOL_SOCKET (if (or *on-freebsd* *on-macos*) #xffff 1)) + ;; SO_REUSEADDR: 4 on FreeBSD/macOS, 2 on Linux + (define SO_REUSEADDR (if (or *on-freebsd* *on-macos*) 4 2)) (define SOCKADDR_IN_SIZE 16) (define INET_ADDRSTRLEN 16) (define MAX-PACKET 512) ;; DNS UDP limit (define MAX-TCP-PACKET 65535) (define TCP-BACKLOG 128) + (define TCP-FIBER-WORKERS 4) + (define MAX-TCP-CLIENTS 128) + (define TCP-IDLE-TIMEOUT-NS (* 15 1000000000)) + (define TCP-FIBER-POLL-MS 1) + (define TCP-IO-TIMEOUT -2) + + ;; Loaded dynamically so static jdns binaries can still run without + ;; needing external Jerboa library files at startup. + (define *fiber-support-state* 'unknown) + (define *make-fiber-runtime* #f) + (define *fiber-spawn* #f) + (define *fiber-runtime-run!* #f) + (define *fiber-sleep* #f) ;; Capsicum rights constants (raw bits, without CAPRIGHT version marker) ;; pack-cap-rights adds the (1<<57) / (1<<58) index markers. @@ -171,6 +191,81 @@ ((top-level-value 'register-signal-handler) SIGPIPE (lambda (sig) (void))))) + (define (load-fiber-support!) + (case *fiber-support-state* + [(available) #t] + [(unavailable) #f] + [else + (guard (e [#t + (set! *fiber-support-state* 'unavailable) + (log-info 'tcp_fibers_unavailable + 'reason (condition-reason e)) + #f]) + (eval '(import (std fiber)) (interaction-environment)) + (set! *make-fiber-runtime* + (eval 'make-fiber-runtime (interaction-environment))) + (set! *fiber-spawn* + (eval 'fiber-spawn (interaction-environment))) + (set! *fiber-runtime-run!* + (eval 'fiber-runtime-run! (interaction-environment))) + (set! *fiber-sleep* + (eval 'fiber-sleep (interaction-environment))) + (set! *fiber-support-state* 'available) + #t)])) + + (define (sleep-ms ms) + (sleep (make-time 'time-duration (* (mod ms 1000) 1000000) (quotient ms 1000)))) + + (define (tcp-sleep-ms ms) + (if *fiber-sleep* + (*fiber-sleep* ms) + (sleep-ms ms))) + + (define (make-tcp-client-limiter limit) + (vector limit 0 (make-mutex))) + + (define (tcp-limiter-try-acquire! limiter) + (let ([limit (vector-ref limiter 0)] + [mx (vector-ref limiter 2)]) + (mutex-acquire mx) + (let ([count (vector-ref limiter 1)]) + (if (< count limit) + (begin + (vector-set! limiter 1 (+ count 1)) + (mutex-release mx) + #t) + (begin + (mutex-release mx) + #f))))) + + (define (tcp-limiter-release! limiter) + (let ([mx (vector-ref limiter 2)]) + (mutex-acquire mx) + (let ([count (vector-ref limiter 1)]) + (when (> count 0) + (vector-set! limiter 1 (- count 1)))) + (mutex-release mx))) + + (define (socket-would-block? err) + (or (= err EAGAIN) (= err EWOULDBLOCK))) + + (define (set-nonblocking! fd who) + (let ([flags (c-fcntl fd F_GETFL 0)]) + (when (= flags -1) + (error who "cannot get socket flags" fd)) + (when (= (c-fcntl fd F_SETFL (bitwise-ior flags O_NONBLOCK)) -1) + (error who "cannot set nonblocking socket" fd)))) + + (define (tcp-deadline-expired? deadline-ns) + (>= (now-monotonic-ns) deadline-ns)) + + (define (tcp-wait-for-io deadline-ns) + (if (tcp-deadline-expired? deadline-ns) + #f + (begin + (tcp-sleep-ms TCP-FIBER-POLL-MS) + #t))) + (define (make-bound-socket ip port socket-type who) (let ([sock (c-socket AF_INET socket-type 0)]) (when (= sock -1) @@ -402,13 +497,17 @@ (do ([i 0 (+ i 1)]) ((= i 4)) (bytevector-u8-set! client-ip i (foreign-ref 'unsigned-8 (+ client-addr 4) i))) - (let ([cdb (open-sandboxed-cdb data-file)]) - (dynamic-wind - void - (lambda () - (dns-respond rs cdb qname qtype client-ip)) - (lambda () - (sandboxed-cdb-close! cdb))))) + (let ([cdb (open-sandboxed-cdb data-file)] + [closed? #f]) + (define (close-cdb!) + (unless closed? + (set! closed? #t) + (sandboxed-cdb-close! cdb))) + (guard (e [#t + (close-cdb!) + (raise e)]) + (dns-respond rs cdb qname qtype client-ip) + (close-cdb!)))) ;; UDP truncates to the question section at 512 bytes; TCP can ;; carry the full DNS message up to the protocol maximum. @@ -427,7 +526,7 @@ (response-length rs) (quotient (- (now-monotonic-ns) t0) 1000))]))))) - (define (send-all fd foreign-buf len) + (define (send-all fd foreign-buf len deadline-ns) (let loop ([sent 0]) (cond [(= sent len) #t] @@ -435,7 +534,14 @@ (let ([n (c-send fd (+ foreign-buf sent) (- len sent) 0)]) (cond [(> n 0) (loop (+ sent n))] - [(and (= n -1) (= (get-errno) EINTR)) (loop sent)] + [(= n -1) + (let ([err (get-errno)]) + (cond + [(= err EINTR) (loop sent)] + [(socket-would-block? err) + (and (tcp-wait-for-io deadline-ns) + (loop sent))] + [else #f]))] [else #f]))]))) (define (send-udp-response! sock rs client-addr) @@ -452,23 +558,28 @@ (lambda () (foreign-free foreign-buf))))) - (define (send-tcp-response! client-fd rs) + (define (send-tcp-response! client-fd rs deadline-ns) (let* ([len (response-length rs)] [buf (response-buffer rs)] [foreign-buf (foreign-alloc (+ len 2))]) - (dynamic-wind - void - (lambda () + (let ([freed? #f]) + (define (free-buf!) + (unless freed? + (set! freed? #t) + (foreign-free foreign-buf))) + (guard (e [#t + (free-buf!) + (raise e)]) (foreign-set! 'unsigned-8 foreign-buf 0 (bitwise-and (bitwise-arithmetic-shift-right len 8) #xff)) (foreign-set! 'unsigned-8 foreign-buf 1 (bitwise-and len #xff)) (do ([i 0 (+ i 1)]) ((= i len)) (foreign-set! 'unsigned-8 foreign-buf (+ i 2) (bytevector-u8-ref buf i))) - (send-all client-fd foreign-buf (+ len 2))) - (lambda () - (foreign-free foreign-buf))))) + (let ([ok? (send-all client-fd foreign-buf (+ len 2) deadline-ns)]) + (free-buf!) + ok?))))) - (define (recv-all fd foreign-buf len) + (define (recv-all fd foreign-buf len deadline-ns) (let loop ([got 0]) (cond [(= got len) got] @@ -477,7 +588,15 @@ (cond [(> n 0) (loop (+ got n))] [(= n 0) got] - [(and (= n -1) (= (get-errno) EINTR)) (loop got)] + [(= n -1) + (let ([err (get-errno)]) + (cond + [(= err EINTR) (loop got)] + [(socket-would-block? err) + (if (tcp-wait-for-io deadline-ns) + (loop got) + TCP-IO-TIMEOUT)] + [else -1]))] [else -1]))]))) (define (tcp-query-length len-buf) @@ -486,38 +605,72 @@ (define (handle-tcp-client! client-fd client-addr data-file) (let ([len-buf (foreign-alloc 2)]) - (dynamic-wind - void - (lambda () + (let ([cleaned? #f]) + (define (cleanup!) + (unless cleaned? + (set! cleaned? #t) + (foreign-free len-buf) + (c-close client-fd))) + (guard (e [#t + (cleanup!) + (raise e)]) (let loop () - (let ([n (recv-all client-fd len-buf 2)]) + (let* ([deadline (+ (now-monotonic-ns) TCP-IDLE-TIMEOUT-NS)] + [n (recv-all client-fd len-buf 2 deadline)]) (when (= n 2) (let ([pkt-len (tcp-query-length len-buf)]) (cond [(or (< pkt-len 12) (> pkt-len MAX-TCP-PACKET)) (log-malformed (client-src-str client-addr) pkt-len "-" "bad_tcp_length")] [else - (let ([pkt-buf (foreign-alloc pkt-len)]) - (dynamic-wind - void - (lambda () - (let ([r (recv-all client-fd pkt-buf pkt-len)]) - (when (= r pkt-len) + (let ([pkt-buf (foreign-alloc pkt-len)] + [keep-going? #f] + [freed? #f]) + (define (free-pkt!) + (unless freed? + (set! freed? #t) + (foreign-free pkt-buf))) + (guard (e [#t + (free-pkt!) + (raise e)]) + (let ([r (recv-all client-fd pkt-buf pkt-len + (+ (now-monotonic-ns) TCP-IDLE-TIMEOUT-NS))]) + (when (= r pkt-len) + (let ([send-ok? #t]) (guard (e [#t (log-error 'tcp_client_error 'src (client-src-str client-addr) 'reason (condition-reason e))]) (process-query! (new-response-state) pkt-buf pkt-len client-addr data-file - (lambda (rs) (send-tcp-response! client-fd rs)) - MAX-TCP-PACKET))))) - (lambda () (foreign-free pkt-buf)))) - (loop)])))))) - (lambda () - (foreign-free len-buf) - (c-close client-fd))))) - - (define (accept-tcp-loop! tcp-sock data-file) + (lambda (rs) + (set! send-ok? + (send-tcp-response! client-fd rs + (+ (now-monotonic-ns) TCP-IDLE-TIMEOUT-NS))) + (unless send-ok? + (error 'send-tcp-response! "send failed"))) + MAX-TCP-PACKET)) + (set! keep-going? send-ok?)))) + (free-pkt!)) + (when keep-going? (loop)))]))))) + (cleanup!))))) + + (define (run-tcp-client-task! client-fd client-addr data-file tcp-limiter) + (let ([cleaned? #f]) + (define (cleanup!) + (unless cleaned? + (set! cleaned? #t) + (foreign-free client-addr) + (tcp-limiter-release! tcp-limiter))) + (guard (e [#t + (log-error 'tcp_client_task_error + 'src (client-src-str client-addr) + 'reason (condition-reason e)) + (cleanup!)]) + (handle-tcp-client! client-fd client-addr data-file) + (cleanup!)))) + + (define (accept-tcp-loop! tcp-sock data-file tcp-limiter spawn-client!) (let loop () (let ([client-addr (foreign-alloc SOCKADDR_IN_SIZE)] [addrlen-buf (foreign-alloc 4)]) @@ -525,17 +678,28 @@ (let ([client-fd (c-accept tcp-sock client-addr addrlen-buf)]) (cond [(>= client-fd 0) - (let ([addr-copy (foreign-alloc SOCKADDR_IN_SIZE)]) - (do ([i 0 (+ i 1)]) ((= i SOCKADDR_IN_SIZE)) - (foreign-set! 'unsigned-8 addr-copy i - (foreign-ref 'unsigned-8 client-addr i))) - (fork-thread - (lambda () - (dynamic-wind - void - (lambda () (handle-tcp-client! client-fd addr-copy data-file)) - (lambda () (foreign-free addr-copy))))))] + (guard (e [#t + (c-close client-fd) + (log-error 'tcp_accept_error + 'reason (condition-reason e))]) + (set-nonblocking! client-fd 'accept-tcp-loop!) + (if (tcp-limiter-try-acquire! tcp-limiter) + (let ([addr-copy (foreign-alloc SOCKADDR_IN_SIZE)]) + (guard (e [#t + (foreign-free addr-copy) + (tcp-limiter-release! tcp-limiter) + (raise e)]) + (do ([i 0 (+ i 1)]) ((= i SOCKADDR_IN_SIZE)) + (foreign-set! 'unsigned-8 addr-copy i + (foreign-ref 'unsigned-8 client-addr i))) + (spawn-client! + (lambda () + (run-tcp-client-task! client-fd addr-copy data-file tcp-limiter)) + "tcp-client"))) + (c-close client-fd)))] [(= (get-errno) EINTR) (void)] + [(socket-would-block? (get-errno)) + (tcp-sleep-ms TCP-FIBER-POLL-MS)] [else (log-error 'tcp_accept_error 'reason (get-errno))]) (foreign-free client-addr) @@ -557,6 +721,8 @@ ;; 1. Create and bind UDP + TCP sockets before chroot/privdrop. (let* ([udp-sock (make-bound-socket ip port SOCK_DGRAM 'run-server!)] [tcp-sock (make-bound-socket ip port SOCK_STREAM 'run-server!)]) + (let ([tcp-fibers? (load-fiber-support!)]) + (set-nonblocking! tcp-sock 'run-server!) (when (= (c-listen tcp-sock TCP-BACKLOG) -1) (c-close udp-sock) (c-close tcp-sock) @@ -618,10 +784,25 @@ "sandboxed" "in-process")) (sandboxed-cdb-close! startup-cdb) - ;; 8. TCP accept loop runs in a Scheme thread; UDP receive - ;; remains the main loop below. - (fork-thread (lambda () (accept-tcp-loop! tcp-sock data-file))) - (log-info 'tcp_listening 'ip ip 'port port) + ;; 8. TCP uses Jerboa fibers when available; embedded static + ;; builds can fall back to bounded nonblocking OS-thread tasks. + (let ([tcp-limiter (make-tcp-client-limiter MAX-TCP-CLIENTS)]) + (if tcp-fibers? + (let ([tcp-rt (*make-fiber-runtime* TCP-FIBER-WORKERS)]) + (*fiber-spawn* tcp-rt + (lambda () + (accept-tcp-loop! tcp-sock data-file tcp-limiter + (lambda (thunk name) + (*fiber-spawn* tcp-rt thunk name)))) + "tcp-accept") + (fork-thread (lambda () (*fiber-runtime-run!* tcp-rt))) + (log-info 'tcp_listening 'ip ip 'port port 'mode "fibers")) + (begin + (fork-thread + (lambda () + (accept-tcp-loop! tcp-sock data-file tcp-limiter + (lambda (thunk name) (fork-thread thunk))))) + (log-info 'tcp_listening 'ip ip 'port port 'mode "threads")))) ;; 9. Main UDP loop (let ([recv-buf (foreign-alloc MAX-PACKET)] @@ -646,6 +827,7 @@ MAX-PACKET)))) (loop))))))) + ) ;; ========== Landlock Sandbox (Linux) ========== --- a/static/build-common.ss +++ b/static/build-common.ss @@ -49,7 +49,8 @@ ;; POSIX symbols jdns calls via foreign-procedure. Resolved by the libc ;; statically/dynamically linked into the final binary. (define jdns-posix-symbols - '("socket" "bind" "close" "recvfrom" "sendto" "setsockopt" + '("socket" "bind" "listen" "accept" "close" + "recvfrom" "sendto" "recv" "send" "setsockopt" "fcntl" "htons" "ntohs" "inet_pton" "inet_ntop" "setuid" "setgid" "setgroups" "chdir" "chroot")) --- a/vs-djbdns.md +++ b/vs-djbdns.md @@ -53,7 +53,7 @@ djbdns's TCB is ~2,000 lines of C with zero library dependencies. jerboa-dns's T - **Manual struct packing.** `make-sockaddr-in` does manual struct packing with hardcoded offsets. One wrong offset is the same bug class as C struct misalignment. - **Foreign memory reads.** `inet_ntop` output is now read with an explicit maximum length, but the correctness still depends on the FFI declaration and pointer arithmetic. -- **Manual foreign memory lifecycle.** Response buffers are freed through `dynamic-wind`, but the code is still responsible for matching every foreign allocation with a free. +- **Manual foreign memory lifecycle.** UDP response buffers use scoped cleanup, and TCP/fiber paths use explicit guarded cleanup to avoid fiber preemption hazards, but the code is still responsible for matching every foreign allocation with a free. - **Blocking FFI calls.** Socket `recvfrom`/`sendto` use `__collect_safe`, but they still cross into C and inherit C ABI risks. ### 3. GC pauses make latency non-deterministic @@ -72,6 +72,10 @@ jerboa-dns now fails closed for chroot and Landlock unless `JDNS_ALLOW_SANDBOX_F The recv buffer is now capped at `MAX-PACKET`, but jerboa-dns still carries the Chez runtime, FFI bridge, allocator, and optional WASM layer. djbdns remains much easier to audit as a whole program. +### 7. TCP introduces a resource-exhaustion surface + +jerboa-dns handles TCP with Jerboa fibers on nonblocking sockets when the fiber runtime is available, and embedded static builds can fall back to bounded nonblocking OS-thread tasks. In both modes it caps concurrent TCP clients at 128 with 15-second idle I/O timeouts. That is materially better than unbounded thread-per-connection handling, but djbdns-style UDP-only deployments still expose less TCP state to attackers. + --- ## Specific Issues Addressed from Review