Rewrite lib/jerboa-dns modules as Jerboa .ss (were raw Chez .sls)
ober
27090cb73989dc5d9e85cb309c84e797c8fe70b5
deleted file mode 100644 --- a/lib/jerboa-dns/cdb.sls +++ /dev/null @@ -1,295 +0,0 @@ -#!chezscheme -;;; (jerboa-dns cdb) — DJB constant database (CDB) reader and writer -;;; -;;; CDB is an immutable key-value store with O(1) lookups via perfect -;;; hashing. Used by djbdns for zone data. Atomic updates via rebuild -;;; and rename. -;;; -;;; File format: -;;; Header: 256 hash tables × 8 bytes = 2048 bytes -;;; Each: (position:uint32-le, count:uint32-le) -;;; Records: [keylen:uint32-le][datalen:uint32-le][key][data] -;;; Hash tables: [hash:uint32-le][position:uint32-le] pairs - -(library (jerboa-dns cdb) - (export - ;; Hash function - cdb-hash - - ;; Reader - open-cdb-reader open-cdb-reader/bytevector cdb-reader? - cdb-reader-close! - cdb-find - cdb-find-all - - ;; Writer - open-cdb-writer cdb-writer? - cdb-add! - cdb-finish!) - - (import (chezscheme)) - - ;; ========== DJB Hash ========== - ;; h = 5381; for each byte c: h = ((h << 5) + h) ^ c - - (define (cdb-hash bv offset len) - (let loop ([i 0] [h 5381]) - (if (= i len) - (bitwise-and h #xffffffff) - (let ([c (bytevector-u8-ref bv (+ offset i))]) - (loop (+ i 1) - (bitwise-and - (bitwise-xor - (+ (bitwise-arithmetic-shift-left h 5) h) - c) - #xffffffff)))))) - - ;; ========== Little-Endian Helpers ========== - - (define (le32-get bv off) - (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))) - - (define (le32-put! bv off val) - (bytevector-u8-set! bv off (bitwise-and val #xff)) - (bytevector-u8-set! bv (+ off 1) (bitwise-and (bitwise-arithmetic-shift-right val 8) #xff)) - (bytevector-u8-set! bv (+ off 2) (bitwise-and (bitwise-arithmetic-shift-right val 16) #xff)) - (bytevector-u8-set! bv (+ off 3) (bitwise-and (bitwise-arithmetic-shift-right val 24) #xff))) - - ;; ========== CDB Reader ========== - - (define-record-type cdb-reader - (fields - data ;; bytevector (entire file contents) - (mutable closed)) - (nongenerative cdb-reader)) - - (define (open-cdb-reader path) - ;; Read entire CDB file into memory - (let* ([size (get-file-size path)] - [bv (make-bytevector size)]) - (call-with-port - (open-file-input-port path (file-options) (buffer-mode block)) - (lambda (p) - (let loop ([off 0]) - (when (< off size) - (let ([n (get-bytevector-n! p bv off (- size off))]) - (loop (+ off n))))))) - (make-cdb-reader bv #f))) - - (define (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. - (make-cdb-reader bv #f)) - - (define (get-file-size path) - (let ([p (open-file-input-port path)]) - (let ([len (port-length p)]) - (close-port p) - len))) - - (define (cdb-reader-close! reader) - (cdb-reader-closed-set! reader #t)) - - (define (cdb-find reader key-bv key-off key-len) - ;; Find first matching value. Returns bytevector or #f. - (let ([data (cdb-reader-data reader)]) - (when (< (bytevector-length data) 2048) - (error 'cdb-find "CDB file too small")) - (let* ([h (cdb-hash key-bv key-off key-len)] - [table-idx (bitwise-and h 255)] - [header-off (* table-idx 8)] - [table-pos (le32-get data header-off)] - [table-count (le32-get data (+ header-off 4))]) - (if (= table-count 0) - #f - (let* ([slot-start (remainder (bitwise-arithmetic-shift-right h 8) table-count)] - [data-len (bytevector-length data)]) - (let loop ([slot slot-start] [tries 0]) - (if (>= tries table-count) - #f - (let* ([entry-off (+ table-pos (* slot 8))] - [entry-hash (le32-get data entry-off)] - [entry-pos (le32-get data (+ entry-off 4))]) - (cond - [(= entry-pos 0) #f] ;; empty slot - [(= entry-hash h) - ;; Check key match - (let ([rec-keylen (le32-get data entry-pos)] - [rec-datalen (le32-get data (+ entry-pos 4))]) - (if (and (= rec-keylen key-len) - (bv-equal? data (+ entry-pos 8) - key-bv key-off key-len)) - ;; Match! Return data as new bytevector - (let ([result (make-bytevector rec-datalen)]) - (bytevector-copy! data (+ entry-pos 8 key-len) - result 0 rec-datalen) - result) - ;; Hash collision, try next slot - (loop (remainder (+ slot 1) table-count) (+ tries 1))))] - [else - (loop (remainder (+ slot 1) table-count) (+ tries 1))]))))))))) - - (define (cdb-find-all reader key-bv key-off key-len) - ;; Find ALL matching values (DNS needs multiple records per domain). - ;; Returns list of bytevectors. - (let ([data (cdb-reader-data reader)]) - (when (< (bytevector-length data) 2048) - (error 'cdb-find-all "CDB file too small")) - (let* ([h (cdb-hash key-bv key-off key-len)] - [table-idx (bitwise-and h 255)] - [header-off (* table-idx 8)] - [table-pos (le32-get data header-off)] - [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 loop ([slot slot-start] [tries 0] [results '()]) - (if (>= tries table-count) - (reverse results) - (let* ([entry-off (+ table-pos (* slot 8))] - [entry-hash (le32-get data entry-off)] - [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)))] - [else - (loop (remainder (+ slot 1) table-count) (+ tries 1) - results)]))))))))) - - (define (bv-equal? bv1 off1 bv2 off2 len) - (let loop ([i 0]) - (if (= i len) #t - (and (= (bytevector-u8-ref bv1 (+ off1 i)) - (bytevector-u8-ref bv2 (+ off2 i))) - (loop (+ i 1)))))) - - ;; ========== CDB Writer ========== - ;; Accumulates records, then writes the complete CDB file on finish. - - (define-record-type cdb-entry - (fields - hash ;; uint32 - pos ;; position in data section - ) - (nongenerative cdb-entry)) - - (define-record-type cdb-writer - (fields - path ;; output file path - (mutable port) ;; output port - (mutable pos) ;; current write position - (mutable tables) ;; vector of 256 lists of cdb-entry - ) - (nongenerative cdb-writer)) - - (define (open-cdb-writer path) - (let ([port (open-file-output-port path - (file-options no-fail) - (buffer-mode block))] - [tables (make-vector 256 '())]) - ;; Reserve 2048 bytes for header (will be filled in finish) - (let ([header (make-bytevector 2048 0)]) - (put-bytevector port header)) - (make-cdb-writer path port 2048 tables))) - - (define (cdb-add! writer key-bv key-len data-bv data-len) - ;; Add a key-value pair - (let* ([port (cdb-writer-port writer)] - [pos (cdb-writer-pos writer)] - [h (cdb-hash key-bv 0 key-len)] - [table-idx (bitwise-and h 255)] - [header-buf (make-bytevector 8)]) - ;; Write record header: keylen + datalen - (le32-put! header-buf 0 key-len) - (le32-put! header-buf 4 data-len) - (put-bytevector port header-buf) - ;; Write key - (if (= key-len (bytevector-length key-bv)) - (put-bytevector port key-bv) - (put-bytevector port key-bv 0 key-len)) - ;; Write data - (if (= data-len (bytevector-length data-bv)) - (put-bytevector port data-bv) - (put-bytevector port data-bv 0 data-len)) - ;; Update position - (cdb-writer-pos-set! writer (+ pos 8 key-len data-len)) - ;; Track entry for hash table - (let ([entry (make-cdb-entry h pos)]) - (vector-set! (cdb-writer-tables writer) table-idx - (cons entry (vector-ref (cdb-writer-tables writer) table-idx)))))) - - (define (cdb-finish! writer) - ;; Write hash tables and header, close file. - (let ([port (cdb-writer-port writer)] - [tables (cdb-writer-tables writer)] - [header (make-bytevector 2048 0)]) - - ;; Write each of the 256 hash tables - (do ([i 0 (+ i 1)]) - ((= i 256)) - (let* ([entries (reverse (vector-ref tables i))] - [count (length entries)] - ;; Hash table size is 2× entry count (for open addressing) - [table-size (if (= count 0) 0 (* count 2))] - [table-pos (cdb-writer-pos writer)]) - - ;; Record position and count in header - (le32-put! header (* i 8) table-pos) - (le32-put! header (+ (* i 8) 4) table-size) - - (when (> table-size 0) - ;; Build hash table with open addressing - (let ([slots (make-vector table-size #f)]) - ;; Insert entries - (for-each - (lambda (entry) - (let ([start (remainder - (bitwise-arithmetic-shift-right - (cdb-entry-hash entry) 8) - table-size)]) - (let probe ([s start]) - (if (vector-ref slots s) - (probe (remainder (+ s 1) table-size)) - (vector-set! slots s entry))))) - entries) - - ;; Write slots - (let ([buf (make-bytevector 8 0)]) - (do ([s 0 (+ s 1)]) - ((= s table-size)) - (let ([entry (vector-ref slots s)]) - (if entry - (begin - (le32-put! buf 0 (cdb-entry-hash entry)) - (le32-put! buf 4 (cdb-entry-pos entry))) - (begin - (le32-put! buf 0 0) - (le32-put! buf 4 0))) - (put-bytevector port buf)))) - - ;; Update writer position - (cdb-writer-pos-set! writer - (+ table-pos (* table-size 8))))))) - - ;; Write header at the beginning - (set-port-position! port 0) - (put-bytevector port header) - (close-port port) - (cdb-writer-port-set! writer #f))) - - ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-dns/cdb.ss @@ -0,0 +1,292 @@ +#!chezscheme +;;; (jerboa-dns cdb) — DJB constant database (CDB) reader and writer +;;; +;;; CDB is an immutable key-value store with O(1) lookups via perfect +;;; hashing. Used by djbdns for zone data. Atomic updates via rebuild +;;; and rename. +;;; +;;; File format: +;;; Header: 256 hash tables × 8 bytes = 2048 bytes +;;; Each: (position:uint32-le, count:uint32-le) +;;; Records: [keylen:uint32-le][datalen:uint32-le][key][data] +;;; Hash tables: [hash:uint32-le][position:uint32-le] pairs + +(library (jerboa-dns cdb) + (export + ;; Hash function + cdb-hash + + ;; Reader + open-cdb-reader open-cdb-reader/bytevector cdb-reader? + cdb-reader-close! + cdb-find + cdb-find-all + + ;; Writer + open-cdb-writer cdb-writer? + cdb-add! + cdb-finish!) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (except (jerboa prelude) meta atom?)) + + ;; ========== DJB Hash ========== + ;; h = 5381; for each byte c: h = ((h << 5) + h) ^ c + + (def (cdb-hash bv offset len) + (let loop ([i 0] [h 5381]) + (if (= i len) + (bitwise-and h #xffffffff) + (let ([c (bytevector-u8-ref bv (+ offset i))]) + (loop (+ i 1) + (bitwise-and + (bitwise-xor + (+ (bitwise-arithmetic-shift-left h 5) h) + c) + #xffffffff)))))) + + ;; ========== Little-Endian Helpers ========== + + (def (le32-get bv off) + (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))) + + (def (le32-put! bv off val) + (bytevector-u8-set! bv off (bitwise-and val #xff)) + (bytevector-u8-set! bv (+ off 1) (bitwise-and (bitwise-arithmetic-shift-right val 8) #xff)) + (bytevector-u8-set! bv (+ off 2) (bitwise-and (bitwise-arithmetic-shift-right val 16) #xff)) + (bytevector-u8-set! bv (+ off 3) (bitwise-and (bitwise-arithmetic-shift-right val 24) #xff))) + + ;; ========== CDB Reader ========== + + ;; data: bytevector (entire file contents); closed: mutable flag + (defstruct cdb-reader (data closed)) + + (def (open-cdb-reader path) + ;; Read entire CDB file into memory + (let* ([size (get-file-size path)] + [bv (make-bytevector size)]) + (call-with-port + (open-file-input-port path (file-options) (buffer-mode block)) + (lambda (p) + (let loop ([off 0]) + (when (< off size) + (let ([n (get-bytevector-n! p bv off (- size off))]) + (loop (+ off n))))))) + (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. + (make-cdb-reader bv #f)) + + (def (get-file-size path) + (let ([p (open-file-input-port path)]) + (let ([len (port-length p)]) + (close-port p) + len))) + + (def (cdb-reader-close! reader) + (cdb-reader-closed-set! reader #t)) + + (def (cdb-find reader key-bv key-off key-len) + ;; Find first matching value. Returns bytevector or #f. + (let ([data (cdb-reader-data reader)]) + (when (< (bytevector-length data) 2048) + (error 'cdb-find "CDB file too small")) + (let* ([h (cdb-hash key-bv key-off key-len)] + [table-idx (bitwise-and h 255)] + [header-off (* table-idx 8)] + [table-pos (le32-get data header-off)] + [table-count (le32-get data (+ header-off 4))]) + (if (= table-count 0) + #f + (let* ([slot-start (remainder (bitwise-arithmetic-shift-right h 8) table-count)] + [data-len (bytevector-length data)]) + (let loop ([slot slot-start] [tries 0]) + (if (>= tries table-count) + #f + (let* ([entry-off (+ table-pos (* slot 8))] + [entry-hash (le32-get data entry-off)] + [entry-pos (le32-get data (+ entry-off 4))]) + (cond + [(= entry-pos 0) #f] ;; empty slot + [(= entry-hash h) + ;; Check key match + (let ([rec-keylen (le32-get data entry-pos)] + [rec-datalen (le32-get data (+ entry-pos 4))]) + (if (and (= rec-keylen key-len) + (bv-equal? data (+ entry-pos 8) + key-bv key-off key-len)) + ;; Match! Return data as new bytevector + (let ([result (make-bytevector rec-datalen)]) + (bytevector-copy! data (+ entry-pos 8 key-len) + result 0 rec-datalen) + result) + ;; Hash collision, try next slot + (loop (remainder (+ slot 1) table-count) (+ tries 1))))] + [else + (loop (remainder (+ slot 1) table-count) (+ tries 1))]))))))))) + + (def (cdb-find-all reader key-bv key-off key-len) + ;; Find ALL matching values (DNS needs multiple records per domain). + ;; Returns list of bytevectors. + (let ([data (cdb-reader-data reader)]) + (when (< (bytevector-length data) 2048) + (error 'cdb-find-all "CDB file too small")) + (let* ([h (cdb-hash key-bv key-off key-len)] + [table-idx (bitwise-and h 255)] + [header-off (* table-idx 8)] + [table-pos (le32-get data header-off)] + [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 loop ([slot slot-start] [tries 0] [results '()]) + (if (>= tries table-count) + (reverse results) + (let* ([entry-off (+ table-pos (* slot 8))] + [entry-hash (le32-get data entry-off)] + [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)))] + [else + (loop (remainder (+ slot 1) table-count) (+ tries 1) + results)]))))))))) + + (def (bv-equal? bv1 off1 bv2 off2 len) + (let loop ([i 0]) + (if (= i len) #t + (and (= (bytevector-u8-ref bv1 (+ off1 i)) + (bytevector-u8-ref bv2 (+ off2 i))) + (loop (+ i 1)))))) + + ;; ========== CDB Writer ========== + ;; Accumulates records, then writes the complete CDB file on finish. + + ;; hash: uint32; pos: position in data section + (defstruct cdb-entry (hash pos)) + + ;; path: output file; port: output port; pos: write position; + ;; tables: vector of 256 lists of cdb-entry + (defstruct cdb-writer (path port pos tables)) + + (def (open-cdb-writer path) + (let ([port (open-file-output-port path + (file-options no-fail) + (buffer-mode block))] + [tables (make-vector 256 '())]) + ;; Reserve 2048 bytes for header (will be filled in finish) + (let ([header (make-bytevector 2048 0)]) + (put-bytevector port header)) + (make-cdb-writer path port 2048 tables))) + + (def (cdb-add! writer key-bv key-len data-bv data-len) + ;; Add a key-value pair + (let* ([port (cdb-writer-port writer)] + [pos (cdb-writer-pos writer)] + [h (cdb-hash key-bv 0 key-len)] + [table-idx (bitwise-and h 255)] + [header-buf (make-bytevector 8)]) + ;; Write record header: keylen + datalen + (le32-put! header-buf 0 key-len) + (le32-put! header-buf 4 data-len) + (put-bytevector port header-buf) + ;; Write key + (if (= key-len (bytevector-length key-bv)) + (put-bytevector port key-bv) + (put-bytevector port key-bv 0 key-len)) + ;; Write data + (if (= data-len (bytevector-length data-bv)) + (put-bytevector port data-bv) + (put-bytevector port data-bv 0 data-len)) + ;; Update position + (cdb-writer-pos-set! writer (+ pos 8 key-len data-len)) + ;; Track entry for hash table + (let ([entry (make-cdb-entry h pos)]) + (vector-set! (cdb-writer-tables writer) table-idx + (cons entry (vector-ref (cdb-writer-tables writer) table-idx)))))) + + (def (cdb-finish! writer) + ;; Write hash tables and header, close file. + (let ([port (cdb-writer-port writer)] + [tables (cdb-writer-tables writer)] + [header (make-bytevector 2048 0)]) + + ;; Write each of the 256 hash tables + (do ([i 0 (+ i 1)]) + ((= i 256)) + (let* ([entries (reverse (vector-ref tables i))] + [count (length entries)] + ;; Hash table size is 2× entry count (for open addressing) + [table-size (if (= count 0) 0 (* count 2))] + [table-pos (cdb-writer-pos writer)]) + + ;; Record position and count in header + (le32-put! header (* i 8) table-pos) + (le32-put! header (+ (* i 8) 4) table-size) + + (when (> table-size 0) + ;; Build hash table with open addressing + (let ([slots (make-vector table-size #f)]) + ;; Insert entries + (for-each + (lambda (entry) + (let ([start (remainder + (bitwise-arithmetic-shift-right + (cdb-entry-hash entry) 8) + table-size)]) + (let probe ([s start]) + (if (vector-ref slots s) + (probe (remainder (+ s 1) table-size)) + (vector-set! slots s entry))))) + entries) + + ;; Write slots + (let ([buf (make-bytevector 8 0)]) + (do ([s 0 (+ s 1)]) + ((= s table-size)) + (let ([entry (vector-ref slots s)]) + (if entry + (begin + (le32-put! buf 0 (cdb-entry-hash entry)) + (le32-put! buf 4 (cdb-entry-pos entry))) + (begin + (le32-put! buf 0 0) + (le32-put! buf 4 0))) + (put-bytevector port buf)))) + + ;; Update writer position + (cdb-writer-pos-set! writer + (+ table-pos (* table-size 8))))))) + + ;; Write header at the beginning + (set-port-position! port 0) + (put-bytevector port header) + (close-port port) + (cdb-writer-port-set! writer #f))) + + ) ;; end library deleted file mode 100644 --- a/lib/jerboa-dns/log.sls +++ /dev/null @@ -1,178 +0,0 @@ -#!chezscheme -;;; (jerboa-dns log) — structured logfmt logger for jdns. -;;; -;;; All events are written to stderr as a single line in logfmt: -;;; -;;; ts=2026-05-17T03:25:09.624Z lvl=info evt=query src=192.0.2.1:53122 \ -;;; qid=0x4f3a qname=example.com qtype=A qclass=IN rcode=NOERROR \ -;;; resp_bytes=64 lat_us=312 -;;; -;;; Values containing space, =, or " are double-quoted and escaped. -;;; -;;; Verbosity: per-query info events are gated by *log-queries* (default -;;; #f, since a busy authoritative server emits thousands of these per -;;; second). Warn-level events (malformed/refused/servfail) are always -;;; emitted regardless. - -(library (jerboa-dns log) - (export - log-startup - log-query - log-malformed - log-refused - log-servfail - log-error - log-info - set-log-queries! - log-queries-on? - qtype-name - rcode-name - bytes-prefix-hex) - - (import (chezscheme)) - - ;; ── Verbosity toggle ─────────────────────────────────────────────────── - (define *log-queries* #f) - (define (log-queries-on?) *log-queries*) - (define (set-log-queries! flag) (set! *log-queries* (and flag #t))) - - ;; ── Timestamp ────────────────────────────────────────────────────────── - ;; ISO-8601 UTC with millisecond precision. Uses Chez (current-date 0) - ;; which returns a date record with the requested UTC offset. - (define (format-ts!) - (let* ([d (current-date 0)] - [ms (quotient (date-nanosecond d) 1000000)]) - (fprintf (current-error-port) - "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d.~3,'0dZ" - (date-year d) (date-month d) (date-day d) - (date-hour d) (date-minute d) (date-second d) ms))) - - ;; ── logfmt value quoting ─────────────────────────────────────────────── - (define (needs-quoting? s) - (let loop ([i 0]) - (cond - [(= i (string-length s)) #f] - [(let ([c (string-ref s i)]) - (or (char=? c #\space) (char=? c #\=) (char=? c #\") - (char<? c #\space))) - #t] - [else (loop (+ i 1))]))) - - (define (write-quoted! port s) - (write-char #\" port) - (let loop ([i 0]) - (cond - [(= i (string-length s)) (write-char #\" port)] - [else - (let ([c (string-ref s i)]) - (cond - [(char=? c #\") (write-char #\\ port) (write-char #\" port)] - [(char=? c #\\) (write-char #\\ port) (write-char #\\ port)] - [(char=? c #\newline) (write-char #\\ port) (write-char #\n port)] - [(char=? c #\tab) (write-char #\\ port) (write-char #\t port)] - [else (write-char c port)]) - (loop (+ i 1)))]))) - - (define (write-value! port v) - (let ([s (cond - [(string? v) v] - [(symbol? v) (symbol->string v)] - [(number? v) (number->string v)] - [(boolean? v) (if v "true" "false")] - [(not v) "-"] - [else (format "~a" v)])]) - (cond - [(zero? (string-length s)) (display "\"\"" port)] - [(needs-quoting? s) (write-quoted! port s)] - [else (display s port)]))) - - ;; ── Core emitter ─────────────────────────────────────────────────────── - ;; kvs is a flat list: (key val key val ...). Keys are symbols, values - ;; can be any displayable atom. Missing values (#f) print as `-`. - (define (emit! level event kvs) - (let ([p (current-error-port)]) - (display "ts=" p) (format-ts!) - (display " lvl=" p) (display level p) - (display " evt=" p) (display event p) - (let loop ([rest kvs]) - (cond - [(null? rest) (void)] - [(null? (cdr rest)) - (error 'emit! "odd number of key/value args" event kvs)] - [else - (write-char #\space p) - (display (car rest) p) - (write-char #\= p) - (write-value! p (cadr rest)) - (loop (cddr rest))])) - (newline p) - (flush-output-port p))) - - ;; ── Public helpers ───────────────────────────────────────────────────── - ;; Each takes positional args (kept short for callers) and produces one - ;; event line. Use log-info / log-error for ad-hoc events without a - ;; dedicated helper. - - (define (log-startup . kvs) (emit! 'info 'startup kvs)) - (define (log-info evt . kvs) (emit! 'info evt kvs)) - (define (log-error evt . kvs) (emit! 'error evt kvs)) - - (define (log-query src qid qname qtype qclass rcode resp-bytes lat-us) - (when *log-queries* - (emit! 'info 'query - (list 'src src 'qid qid 'qname qname 'qtype qtype 'qclass qclass - 'rcode rcode 'resp_bytes resp-bytes 'lat_us lat-us)))) - - (define (log-malformed src bytes first16 reason) - (emit! 'warn 'malformed - (list 'src src 'bytes bytes 'first16 first16 'reason reason))) - - (define (log-refused src qid qname qtype reason) - (emit! 'warn 'refused - (list 'src src 'qid qid 'qname qname 'qtype qtype 'reason reason))) - - (define (log-servfail src qid qname qtype reason) - (emit! 'warn 'servfail - (list 'src src 'qid qid 'qname qname 'qtype qtype 'reason reason))) - - ;; ── Shared lookup tables ────────────────────────────────────────────── - ;; Mapping qtype codes to symbolic names (covers everything jdns-data - ;; can emit plus the few client-side query types that may show up). - (define (qtype-name n) - (case n - [(1) "A"] [(2) "NS"] [(5) "CNAME"] - [(6) "SOA"] [(12) "PTR"] [(15) "MX"] - [(16) "TXT"] [(28) "AAAA"] [(33) "SRV"] - [(35) "NAPTR"] [(43) "DS"] [(46) "RRSIG"] - [(47) "NSEC"] [(48) "DNSKEY"][(50) "NSEC3"] - [(52) "TLSA"] [(99) "SPF"] [(252) "AXFR"] - [(253) "MAILB"] [(255) "ANY"] - [else (number->string n)])) - - ;; DNS RCODEs (RFC 1035 §4.1.1) — low 4 bits of header byte 3. - (define (rcode-name code) - (case (bitwise-and code #x0f) - [(0) "NOERROR"] [(1) "FORMERR"] - [(2) "SERVFAIL"] [(3) "NXDOMAIN"] - [(4) "NOTIMP"] [(5) "REFUSED"] - [else (number->string code)])) - - ;; First N bytes of a bytevector as a continuous hex string — useful for - ;; including in malformed-packet logs so an operator can decode by hand. - (define (bytes-prefix-hex bv n) - (let* ([m (min n (bytevector-length bv))] - [out (make-string (* m 2))]) - (do ([i 0 (+ i 1)]) ((= i m)) - (let* ([b (bytevector-u8-ref bv i)] - [hi (quotient b 16)] - [lo (remainder b 16)]) - (string-set! out (* i 2) (hex-digit hi)) - (string-set! out (+ (* i 2) 1) (hex-digit lo)))) - out)) - - (define (hex-digit n) - (cond - [(< n 10) (integer->char (+ (char->integer #\0) n))] - [else (integer->char (+ (char->integer #\a) (- n 10)))])) - - ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-dns/log.ss @@ -0,0 +1,187 @@ +#!chezscheme +;;; (jerboa-dns log) — structured logfmt logger for jdns. +;;; +;;; All events are written to stderr as a single line in logfmt: +;;; +;;; ts=2026-05-17T03:25:09.624Z lvl=info evt=query src=192.0.2.1:53122 \ +;;; qid=0x4f3a qname=example.com qtype=A qclass=IN rcode=NOERROR \ +;;; resp_bytes=64 lat_us=312 +;;; +;;; Values containing space, =, or " are double-quoted and escaped. +;;; +;;; Verbosity: per-query info events are gated by *log-queries* (default +;;; #f, since a busy authoritative server emits thousands of these per +;;; second). Warn-level events (malformed/refused/servfail) are always +;;; emitted regardless. + +(library (jerboa-dns log) + (export + log-startup + log-query + log-malformed + log-refused + log-servfail + log-error + log-info + set-log-queries! + log-queries-on? + qtype-name + rcode-name + bytes-prefix-hex) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (except (jerboa prelude) meta atom?)) + + ;; ── Verbosity toggle ─────────────────────────────────────────────────── + (def *log-queries* #f) + (def (log-queries-on?) *log-queries*) + (def (set-log-queries! flag) (set! *log-queries* (and flag #t))) + + ;; ── Timestamp ────────────────────────────────────────────────────────── + ;; ISO-8601 UTC with millisecond precision. Uses Chez (current-date 0) + ;; which returns a date record with the requested UTC offset. + (def (format-ts!) + (let* ([d (current-date 0)] + [ms (quotient (date-nanosecond d) 1000000)]) + (fprintf (current-error-port) + "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d.~3,'0dZ" + (date-year d) (date-month d) (date-day d) + (date-hour d) (date-minute d) (date-second d) ms))) + + ;; ── logfmt value quoting ─────────────────────────────────────────────── + (def (needs-quoting? s) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(let ([c (string-ref s i)]) + (or (char=? c #\space) (char=? c #\=) (char=? c #\") + (char<? c #\space))) + #t] + [else (loop (+ i 1))]))) + + (def (write-quoted! port s) + (write-char #\" port) + (let loop ([i 0]) + (cond + [(= i (string-length s)) (write-char #\" port)] + [else + (let ([c (string-ref s i)]) + (cond + [(char=? c #\") (write-char #\\ port) (write-char #\" port)] + [(char=? c #\\) (write-char #\\ port) (write-char #\\ port)] + [(char=? c #\newline) (write-char #\\ port) (write-char #\n port)] + [(char=? c #\tab) (write-char #\\ port) (write-char #\t port)] + [else (write-char c port)]) + (loop (+ i 1)))]))) + + (def (write-value! port v) + (let ([s (cond + [(string? v) v] + [(symbol? v) (symbol->string v)] + [(number? v) (number->string v)] + [(boolean? v) (if v "true" "false")] + [(not v) "-"] + [else (format "~a" v)])]) + (cond + [(zero? (string-length s)) (display "\"\"" port)] + [(needs-quoting? s) (write-quoted! port s)] + [else (display s port)]))) + + ;; ── Core emitter ─────────────────────────────────────────────────────── + ;; kvs is a flat list: (key val key val ...). Keys are symbols, values + ;; can be any displayable atom. Missing values (#f) print as `-`. + (def (emit! level event kvs) + (let ([p (current-error-port)]) + (display "ts=" p) (format-ts!) + (display " lvl=" p) (display level p) + (display " evt=" p) (display event p) + (let loop ([rest kvs]) + (cond + [(null? rest) (void)] + [(null? (cdr rest)) + (error 'emit! "odd number of key/value args" event kvs)] + [else + (write-char #\space p) + (display (car rest) p) + (write-char #\= p) + (write-value! p (cadr rest)) + (loop (cddr rest))])) + (newline p) + (flush-output-port p))) + + ;; ── Public helpers ───────────────────────────────────────────────────── + ;; Each takes positional args (kept short for callers) and produces one + ;; event line. Use log-info / log-error for ad-hoc events without a + ;; dedicated helper. + + (def (log-startup . kvs) (emit! 'info 'startup kvs)) + (def (log-info evt . kvs) (emit! 'info evt kvs)) + (def (log-error evt . kvs) (emit! 'error evt kvs)) + + (def (log-query src qid qname qtype qclass rcode resp-bytes lat-us) + (when *log-queries* + (emit! 'info 'query + (list 'src src 'qid qid 'qname qname 'qtype qtype 'qclass qclass + 'rcode rcode 'resp_bytes resp-bytes 'lat_us lat-us)))) + + (def (log-malformed src bytes first16 reason) + (emit! 'warn 'malformed + (list 'src src 'bytes bytes 'first16 first16 'reason reason))) + + (def (log-refused src qid qname qtype reason) + (emit! 'warn 'refused + (list 'src src 'qid qid 'qname qname 'qtype qtype 'reason reason))) + + (def (log-servfail src qid qname qtype reason) + (emit! 'warn 'servfail + (list 'src src 'qid qid 'qname qname 'qtype qtype 'reason reason))) + + ;; ── Shared lookup tables ────────────────────────────────────────────── + ;; Mapping qtype codes to symbolic names (covers everything jdns-data + ;; can emit plus the few client-side query types that may show up). + (def (qtype-name n) + (case n + [(1) "A"] [(2) "NS"] [(5) "CNAME"] + [(6) "SOA"] [(12) "PTR"] [(15) "MX"] + [(16) "TXT"] [(28) "AAAA"] [(33) "SRV"] + [(35) "NAPTR"] [(43) "DS"] [(46) "RRSIG"] + [(47) "NSEC"] [(48) "DNSKEY"][(50) "NSEC3"] + [(52) "TLSA"] [(99) "SPF"] [(252) "AXFR"] + [(253) "MAILB"] [(255) "ANY"] + [else (number->string n)])) + + ;; DNS RCODEs (RFC 1035 §4.1.1) — low 4 bits of header byte 3. + (def (rcode-name code) + (case (bitwise-and code #x0f) + [(0) "NOERROR"] [(1) "FORMERR"] + [(2) "SERVFAIL"] [(3) "NXDOMAIN"] + [(4) "NOTIMP"] [(5) "REFUSED"] + [else (number->string code)])) + + ;; First N bytes of a bytevector as a continuous hex string — useful for + ;; including in malformed-packet logs so an operator can decode by hand. + (def (bytes-prefix-hex bv n) + (let* ([m (min n (bytevector-length bv))] + [out (make-string (* m 2))]) + (do ([i 0 (+ i 1)]) ((= i m)) + (let* ([b (bytevector-u8-ref bv i)] + [hi (quotient b 16)] + [lo (remainder b 16)]) + (string-set! out (* i 2) (hex-digit hi)) + (string-set! out (+ (* i 2) 1) (hex-digit lo)))) + out)) + + (def (hex-digit n) + (cond + [(< n 10) (integer->char (+ (char->integer #\0) n))] + [else (integer->char (+ (char->integer #\a) (- n 10)))])) + + ) ;; end library deleted file mode 100644 --- a/lib/jerboa-dns/lookup.sls +++ /dev/null @@ -1,307 +0,0 @@ -#!chezscheme -;;; (jerboa-dns lookup) — DNS record lookup engine -;;; -;;; Translates djbdns tdlookup.c. Walks the domain hierarchy to find -;;; the authoritative zone, looks up records in CDB, builds the -;;; complete DNS response with answer, authority, and additional sections. - -(library (jerboa-dns lookup) - (export dns-respond) - - (import - (chezscheme) - (jerboa-dns protocol) - ;; cdb-find-all is routed through the sandbox wrapper; the plain - ;; (jerboa-dns cdb) reader survives as the fallback path inside - ;; sandboxed-cdb-find-all. - (rename (jerboa-dns wasm-cdb) (sandboxed-cdb-find-all cdb-find-all)) - (jerboa-dns response) - (jerboa-dns zone)) - - ;; ========== CDB Value Parsing ========== - ;; CDB value format: [type:2][flag:1][ttl:4][rdata:variable] - - (define (cdb-val-type val) - (uint16-get val 0)) - - (define (cdb-val-flag val) - (bytevector-u8-ref val 2)) - - (define (cdb-val-ttl val) - (uint32-get val 3)) - - (define (cdb-val-rdata val) - ;; Returns the rdata portion as a new bytevector - (let* ([total (bytevector-length val)] - [rdata-start 7] - [rdata-len (- total rdata-start)]