Harden DNS server and zone compiler
ober
4eb77753047ba1011252d9f2348461d3dda1f89d
--- a/README.md +++ b/README.md @@ -1 +1,44 @@ # jerboa-dns + +Authoritative-only UDP DNS server and zone compiler in Jerboa/Chez Scheme. + +## Build and Test + +```sh +make build +make test +``` + +Static release targets live behind the `static-*` Make targets, for example: + +```sh +make static-freebsd +``` + +## Runtime Security Defaults + +`jdns` binds the UDP socket first, then chroots to `ROOT` (default `.`), drops +supplementary groups with `setgroups(0, NULL)`, applies `setgid`/`setuid` when +configured, and then applies platform filesystem restrictions. + +Filesystem sandbox setup fails closed by default. For local development only, +you can allow a weaker fallback with either: + +```sh +JDNS_ALLOW_SANDBOX_FALLBACK=1 jdns ... +jdns --allow-sandbox-fallback ... +``` + +The WASM DNS parser and WASM CDB reader are used when available. To require +them and fail instead of falling back to in-process parsing, set: + +```sh +JDNS_REQUIRE_WASM_PARSER=1 +JDNS_REQUIRE_WASM_CDB=1 +``` + +## Zone Updates + +`jdns-data` writes a temporary CDB and atomically renames it into place. The +server validates the CDB at startup, then reopens it per query so an atomic +`data.cdb` replacement is visible without restarting the server. --- a/bin/jdns-convert.ss +++ b/bin/jdns-convert.ss @@ -8,7 +8,7 @@ ;;; If output is omitted, writes to stdout. ;;; If input is omitted, reads from stdin. -(import (chezscheme)) +(import (chezscheme)) ; jerboa-security: suppress direct-chezscheme-import-user-code ;; ========== String Utilities ========== @@ -297,16 +297,13 @@ ;; ========== Comment extraction ========== -(define (parse-tinydns-file input-path) - (let ([port (if input-path - (open-input-file input-path) - (current-input-port))]) - (let loop ([entries '()] [current-comment #f]) - (let ([line (get-line port)]) - (cond - [(eof-object? line) - (when input-path (close-port port)) - (reverse entries)] + (define (parse-tinydns-file input-path) + (define (parse-port port) + (let loop ([entries '()] [current-comment #f]) + (let ([line (get-line port)]) + (cond + [(eof-object? line) + (reverse entries)] ;; Blank line [(= (string-length (string-trim line)) 0) (loop entries current-comment)] @@ -331,12 +328,15 @@ (loop entries comment-text)))] ;; Data line [else - (let ([rec (parse-tinydns-line (string-trim line))]) - (if rec - (loop (cons (cons current-comment rec) - entries) - #f) - (loop entries current-comment)))]))))) + (let ([rec (parse-tinydns-line (string-trim line))]) + (if rec + (loop (cons (cons current-comment rec) + entries) + #f) + (loop entries current-comment)))])))) + (if input-path + (call-with-input-file input-path parse-port) + (parse-port (current-input-port)))) ;; ========== Group records by domain ========== @@ -466,7 +466,7 @@ (let* ([entries (parse-tinydns-file input-path)] [groups (group-by-domain entries)]) (if output-path - (call-with-output-file output-path + (call-with-output-file output-path ; jerboa-security: suppress call-with-output-file-overwrite-fail (lambda (port) (emit-zone port groups)) 'replace) (emit-zone (current-output-port) groups)))) --- a/bin/jdns-data.ss +++ b/bin/jdns-data.ss @@ -1,3 +1,3 @@ #!chezscheme -(import (chezscheme) (jerboa-dns main)) +(import (chezscheme) (jerboa-dns main)) ; jerboa-security: suppress direct-chezscheme-import-user-code (run-jdns-data! (cdr (command-line))) --- a/bin/jdns.ss +++ b/bin/jdns.ss @@ -1,3 +1,3 @@ #!chezscheme -(import (chezscheme) (jerboa-dns main)) +(import (chezscheme) (jerboa-dns main)) ; jerboa-security: suppress direct-chezscheme-import-user-code (run-jdns! (cdr (command-line))) --- a/build.ss +++ b/build.ss @@ -1,4 +1,4 @@ -(import (chezscheme)) +(import (chezscheme)) ; jerboa-security: suppress direct-chezscheme-import-user-code (compile-imported-libraries #t) (generate-wpo-files #t) (import --- a/lib/jerboa-dns/lookup.sls +++ b/lib/jerboa-dns/lookup.sls @@ -96,12 +96,21 @@ (response-rfinish! rs RESPONSE-ADDITIONAL)))) records))) - ;; ========== Record Response Building ========== + ;; ========== Record Response Building ========== + (define MAX-CNAME-DEPTH 8) - (define (add-answer-records! rs cdb-reader qname qtype) - ;; Look up records matching qname and qtype. - ;; Returns #t if any records were added, #f otherwise. - (let* ([key (dns-domain-copy qname 0)] + (define (add-answer-records! rs cdb-reader qname qtype) + (add-answer-records/depth! rs cdb-reader qname qtype 0 '())) + + (define (domain-in-list? name names) + (exists (lambda (candidate) + (dns-domain-equal? name 0 candidate 0)) + names)) + + (define (add-answer-records/depth! rs cdb-reader qname qtype depth seen) + ;; Look up records matching qname and qtype. + ;; Returns #t if any records were added, #f otherwise. + (let* ([key (dns-domain-copy qname 0)] [records (cdb-find-all cdb-reader key 0 (bytevector-length key))] [added? #f]) @@ -118,9 +127,14 @@ (response-addname! rs rdata 0) (response-rfinish! rs RESPONSE-ANSWER) (set! added? #t) - ;; Follow CNAME (one level only, to prevent loops) - (add-answer-records! rs cdb-reader rdata qtype) - ))) + ;; Follow CNAMEs with an explicit depth/visited guard so + ;; malicious or mistaken zones cannot recurse forever. + (unless (or (>= depth MAX-CNAME-DEPTH) + (domain-in-list? rdata seen)) + (add-answer-records/depth! rs cdb-reader rdata qtype + (+ depth 1) + (cons key seen))) + ))) ;; Add matching records (for-each --- a/lib/jerboa-dns/main.sls +++ b/lib/jerboa-dns/main.sls @@ -55,15 +55,18 @@ uid (string->number (cadr rest)) data-file)] [(string=? (car rest) "--data") (process-args (cddr rest) ip port root-dir uid gid (cadr rest))] - [(string=? (car rest) "--log-queries") - (set-log-queries! #t) - (process-args (cdr rest) ip port root-dir uid gid data-file)] - [else - (display (format "jdns: unknown option ~a\n" (car rest)) - (current-error-port)) - (display "Usage: jdns [--ip IP] [--port PORT] [--root DIR] [--uid UID] [--gid GID] [--data FILE] [--log-queries]\n" - (current-error-port)) - (exit 1)])))) + [(string=? (car rest) "--log-queries") + (set-log-queries! #t) + (process-args (cdr rest) ip port root-dir uid gid data-file)] + [(string=? (car rest) "--allow-sandbox-fallback") + (putenv "JDNS_ALLOW_SANDBOX_FALLBACK" "1") + (process-args (cdr rest) ip port root-dir uid gid data-file)] + [else + (display (format "jdns: unknown option ~a\n" (car rest)) + (current-error-port)) + (display "Usage: jdns [--ip IP] [--port PORT] [--root DIR] [--uid UID] [--gid GID] [--data FILE] [--log-queries] [--allow-sandbox-fallback]\n" + (current-error-port)) + (exit 1)])))) ;; ========== Zone Compiler Entry Point ========== --- a/lib/jerboa-dns/protocol.sls +++ b/lib/jerboa-dns/protocol.sls @@ -100,13 +100,15 @@ (substring str 0 (- (string-length str) 1)) str)] [labels (string-split s #\.)]) - ;; Calculate total length - (let ([total (fold-left (lambda (acc lab) - (+ acc 1 (string-length lab))) - 1 ;; for final 0 - labels)]) - (let ([bv (make-bytevector total 0)]) - (let loop ([pos 0] [labs labels]) + ;; Calculate total length + (let ([total (fold-left (lambda (acc lab) + (+ acc 1 (string-length lab))) + 1 ;; for final 0 + labels)]) + (when (> total 255) + (error 'dns-domain-from-dot "domain name too long" str)) + (let ([bv (make-bytevector total 0)]) + (let loop ([pos 0] [labs labels]) (if (null? labs) (begin (bytevector-u8-set! bv pos 0) @@ -214,62 +216,73 @@ ;; DNS wire packets use name compression: pointer bytes have top 2 bits set. ;; Pointer: 11xxxxxx xxxxxxxx → offset into packet - (define (dns-packet-getname buf len pos) - ;; Extract a domain name from a DNS packet at position pos. - ;; Handles compression pointers. Returns (values domain-bv new-pos) or #f. - ;; new-pos is the position after the name in the packet (not following pointers). - (let ([result (make-bytevector 256 0)] - [first-jump #f]) - (let loop ([p pos] [rpos 0] [jumps 0]) + (define (dns-packet-getname buf len pos) + ;; Extract a domain name from a DNS packet at position pos. + ;; Handles compression pointers. Returns (values domain-bv new-pos), + ;; or (values #f #f) for malformed input. + (let ((result (make-bytevector 256 0)) + (first-jump #f)) + (let loop ((p pos) (rpos 0) (jumps 0)) + (cond + ((> jumps 100) (values #f #f)) ;; infinite loop protection + ((>= p len) (values #f #f)) + (else + (let ((b (bytevector-u8-ref buf p))) + (cond + ;; End of name + ((= b 0) + (bytevector-u8-set! result rpos 0) + (let ((out (make-bytevector (+ rpos 1)))) + (bytevector-copy! result 0 out 0 (+ rpos 1)) + ;; Return position after name in packet: + ;; If we followed a pointer, first-jump+1 is past the pointer bytes. + ;; If no pointer, p+1 is past the terminating zero. + (values out (if first-jump (+ first-jump 1) (+ p 1))))) + ;; Compression pointer + ((= (bitwise-and b #xc0) #xc0) + (if (>= (+ p 1) len) + (values #f #f) + (let ((target (bitwise-ior + (bitwise-arithmetic-shift-left (bitwise-and b #x3f) 8) + (bytevector-u8-ref buf (+ p 1))))) + (unless first-jump + (set! first-jump (+ p 1))) + (loop target rpos (+ jumps 1))))) + ;; Reserved label types + ((not (= (bitwise-and b #xc0) 0)) + (values #f #f)) + ;; Label + (else + (cond + ((or (> b 63) + (> (+ rpos 1 b) 255) + (> (+ p 1 b) len)) + (values #f #f)) + (else + (bytevector-u8-set! result rpos b) + (let copy ((i 0)) + (if (= i b) + (loop (+ p 1 b) (+ rpos 1 b) jumps) + (begin + (bytevector-u8-set! result (+ rpos 1 i) + (bytevector-u8-ref buf (+ p 1 i))) + (copy (+ i 1))))))))))))))) + + (define (dns-packet-skipname buf len pos) + ;; Skip over a domain name in a DNS packet, returning the position + ;; after the name. Handles compression pointers. + (let loop ([p pos]) (cond - [(> jumps 100) #f] ;; infinite loop protection [(>= p len) #f] [else (let ([b (bytevector-u8-ref buf p)]) (cond - ;; End of name - [(= b 0) - (bytevector-u8-set! result rpos 0) - (let ([out (make-bytevector (+ rpos 1))]) - (bytevector-copy! result 0 out 0 (+ rpos 1)) - ;; Return position after name in packet: - ;; If we followed a pointer, first-jump+1 is past the pointer bytes. - ;; If no pointer, p+1 is past the terminating zero. - (values out (if first-jump (+ first-jump 1) (+ p 1))))] - ;; Compression pointer + [(= b 0) (+ p 1)] [(= (bitwise-and b #xc0) #xc0) - (when (>= (+ p 1) len) (values #f 0)) - (let ([target (bitwise-ior - (bitwise-arithmetic-shift-left (bitwise-and b #x3f) 8) - (bytevector-u8-ref buf (+ p 1)))]) - (unless first-jump - (set! first-jump (+ p 1))) - (loop target rpos (+ jumps 1)))] - ;; Label - [else - (when (> (+ rpos 1 b) 255) (values #f 0)) - (bytevector-u8-set! result rpos b) - (let copy ([i 0]) - (if (= i b) - (loop (+ p 1 b) (+ rpos 1 b) jumps) - (begin - (when (>= (+ p 1 i) len) (values #f 0)) - (bytevector-u8-set! result (+ rpos 1 i) - (bytevector-u8-ref buf (+ p 1 i))) - (copy (+ i 1)))))]))])))) - - (define (dns-packet-skipname buf len pos) - ;; Skip over a domain name in a DNS packet, returning the position - ;; after the name. Handles compression pointers. - (let loop ([p pos]) - (cond - [(>= p len) #f] - [else - (let ([b (bytevector-u8-ref buf p)]) - (cond - [(= b 0) (+ p 1)] - [(= (bitwise-and b #xc0) #xc0) (+ p 2)] - [else (loop (+ p 1 b))]))]))) + (and (< (+ p 1) len) (+ p 2))] + [(not (= (bitwise-and b #xc0) 0)) #f] + [(or (> b 63) (> (+ p 1 b) len)) #f] + [else (loop (+ p 1 b))]))]))) (define (parse-query pkt len) ;; Parse a DNS query packet. Returns (values id qname qtype qclass) or #f. @@ -307,34 +320,82 @@ '(0 1 2 3)) ".")) - (define (ip6-from-string str) - ;; Parse hex string (32 hex chars, no colons) → #vu8(16 bytes) - ;; Also handles :: notation - (guard (e [#t #f]) - (cond - ;; 32-char hex string (DJB format in zone files) - [(= (string-length str) 32) - (let ([bv (make-bytevector 16 0)]) - (do ([i 0 (+ i 2)]) - ((= i 32) bv) - (bytevector-u8-set! bv (/ i 2) - (string->number (substring str i (+ i 2)) 16))))] - ;; Standard colon notation - [else - (let ([bv (make-bytevector 16 0)] - [groups (string-split str #\:)]) - (let fill ([gs groups] [pos 0]) - (cond - [(null? gs) (and (= pos 16) bv)] - [(string=? (car gs) "") - ;; :: expansion - (let ([remaining (- (length gs) 1)] - [zeros-needed (- 8 (- (length groups) 1))]) - (fill (cdr gs) (+ pos (* 2 zeros-needed))))] - [else - (let ([val (string->number (car gs) 16)]) - (uint16-put! bv pos val) - (fill (cdr gs) (+ pos 2)))])))]))) + (define (ip6-from-string str) + ;; Parse a DJB 32-hex IPv6 string or standard colon notation. + ;; IPv4-embedded forms are intentionally not accepted. + (guard (e [#t #f]) + (cond + ;; 32-char hex string (DJB format in zone files) + [(and (= (string-length str) 32) + (not (string-contains-char? str #\:))) + (let ([bv (make-bytevector 16 0)]) + (do ([i 0 (+ i 2)]) + ((= i 32) bv) + (let ([n (string->number (substring str i (+ i 2)) 16)]) + (unless n (error 'ip6-from-string "bad hex byte" str)) + (bytevector-u8-set! bv (/ i 2) n))))] + [else + (let ([groups (parse-ip6-groups str)]) + (and groups + (= (length groups) 8) + (let ([bv (make-bytevector 16 0)]) + (let fill ([gs groups] [pos 0]) + (if (null? gs) + bv + (begin + (uint16-put! bv pos (car gs)) + (fill (cdr gs) (+ pos 2))))))))]))) + + (define (string-contains-char? str ch) + (let loop ([i 0]) + (cond + [(= i (string-length str)) #f] + [(char=? (string-ref str i) ch) #t] + [else (loop (+ i 1))]))) + + (define (find-double-colon str) + (let ([len (string-length str)]) + (let loop ([i 0]) + (cond + [(>= (+ i 1) len) #f] + [(and (char=? (string-ref str i) #\:) + (char=? (string-ref str (+ i 1)) #\:)) + i] + [else (loop (+ i 1))])))) + + (define (parse-ip6-group s) + (and (> (string-length s) 0) + (<= (string-length s) 4) + (let ([n (string->number s 16)]) + (and n (>= n 0) (<= n #xffff) n)))) + + (define (parse-ip6-side s) + (if (string=? s "") + '() + (let ([parts (string-split s #\:)]) + (and (for-all (lambda (p) (> (string-length p) 0)) parts) + (let ([groups (map parse-ip6-group parts)]) + (and (for-all (lambda (g) g) groups) groups)))))) + + (define (make-zero-groups n) + (let loop ([i 0] [acc '()]) + (if (= i n) acc (loop (+ i 1) (cons 0 acc))))) + + (define (parse-ip6-groups str) + (let ([dc (find-double-colon str)]) + (if dc + (let* ([left (substring str 0 dc)] + [right (substring str (+ dc 2) (string-length str))] + [extra (find-double-colon right)] + [lg (parse-ip6-side left)] + [rg (parse-ip6-side right)]) + (and (not extra) + lg rg + (let ([zeros (- 8 (+ (length lg) (length rg)))]) + (and (>= zeros 1) + (append lg (make-zero-groups zeros) rg))))) + (let ([groups (parse-ip6-side str)]) + (and groups (= (length groups) 8) groups))))) (define (ip6-to-string bv offset) ;; 16 bytes at offset → colon-separated hex --- a/lib/jerboa-dns/server.sls +++ b/lib/jerboa-dns/server.sls @@ -4,7 +4,7 @@ ;;; Translates djbdns server.c + tinydns.c startup sequence. ;;; Security layers (applied in order): ;;; 1. Bind socket to port (requires root for port 53) -;;; 2. chroot() to data directory (FreeBSD) or chdir (Linux) +;;; 2. chroot() to data directory ;;; 3. Drop privileges via setgid/setuid ;;; 4. FreeBSD: cap_rights_limit on non-socket fds (restrict operations) ;;; 5. Linux: Landlock filesystem restriction (if available) @@ -79,6 +79,7 @@ (or (guard (e [#t #f]) (load-shared-object "libc.so.7")) (guard (e [#t #f]) (load-shared-object "libc.so.6")) (guard (e [#t #f]) (load-shared-object "libc.so")) + (guard (e [#t #f]) (load-shared-object "libSystem.B.dylib")) (guard (e [#t #f]) (load-shared-object "")))) ;; ========== FFI for socket operations ========== @@ -86,8 +87,8 @@ (define c-socket (foreign-procedure "socket" (int int int) int)) (define c-bind (foreign-procedure "bind" (int void* int) int)) (define c-close (foreign-procedure "close" (int) int)) - (define c-recvfrom (foreign-procedure "recvfrom" (int void* size_t int void* void*) ssize_t)) - (define c-sendto (foreign-procedure "sendto" (int void* size_t int void* int) ssize_t)) + (define c-recvfrom (foreign-procedure __collect_safe "recvfrom" (int void* size_t int void* void*) ssize_t)) + (define c-sendto (foreign-procedure __collect_safe "sendto" (int void* size_t int void* int) ssize_t)) (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)) @@ -95,6 +96,7 @@ (define c-inet-ntop (foreign-procedure "inet_ntop" (int void* void* int) void*)) (define c-setuid (foreign-procedure "setuid" (unsigned) int)) (define c-setgid (foreign-procedure "setgid" (unsigned) int)) + (define c-setgroups (foreign-procedure "setgroups" (int void*) int)) (define c-chdir (foreign-procedure "chdir" (string) int)) ;; ========== FFI for chroot (FreeBSD/Linux) ========== @@ -157,7 +159,7 @@ ;; sin_port = htons(port) at offset 2 (same on both) (foreign-set! 'unsigned-short buf 2 (c-htons port)) ;; sin_addr at offset 4 (same on both) - (when (= (c-inet-pton AF_INET address (+ buf 4)) 0) + (unless (= (c-inet-pton AF_INET address (+ buf 4)) 1) (foreign-free buf) (error 'make-sockaddr-in "invalid address" address)) buf)) @@ -165,22 +167,39 @@ (define (sockaddr-in-port sa) (c-ntohs (foreign-ref 'unsigned-short sa 2))) - (define (sockaddr-in-addr-str sa) - ;; Read the IP address as a dotted-quad string from sockaddr_in. - ;; inet_ntop writes a null-terminated C string to the buffer. - (let ([out (foreign-alloc INET_ADDRSTRLEN)]) - (c-inet-ntop AF_INET (+ sa 4) out INET_ADDRSTRLEN) - (let ([s (foreign-cstring->string out)]) - (foreign-free out) - s))) - - (define (foreign-cstring->string ptr) - ;; Read a null-terminated C string from foreign memory. - (let loop ([i 0] [chars '()]) - (let ([b (foreign-ref 'unsigned-8 ptr i)]) - (if (= b 0) - (list->string (reverse chars)) - (loop (+ i 1) (cons (integer->char b) chars)))))) + (define (sockaddr-in-addr-str sa) + ;; Read the IP address as a dotted-quad string from sockaddr_in. + ;; inet_ntop writes a null-terminated C string to the buffer. + (let ([out (foreign-alloc INET_ADDRSTRLEN)]) + (unless (c-inet-ntop AF_INET (+ sa 4) out INET_ADDRSTRLEN) + (foreign-free out) + (error 'sockaddr-in-addr-str "inet_ntop failed")) + (let ([s (foreign-cstring->string out INET_ADDRSTRLEN)]) + (foreign-free out) + s))) + + (define (foreign-cstring->string ptr max-len) + ;; Read a bounded null-terminated C string from foreign memory. + (let loop ([i 0] [chars '()]) + (cond + [(>= i max-len) (list->string (reverse chars))] + [else + (let ([b (foreign-ref 'unsigned-8 ptr i)]) + (if (= b 0) + (list->string (reverse chars)) + (loop (+ i 1) (cons (integer->char b) chars))))]))) + + (define (truthy-env? name) + (let ([v (getenv name)]) + (and v + (let ([s (string-downcase v)]) + (not (or (string=? s "") + (string=? s "0") + (string=? s "false") + (string=? s "no"))))))) + + (define (allow-sandbox-fallback?) + (truthy-env? "JDNS_ALLOW_SANDBOX_FALLBACK")) ;; ========== Capsicum fd Restriction (FreeBSD) ========== @@ -244,15 +263,15 @@ (define (use-wasm-parser?) *use-wasm-parser*) (define (set-use-wasm-parser! flag) (set! *use-wasm-parser* (and flag #t))) - (define (parse-query-dispatch pkt pkt-len) - ;; Always normalize to four values. Both parse-query and - ;; parse-query-sandboxed either return (values id qname qtype qclass) - ;; or a single #f for "not a query I can answer." - (call-with-values - (lambda () - (if (and *use-wasm-parser* (sandbox-available?)) - (parse-query-sandboxed pkt pkt-len) - (parse-query pkt pkt-len))) + (define (parse-query-dispatch pkt pkt-len) + ;; Always normalize to four values. Both parse-query and + ;; parse-query-sandboxed either return (values id qname qtype qclass) + ;; or a single #f for "not a query I can answer." + (call-with-values + (lambda () + (if *use-wasm-parser* + (parse-query-sandboxed pkt pkt-len) + (parse-query pkt pkt-len))) (case-lambda [() (values #f #f #f #f)] [(_) (values #f #f #f #f)] @@ -276,11 +295,10 @@ [(message-condition? e) (condition-message e)] [else "unknown"])) - (define (process-query! rs sock pkt-buf pkt-len client-addr cdb) - ;; Parse query, look up in CDB, send response. - ;; cdb is the shared reader opened once at startup (see run-server!). - (let ([pkt (make-bytevector pkt-len)] - [t0 (now-monotonic-ns)] + (define (process-query! rs sock pkt-buf pkt-len client-addr data-file) + ;; Parse query, look up in CDB, send response. + (let ([pkt (make-bytevector pkt-len)] + [t0 (now-monotonic-ns)] [src (client-src-str client-addr)]) ;; Copy from foreign memory to bytevector (do ([i 0 (+ i 1)]) ((= i pkt-len)) @@ -331,17 +349,20 @@ (response-query! rs qname qtype qclass) (response-id! rs id) - ;; Look up against the shared CDB reader. The reader is - ;; opened once in run-server! and reused across queries — - ;; the sandbox wrapper resets its bump arena and refills - ;; fuel on every cdb_query so the wasm instance stays - ;; clean between calls. - (let ([client-ip (make-bytevector 4 0)]) - ;; Extract from sockaddr (sin_addr at offset 4) - (do ([i 0 (+ i 1)]) ((= i 4)) - (bytevector-u8-set! client-ip i - (foreign-ref 'unsigned-8 (+ client-addr 4) i))) - (dns-respond rs cdb qname qtype client-ip)) + ;; Open per query so an atomic data.cdb rename is visible + ;; immediately, matching tinydns live-update behavior. + (let ([client-ip (make-bytevector 4 0)]) + ;; Extract from sockaddr (sin_addr at offset 4) + (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))))) ;; Truncate if > 512 bytes (when (> (response-length rs) MAX-PACKET) @@ -359,15 +380,19 @@ (response-length rs) (quotient (- (now-monotonic-ns) t0) 1000))]))))) - (define (send-response! sock rs client-addr) - (let* ([len (response-length rs)] - [buf (response-buffer rs)] - [foreign-buf (foreign-alloc len)]) - ;; Copy bytevector to foreign memory - (do ([i 0 (+ i 1)]) ((= i len)) - (foreign-set! 'unsigned-8 foreign-buf i (bytevector-u8-ref buf i))) - (c-sendto sock foreign-buf len 0 client-addr SOCKADDR_IN_SIZE) - (foreign-free foreign-buf))) + (define (send-response! sock rs client-addr) + (let* ([len (response-length rs)] + [buf (response-buffer rs)] + [foreign-buf (foreign-alloc len)]) + (dynamic-wind + void + (lambda () + ;; Copy bytevector to foreign memory + (do ([i 0 (+ i 1)]) ((= i len)) + (foreign-set! 'unsigned-8 foreign-buf i (bytevector-u8-ref buf i))) + (c-sendto sock foreign-buf len 0 client-addr SOCKADDR_IN_SIZE)) + (lambda () + (foreign-free foreign-buf))))) ;; ========== Main Server Loop ========== @@ -399,26 +424,34 @@ (log-startup 'ip ip 'port port) - ;; 4. chroot + chdir to data directory - ;; chroot restricts filesystem access to this directory tree. - ;; Must be done before dropping privileges (requires root). - (when root-dir - (let ([chroot-ok (= (c-chroot root-dir) 0)]) - (if chroot-ok - (begin - (c-chdir "/") - (log-info 'chroot 'dir root-dir)) - (begin - ;; chroot failed (not root?) — fall back to chdir - (when (= (c-chdir root-dir) -1) - (error 'run-server! "cannot chdir" root-dir)) - (log-info 'chdir 'dir root-dir 'reason "chroot_unavailable"))))) - - ;; 5. Drop privileges (gid before uid, as setuid may remove - ;; the ability to call setgid) - (when gid - (when (= (c-setgid gid) -1) - (error 'run-server! "cannot setgid" gid))) + ;; 4. chroot + chdir to data directory. chroot restricts + ;; filesystem access to this directory tree and must be done + ;; before dropping privileges. Failing open is only allowed + ;; when explicitly requested for development. + (when root-dir + (let ([chroot-ok (= (c-chroot root-dir) 0)]) + (if chroot-ok + (begin + (c-chdir "/") + (log-info 'chroot 'dir root-dir)) + (if (allow-sandbox-fallback?) + (begin + (when (= (c-chdir root-dir) -1) + (error 'run-server! "cannot chdir" root-dir)) + (log-info 'chdir 'dir root-dir 'reason "chroot_unavailable")) + (error 'run-server! + "chroot failed; set JDNS_ALLOW_SANDBOX_FALLBACK=1 to allow chdir fallback" + root-dir))))) + + ;; 5. Drop privileges (clear groups before gid/uid, and gid + ;; before uid as setuid may remove + ;; the ability to call setgid) + (when gid + (when (= (c-setgroups 0 0) -1) + (error 'run-server! "cannot clear supplementary groups"))) + (when gid + (when (= (c-setgid gid) -1) + (error 'run-server! "cannot setgid" gid))) (when uid (when (= (c-setuid uid) -1) (error 'run-server! "cannot setuid" uid))) @@ -436,23 +469,19 @@ ;; Landlock: restrict filesystem access (if available) (enter-landlock-sandbox!)]) - ;; 7. Open the CDB once. The wasm sandbox path is designed to be - ;; reused: cdb_finalize loads the file into the sandbox's static - ;; CDB buffer, and each subsequent cdb_query refills fuel and - ;; resets the per-query bump arena. The previous per-query open - ;; was ~22% of CPU under sandbox load (__bzero on a fresh wasm - ;; linear memory) and ~15% under no-sandbox load (__open syscall - ;; on the CDB file) — see bench/results/summary.md. - (let ([cdb (open-sandboxed-cdb data-file)]) - (log-info 'cdb_opened - 'file data-file - 'parser (if (sandboxed-cdb-reader-using-sandbox? cdb) - "sandboxed" "in-process")) - - ;; 8. Main loop - (let ([recv-buf (foreign-alloc 65536)] - [client-addr (foreign-alloc SOCKADDR_IN_SIZE)] - [addrlen-buf (foreign-alloc 4)] + ;; 7. Validate the CDB at startup, then reopen per query so + ;; atomic data.cdb replacement is observed without restart. + (let ([startup-cdb (open-sandboxed-cdb data-file)]) + (log-info 'cdb_opened + 'file data-file + 'parser (if (sandboxed-cdb-reader-using-sandbox? startup-cdb) + "sandboxed" "in-process")) + (sandboxed-cdb-close! startup-cdb) + + ;; 8. Main loop + (let ([recv-buf (foreign-alloc MAX-PACKET)] + [client-addr (foreign-alloc SOCKADDR_IN_SIZE)] + [addrlen-buf (foreign-alloc 4)] [rs (new-response-state)]) (let loop () @@ -460,13 +489,13 @@ (foreign-set! 'int addrlen-buf 0 SOCKADDR_IN_SIZE) ;; Receive packet - (let ([n (c-recvfrom sock recv-buf 65536 0 client-addr addrlen-buf)]) - (when (> n 0) - ;; Process query - (guard (e [#t - (log-error 'recv_loop_error - 'reason (condition-reason e))]) - (process-query! rs sock recv-buf n client-addr cdb)))) + (let ([n (c-recvfrom sock recv-buf MAX-PACKET 0 client-addr addrlen-buf)]) + (when (> n 0) + ;; Process query + (guard (e [#t + (log-error 'recv_loop_error + 'reason (condition-reason e))]) + (process-query! rs sock recv-buf n client-addr data-file)))) (loop))))))) @@ -475,22 +504,30 @@ (define (enter-landlock-sandbox!) ;; On Linux, restrict filesystem access to current directory only. ;; Uses Landlock ABI if available (Linux 5.13+). - ;; Graceful fallback if not available. - (guard (e [#t - (log-info 'landlock_unavailable 'reason "no_filesystem_sandbox")]) - ;; Try to load the Jerboa Landlock module dynamically - (let ([ll-available? (guard (e [#t #f]) - (eval '(begin - (import (std security landlock)) - (landlock-available?)) - (interaction-environment)))]) - (when ll-available? - (eval '(begin - (import (std security landlock)) - (let ([rs (make-landlock-ruleset)]) - (landlock-add-read-only! rs ".") - (landlock-install! rs))) - (interaction-environment)) - (log-info 'landlock_active))))) + ;; Fails closed unless JDNS_ALLOW_SANDBOX_FALLBACK is set. + (guard (e [#t + (if (allow-sandbox-fallback?) + (log-info 'landlock_unavailable 'reason "no_filesystem_sandbox") + (error 'enter-landlock-sandbox! + "Landlock unavailable; set JDNS_ALLOW_SANDBOX_FALLBACK=1 to run without filesystem sandbox"))]) + ;; Try to load the Jerboa Landlock module dynamically + (let ([ll-available? (guard (e [#t #f]) + (eval '(begin + (import (std security landlock)) + (landlock-available?)) + (interaction-environment)))]) + (if ll-available? + (begin + (eval '(begin + (import (std security landlock)) + (let ([rs (make-landlock-ruleset)]) + (landlock-add-read-only! rs ".") + (landlock-install! rs))) + (interaction-environment)) + (log-info 'landlock_active)) + (if (allow-sandbox-fallback?) + (log-info 'landlock_unavailable 'reason "no_filesystem_sandbox") + (error 'enter-landlock-sandbox! + "Landlock unavailable; set JDNS_ALLOW_SANDBOX_FALLBACK=1 to run without filesystem sandbox")))))) ) ;; end library --- a/lib/jerboa-dns/wasm-dns.sls +++ b/lib/jerboa-dns/wasm-dns.sls @@ -241,12 +241,18 @@ (define (parse-query-sandboxed/wasm pkt-bv pkt-len) (let ([init-ok? (or %instance (wasm-dns-init!))]) (cond - [(not init-ok?) - (let ([reason "wasm-dns-init! failed"]) - (when (require-sandbox?) - (error 'parse-query-sandboxed reason)) - (warn-fallback-once! reason) - (parse-query pkt-bv pkt-len))] + [(not init-ok?) + (let ([reason "wasm-dns-init! failed"]) + (when (require-sandbox?) + (error 'parse-query-sandboxed reason)) + (warn-fallback-once! reason) + (guard (e [#t #f]) + (call-with-values + (lambda () (parse-query pkt-bv pkt-len)) + (case-lambda + [() #f] + [(v) v] + [(id qn t c) (values id qn t c)]))))] [(> pkt-len MAX-INPUT) ;; Mirror the wasm side's input cap; over the cap is "not a query". #f] --- a/lib/jerboa-dns/zone-compiler.sls +++ b/lib/jerboa-dns/zone-compiler.sls @@ -33,10 +33,19 @@ (if (string=? f "") default f)) default)) - (define (field->int fields idx default) - (let ([s (field-ref fields idx "")]) - (if (string=? s "") default - (or (string->number s) default)))) + (define (field->int fields idx default) + (let ([s (field-ref fields idx "")]) + (if (string=? s "") default + (let ([n (string->number s)]) + (if (and n (integer? n) (>= n 0) (<= n #xffffffff)) + n + (error 'field->int "invalid unsigned 32-bit integer" s)))))) + + (define (field->uint16 fields idx default) + (let ([n (field->int fields idx default)]) + (if (<= n #xffff) + n + (error 'field->uint16 "invalid unsigned 16-bit integer" n)))) ;; ========== CDB Key/Value Building ========== ;; CDB key: domain name in wire format (lowercased) @@ -64,13 +73,14 @@ ;; ========== Record Type Handlers ========== - (define (add-a-record! writer fqdn ip-str ttl) - ;; + record: A only - (let ([key (make-cdb-key fqdn)] - [ip (ip4-from-string ip-str)]) - (when ip + (define (add-a-record! writer fqdn ip-str ttl) + ;; + record: A only + (let ([key (make-cdb-key fqdn)] + [ip (ip4-from-string ip-str)]) + (unless ip + (error 'add-a-record! "invalid IPv4 address" fqdn ip-str)) (let ([val (make-cdb-value DNS-T-A CDB-FLAG-NORMAL ttl ip)]) - (cdb-add! writer key (bytevector-length key) val (bytevector-length val)))))) + (cdb-add! writer key (bytevector-length key) val (bytevector-length val))))) (define (add-a-ptr-record! writer fqdn ip-str ttl) ;; = record: A + PTR @@ -169,34 +179,114 @@ (cdb-add! writer key (bytevector-length key) val (bytevector-length val)))) - (define (add-txt-record! writer fqdn text ttl) - ;; ' record: TXT - (let* ([key (make-cdb-key fqdn)] - [text-bytes (string->utf8 text)] - [tlen (bytevector-length text-bytes)] - ;; TXT rdata: length byte(s) + text data - ;; Each chunk is max 255 bytes - [rdata (make-bytevector (+ 1 tlen) 0)]) - (bytevector-u8-set! rdata 0 (min tlen 255)) - (bytevector-copy! text-bytes 0 rdata 1 (min tlen 255)) - (let ([val (make-cdb-value DNS-T-TXT CDB-FLAG-NORMAL ttl rdata)]) - (cdb-add! writer key (bytevector-length key) - val (bytevector-length val))))) - - (define (add-aaaa-record! writer fqdn ip6-str ttl) - ;; 3 record: AAAA only - (let ([key (make-cdb-key fqdn)] - [ip6 (ip6-from-string ip6-str)]) - (when ip6 + (define (add-txt-record! writer fqdn text ttl) + ;; ' record: TXT + (let* ([key (make-cdb-key fqdn)] + [text-bytes (string->utf8 text)] + [tlen (bytevector-length text-bytes)] + [rdata (make-txt-rdata text-bytes)]) + (let ([val (make-cdb-value DNS-T-TXT CDB-FLAG-NORMAL ttl rdata)]) + (cdb-add! writer key (bytevector-length key) + val (bytevector-length val))))) + + (define (txt-chunk-count len) + (if (= len 0) + 1 + (quotient (+ len 254) 255))) + + (define (make-txt-rdata text-bytes) + ;; DNS TXT rdata is one or more length-prefixed strings, each + ;; carrying at most 255 bytes. + (let* ([tlen (bytevector-length text-bytes)] + [chunks (txt-chunk-count tlen)] + [rdata (make-bytevector (+ tlen chunks) 0)]) + (let loop ([src 0] [dst 0] [remaining tlen]) + (cond + [(= remaining 0) + (when (= tlen 0) + (bytevector-u8-set! rdata dst 0)) + rdata] + [else + (let ([chunk (min remaining 255)]) + (bytevector-u8-set! rdata dst chunk) + (bytevector-copy! text-bytes src rdata (+ dst 1) chunk) + (loop (+ src chunk) (+ dst 1 chunk) (- remaining chunk)))])))) + + (define (add-aaaa-record! writer fqdn ip6-str ttl) + ;; 3 record: AAAA only + (let ([key (make-cdb-key fqdn)] + [ip6 (ip6-from-string ip6-str)]) + (unless ip6 + (error 'add-aaaa-record! "invalid IPv6 address" fqdn ip6-str)) (let ([val (make-cdb-value DNS-T-AAAA CDB-FLAG-NORMAL ttl ip6)]) (cdb-add! writer key (bytevector-length key) - val (bytevector-length val)))))) + val (bytevector-length val))))) - (define (add-aaaa-ptr-record! writer fqdn ip6-str ttl) - ;; 6 record: AAAA + PTR - (add-aaaa-record! writer fqdn ip6-str ttl) - ;; TODO: reverse IPv6 PTR record - ) + (define (add-aaaa-ptr-record! writer fqdn ip6-str ttl) + ;; 6 record: AAAA + PTR + (add-aaaa-record! writer fqdn ip6-str ttl) + (let ([ip6 (ip6-from-string ip6-str)]) + (let* ([rev-name (ip6-reverse-name ip6)] + [key (make-cdb-key rev-name)] + [ptr-data (dns-domain-from-dot fqdn)] + [val (make-cdb-value DNS-T-PTR CDB-FLAG-NORMAL ttl ptr-data)]) + (cdb-add! writer key (bytevector-length key) + val (bytevector-length val))))) + + (define (hex-nibble n) + (integer->char + (if (< n 10) + (+ (char->integer #\0) n) + (+ (char->integer #\a) (- n 10))))) + + (define (ip6-reverse-name ip6) + ;; RFC 3596 reverse nibble form under ip6.arpa. + (let loop ([i 15] [parts '()]) + (if (< i 0) + (join-strings (append parts '("ip6" "arpa")) ".") + (let* ([b (bytevector-u8-ref ip6 i)] + [hi (bitwise-and (bitwise-arithmetic-shift-right b 4) #x0f)] + [lo (bitwise-and b #x0f)]) + (loop (- i 1)