fix: CDB bounds validation, domain-name walking bounds, response overflow check, buffer cleanup, remove eval
ober
bfdbb6a722bd030f383d82d318d9f2ae035c3ca1
--- a/lib/jerboa-dns/cdb.ss +++ b/lib/jerboa-dns/cdb.ss @@ -73,6 +73,69 @@ ;; data: bytevector (entire file contents); closed: mutable flag (defstruct cdb-reader (data closed)) + ;; Maximum CDB size the in-process reader accepts. Matches the wasm + ;; sandbox's CDB_CAP so the fallback path rejects the same files. + (def MAX-CDB-BYTES (* 16 1024 1024)) + + ;; Bounds-checked little-endian uint32 read used by envelope validation. + (def (cdb-le32 bv off) + (let ([len (bytevector-length bv)]) + (when (or (negative? off) (> (+ off 4) len)) + (error 'validate-cdb-bytevector! "truncated uint32" off len)) + (bitwise-ior + (bytevector-u8-ref bv off) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ off 1)) 8) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ off 2)) 16) + (bitwise-arithmetic-shift-left (bytevector-u8-ref bv (+ off 3)) 24)))) + + ;; Validate the complete CDB envelope before any lookup walks the bytes. + ;; A corrupted file must raise here rather than cause an out-of-bounds + ;; read in cdb-find / cdb-find-all. Ported from (jerboa-dns wasm-cdb). + (def (validate-cdb-bytevector! bv) + (let ([len (bytevector-length bv)]) + (when (or (< len 2048) (> len MAX-CDB-BYTES)) + (error 'validate-cdb-bytevector! + "CDB size outside supported range" len MAX-CDB-BYTES)) + + ;; The first non-empty hash table marks the end of the record area. + ;; Every table and every referenced record must remain within the file. + (let ([records-end len]) + (do ([i 0 (+ i 1)]) ((= i 256)) + (let* ([header-off (* i 8)] + [table-pos (cdb-le32 bv header-off)] + [table-count (cdb-le32 bv (+ header-off 4))] + [table-bytes (* table-count 8)]) + (when (or (> table-pos len) (> table-bytes (- len table-pos))) + (error 'validate-cdb-bytevector! + "CDB hash table outside file" i table-pos table-count len)) + (when (> table-count 0) + (set! records-end (min records-end table-pos))))) + + (when (< records-end 2048) + (error 'validate-cdb-bytevector! + "CDB record area overlaps header" records-end)) + + (do ([i 0 (+ i 1)]) ((= i 256) #t) + (let* ([header-off (* i 8)] + [table-pos (cdb-le32 bv header-off)] + [table-count (cdb-le32 bv (+ header-off 4))]) + (do ([slot 0 (+ slot 1)]) ((= slot table-count)) + (let* ([entry-off (+ table-pos (* slot 8))] + [entry-pos (cdb-le32 bv (+ entry-off 4))]) + (unless (zero? entry-pos) + (when (or (< entry-pos 2048) (> (+ entry-pos 8) records-end)) + (error 'validate-cdb-bytevector! + "CDB record header outside record area" + i slot entry-pos records-end)) + (let* ([key-len (cdb-le32 bv entry-pos)] + [data-len (cdb-le32 bv (+ entry-pos 4))] + [payload-len (+ key-len data-len)] + [payload-off (+ entry-pos 8)]) + (when (> payload-len (- records-end payload-off)) + (error 'validate-cdb-bytevector! + "CDB record payload outside record area" + i slot key-len data-len records-end))))))))))) + (def (open-cdb-reader path) ;; Read entire CDB file into memory (let* ([size (get-file-size path)] @@ -84,11 +147,14 @@ (when (< off size) (let ([n (get-bytevector-n! p bv off (- size off))]) (loop (+ off n))))))) + (validate-cdb-bytevector! bv) (make-cdb-reader bv #f))) (def (open-cdb-reader/bytevector bv) ;; Create a CDB reader from a pre-read bytevector. ;; Used when the file was read via openat() in Capsicum capability mode. + ;; Validate the envelope so a corrupted CDB can never reach the lookups. + (validate-cdb-bytevector! bv) (make-cdb-reader bv #f)) (def (get-file-size path) @@ -123,9 +189,15 @@ (cond [(= entry-pos 0) #f] ;; empty slot [(= entry-hash h) + ;; Bounds-check entry_pos before reading (defense in + ;; depth; the envelope was validated at open time). + (when (or (< entry-pos 2048) (> (+ entry-pos 8) data-len)) + (error 'cdb-find "CDB record header out of bounds" entry-pos)) ;; Check key match (let ([rec-keylen (le32-get data entry-pos)] [rec-datalen (le32-get data (+ entry-pos 4))]) + (when (> (+ entry-pos 8 rec-keylen rec-datalen) data-len) + (error 'cdb-find "CDB record payload out of bounds" entry-pos)) (if (and (= rec-keylen key-len) (bv-equal? data (+ entry-pos 8) key-bv key-off key-len)) @@ -152,7 +224,8 @@ [table-count (le32-get data (+ header-off 4))]) (if (= table-count 0) '() - (let ([slot-start (remainder (bitwise-arithmetic-shift-right h 8) table-count)]) + (let ([slot-start (remainder (bitwise-arithmetic-shift-right h 8) table-count)] + [data-len (bytevector-length data)]) (let loop ([slot slot-start] [tries 0] [results '()]) (if (>= tries table-count) (reverse results) @@ -161,18 +234,26 @@ [entry-pos (le32-get data (+ entry-off 4))]) (cond [(= entry-pos 0) (reverse results)] ;; empty slot = end - [(and (= entry-hash h) - (let ([rec-keylen (le32-get data entry-pos)]) - (and (= rec-keylen key-len) - (bv-equal? data (+ entry-pos 8) - key-bv key-off key-len)))) - ;; Match - (let* ([rec-datalen (le32-get data (+ entry-pos 4))] - [result (make-bytevector rec-datalen)]) - (bytevector-copy! data (+ entry-pos 8 key-len) - result 0 rec-datalen) - (loop (remainder (+ slot 1) table-count) (+ tries 1) - (cons result results)))] + [(= entry-hash h) + ;; Bounds-check entry_pos before reading (defense in + ;; depth; the envelope was validated at open time). + (when (or (< entry-pos 2048) (> (+ entry-pos 8) data-len)) + (error 'cdb-find-all "CDB record header out of bounds" entry-pos)) + (let ([rec-keylen (le32-get data entry-pos)] + [rec-datalen (le32-get data (+ entry-pos 4))]) + (when (> (+ entry-pos 8 rec-keylen rec-datalen) data-len) + (error 'cdb-find-all "CDB record payload out of bounds" entry-pos)) + (if (and (= rec-keylen key-len) + (bv-equal? data (+ entry-pos 8) + key-bv key-off key-len)) + ;; Match + (let ([result (make-bytevector rec-datalen)]) + (bytevector-copy! data (+ entry-pos 8 key-len) + result 0 rec-datalen) + (loop (remainder (+ slot 1) table-count) (+ tries 1) + (cons result results))) + (loop (remainder (+ slot 1) table-count) (+ tries 1) + results)))] [else (loop (remainder (+ slot 1) table-count) (+ tries 1) results)]))))))))) --- a/lib/jerboa-dns/protocol.ss +++ b/lib/jerboa-dns/protocol.ss @@ -147,18 +147,26 @@ (def (dns-domain-to-dot bv offset) ;; Convert wire format domain at offset to dotted string. - (let loop ([pos offset] [parts '()]) - (let ([len (bytevector-u8-ref bv pos)]) - (if (= len 0) - (if (null? parts) "." (join-strings (reverse parts) ".")) - (let ([label (let lbl ([i 0] [chars '()]) - (if (= i len) - (list->string (reverse chars)) - (lbl (+ i 1) - (cons (integer->char - (bytevector-u8-ref bv (+ pos 1 i))) - chars))))]) - (loop (+ pos 1 len) (cons label parts))))))) + (let ([bv-len (bytevector-length bv)]) + (let loop ([pos offset] [parts '()]) + ;; Bounds-check pos at each step so a malformed name (missing + ;; terminator or over-long label) cannot read past the bytevector. + (when (or (< pos 0) (>= pos bv-len)) + (error 'dns-domain-to-dot "domain name offset out of bounds" pos bv-len)) + (let ([len (bytevector-u8-ref bv pos)]) + (if (= len 0) + (if (null? parts) "." (join-strings (reverse parts) ".")) + (begin + (when (> (+ pos 1 len) bv-len) + (error 'dns-domain-to-dot "domain label out of bounds" pos len bv-len)) + (let ([label (let lbl ([i 0] [chars '()]) + (if (= i len) + (list->string (reverse chars)) + (lbl (+ i 1) + (cons (integer->char + (bytevector-u8-ref bv (+ pos 1 i))) + chars))))]) + (loop (+ pos 1 len) (cons label parts))))))))) (def (join-strings lst sep) (if (null? lst) "" @@ -168,11 +176,19 @@ (def (dns-domain-length bv offset) ;; Total bytes consumed by the domain name (including terminating 0) - (let loop ([pos offset]) - (let ([len (bytevector-u8-ref bv pos)]) - (if (= len 0) - (+ 1 (- pos offset)) - (loop (+ pos 1 len)))))) + (let ([bv-len (bytevector-length bv)]) + (let loop ([pos offset]) + ;; Bounds-check pos at each step so a malformed name (missing + ;; terminator or over-long label) cannot read past the bytevector. + (when (or (< pos 0) (>= pos bv-len)) + (error 'dns-domain-length "domain name offset out of bounds" pos bv-len)) + (let ([len (bytevector-u8-ref bv pos)]) + (if (= len 0) + (+ 1 (- pos offset)) + (begin + (when (> (+ pos 1 len) bv-len) + (error 'dns-domain-length "domain label out of bounds" pos len bv-len)) + (loop (+ pos 1 len)))))))) (def (dns-domain-equal? bv1 off1 bv2 off2) ;; Case-insensitive comparison of two domain names in wire format --- a/lib/jerboa-dns/response.ss +++ b/lib/jerboa-dns/response.ss @@ -149,6 +149,7 @@ (let ([l (bytevector-u8-ref domain-bv s)]) (cond [(= l 0) + (when (> (+ d 1) 65535) (error 'response-addname! "overflow")) (bytevector-u8-set! buf d 0) ;; Cache the full name if room (when (< nc MAX-NAMES) @@ -159,6 +160,7 @@ (response-state-len-set! rs (+ d 1)) #t] [else + (when (> (+ d 1 l) 65535) (error 'response-addname! "overflow")) (bytevector-u8-set! buf d l) (bytevector-copy! domain-bv (+ s 1) buf (+ d 1) l) (write-rest (+ s 1 l) (+ d 1 l))])))] @@ -180,6 +182,7 @@ (if (= s src) ;; Write pointer (begin + (when (> (+ d 2) 65535) (error 'response-addname! "overflow")) (bytevector-u8-set! buf d (bitwise-ior #xc0 (bitwise-arithmetic-shift-right cached-off 8))) @@ -195,6 +198,7 @@ #t) ;; Write label (let ([l (bytevector-u8-ref domain-bv s)]) + (when (> (+ d 1 l) 65535) (error 'response-addname! "overflow")) (bytevector-u8-set! buf d l) (bytevector-copy! domain-bv (+ s 1) buf (+ d 1) l) (write-prefix (+ s 1 l) (+ d 1 l))))) --- a/lib/jerboa-dns/server.ss +++ b/lib/jerboa-dns/server.ss @@ -201,15 +201,17 @@ (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))) + ;; Load (std fiber) directly into a fresh, isolated environment + ;; rather than importing into the global interaction-environment. + ;; (environment ...) raises if the module is unavailable, which the + ;; guard above turns into the 'unavailable state. Bindings are then + ;; read from that controlled environment, and the state flag is set + ;; only after every lookup succeeds. + (let ([env (environment '(std fiber))]) + (set! *make-fiber-runtime* (eval 'make-fiber-runtime env)) + (set! *fiber-spawn* (eval 'fiber-spawn env)) + (set! *fiber-runtime-run!* (eval 'fiber-runtime-run! env)) + (set! *fiber-sleep* (eval 'fiber-sleep env))) (set! *fiber-support-state* 'available) #t)])) @@ -953,23 +955,33 @@ [addrlen-buf (foreign-alloc 4)] [rs (new-response-state)]) - (let loop () - ;; Reset addrlen - (foreign-set! 'int addrlen-buf 0 SOCKADDR_IN_SIZE) - - ;; Receive packet - (let ([n (c-recvfrom udp-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 recv-buf n client-addr cdb-cache - (lambda (out-rs) - (send-udp-response! udp-sock out-rs client-addr)) - MAX-PACKET)))) - - (loop))))))) + ;; Free the foreign buffers if the loop ever exits (exception + ;; or shutdown), matching the per-iteration cleanup the TCP + ;; accept loop already performs. + (dynamic-wind + (lambda () (void)) + (lambda () + (let loop () + ;; Reset addrlen + (foreign-set! 'int addrlen-buf 0 SOCKADDR_IN_SIZE) + + ;; Receive packet + (let ([n (c-recvfrom udp-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 recv-buf n client-addr cdb-cache + (lambda (out-rs) + (send-udp-response! udp-sock out-rs client-addr)) + MAX-PACKET)))) + + (loop)) + (lambda () + (foreign-free recv-buf) + (foreign-free client-addr) + (foreign-free addrlen-buf))))))))) ) ;; ========== Landlock Sandbox (Linux) ==========