Add djbdns-inspired authoritative DNS server
Jaime Fournier
8cec4aa52f7d94241d9159160a3fa5bfad29f598
new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,29 @@ +SCHEME ?= scheme +JERBOA ?= $(HOME)/mine/jerboa/lib +LIBDIRS = lib:$(JERBOA) + +.PHONY: all build test clean jdns jdns-data + +all: build + +build: + @echo "Compiling jerboa-dns libraries..." + @$(SCHEME) --libdirs "$(LIBDIRS)" --compile-imported-libraries --script build.ss + +jdns: build + $(SCHEME) --libdirs "$(LIBDIRS)" --script bin/jdns.ss + +jdns-data: build + $(SCHEME) --libdirs "$(LIBDIRS)" --script bin/jdns-data.ss $(ARGS) + +test: build + @echo "Running tests..." + @for f in tests/*-test.ss; do \ + echo " $$f"; \ + $(SCHEME) --libdirs "$(LIBDIRS)" --script "$$f" || exit 1; \ + done + @echo "All tests passed." + +clean: + find lib -name '*.so' -delete 2>/dev/null || true + find lib -name '*.wpo' -delete 2>/dev/null || true new file mode 100644 --- /dev/null +++ b/bin/jdns-convert.ss @@ -0,0 +1,472 @@ +#!chezscheme +;;; jdns-convert — Convert tinydns data files to a human-readable zone format +;;; +;;; Reads DJB tinydns "data" format and outputs a clean, readable format +;;; that groups records by domain with explicit record types. +;;; +;;; Usage: scheme --libdirs lib --script bin/jdns-convert.ss [input] [output] +;;; If output is omitted, writes to stdout. +;;; If input is omitted, reads from stdin. + +(import (chezscheme)) + +;; ========== String Utilities ========== + +(define (string-trim s) + (let ([len (string-length s)]) + (let ([start (let loop ([i 0]) + (if (and (< i len) (char-whitespace? (string-ref s i))) + (loop (+ i 1)) i))] + [end (let loop ([i len]) + (if (and (> i 0) (char-whitespace? (string-ref s (- i 1)))) + (loop (- i 1)) i))]) + (if (>= start end) "" (substring s start end))))) + +(define (string-join strs sep) + (if (null? strs) "" + (let loop ([rest (cdr strs)] [acc (car strs)]) + (if (null? rest) acc + (loop (cdr rest) (string-append acc sep (car rest))))))) + +(define (numeric-string? s) + (and (> (string-length s) 0) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #t] + [(char-numeric? (string-ref s i)) (loop (+ i 1))] + [else #f])))) + +;; ========== Parsing tinydns data format ========== + +;; Decode octal escapes in tinydns data: \NNN → character +;; Printable ASCII is kept, non-printable shown as \xHH +(define (decode-tinydns-octal s) + (let loop ([i 0] [acc '()]) + (cond + [(>= i (string-length s)) + (list->string (reverse acc))] + [(and (char=? (string-ref s i) #\\) + (<= (+ i 3) (string-length s)) + (char<=? #\0 (string-ref s (+ i 1)) #\7)) + ;; Octal escape \NNN + (let ([code (+ (* (- (char->integer (string-ref s (+ i 1))) 48) 64) + (* (- (char->integer (string-ref s (+ i 2))) 48) 8) + (- (char->integer (string-ref s (+ i 3))) 48))]) + (cond + ;; Printable ASCII + [(and (>= code 32) (<= code 126)) + (loop (+ i 4) (cons (integer->char code) acc))] + ;; Non-printable: keep as hex escape in output + [else + (let ([hex (number->string code 16)]) + (loop (+ i 4) + (append (reverse (string->list + (string-append "\\x" + (if (< code 16) "0" "") + hex))) + acc)))]))] + [else + (loop (+ i 1) (cons (string-ref s i) acc))]))) + +;; Decode TXT rdata from generic `:` records (type 16). +;; The rdata starts with a length-prefix byte (\NNN) followed by text. +;; Multiple strings may be concatenated (each with its own length prefix). +;; We strip the length prefixes and return just the text. +(define (decode-tinydns-txt-rdata s) + ;; First pass: decode all octal escapes to a list of byte values + (let ([bytes (let loop ([i 0] [acc '()]) + (cond + [(>= i (string-length s)) + (reverse acc)] + [(and (char=? (string-ref s i) #\\) + (<= (+ i 3) (string-length s)) + (char<=? #\0 (string-ref s (+ i 1)) #\7)) + (let ([code (+ (* (- (char->integer (string-ref s (+ i 1))) 48) 64) + (* (- (char->integer (string-ref s (+ i 2))) 48) 8) + (- (char->integer (string-ref s (+ i 3))) 48))]) + (loop (+ i 4) (cons code acc)))] + [else + (loop (+ i 1) (cons (char->integer (string-ref s i)) acc))]))]) + ;; Second pass: walk TXT rdata — skip length prefix bytes, extract text + (if (null? bytes) + "" + (let ([first-byte (car bytes)] + [rest-bytes (cdr bytes)]) + ;; Check if first byte looks like a length prefix + ;; (its value should match or exceed remaining bytes) + (if (and (> first-byte 0) + (<= first-byte (length rest-bytes))) + ;; Strip length prefix, take that many chars as text + ;; Then check for more TXT strings + (let extract ([remaining bytes] [acc '()]) + (if (null? remaining) + (list->string (reverse acc)) + (let ([len (car remaining)] + [data (cdr remaining)]) + (if (and (> len 0) (<= len (length data))) + ;; Take `len` bytes as text + (let take ([n len] [d data] [a acc]) + (if (= n 0) + (extract d a) + (take (- n 1) (cdr d) + (cons (integer->char (car d)) a)))) + ;; Not a valid length prefix — treat rest as literal + (let literal ([d remaining] [a acc]) + (if (null? d) + (list->string (reverse a)) + (literal (cdr d) + (cons (integer->char (car d)) a)))))))) + ;; Doesn't look like length-prefixed — decode as literal + (list->string (map integer->char bytes))))))) + +;; Split string by colon, but only split into N fields max. +;; Extra colons stay in the last field. +(define (split-colon-n s n) + (let loop ([i 0] [start 0] [acc '()] [remaining (- n 1)]) + (cond + ;; End of string + [(= i (string-length s)) + (reverse (cons (substring s start i) acc))] + ;; No more splits allowed — rest goes into last field + [(= remaining 0) + (reverse (cons (substring s start (string-length s)) acc))] + ;; Colon delimiter + [(char=? (string-ref s i) #\:) + (loop (+ i 1) (+ i 1) + (cons (substring s start i) acc) + (- remaining 1))] + [else + (loop (+ i 1) start acc remaining)]))) + +;; Split string by all colons +(define (split-colon s) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (cons (substring s start i) acc))] + [(char=? (string-ref s i) #\:) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else + (loop (+ i 1) start acc)]))) + +;; Get field from split list, or default +(define (field parts idx default) + (if (and (> (length parts) idx) + (> (string-length (list-ref parts idx)) 0)) + (list-ref parts idx) + default)) + +;; For record types where the data field can contain colons, +;; extract TTL from the end if the last field is numeric. +;; Returns (values data-string ttl-string) +(define (extract-trailing-ttl parts start-idx) + (let* ([data-parts (list-tail parts start-idx)] + [last (list-ref data-parts (- (length data-parts) 1))]) + (if (and (> (length data-parts) 1) + (numeric-string? last)) + ;; Last field is TTL + (values (string-join (reverse (cdr (reverse data-parts))) ":") + last) + ;; No TTL, everything is data + (values (string-join data-parts ":") + "")))) + +;; Parse a single tinydns data line into a record alist +;; Returns: (domain type . fields-alist) or #f +(define (parse-tinydns-line line) + (let ([len (string-length line)]) + (cond + [(= len 0) #f] + [(char=? (string-ref line 0) #\#) #f] + [(char=? (string-ref line 0) #\-) #f] + [else + (let ([prefix (string-ref line 0)] + [rest (substring line 1 len)]) + (let ([parts (split-colon rest)]) + (case prefix + [(#\.) ;; SOA + NS + A: .fqdn:ip:ns:ttl + (let ([fqdn (field parts 0 "")] + [ip (field parts 1 "")] + [ns (field parts 2 "")] + [ttl (field parts 3 "")]) + `(,fqdn SOA+NS+A + (ip . ,ip) (ns . ,ns) (ttl . ,ttl)))] + + [(#\&) ;; NS + A: &fqdn:ip:ns:ttl + (let ([fqdn (field parts 0 "")] + [ip (field parts 1 "")] + [ns (field parts 2 "")] + [ttl (field parts 3 "")]) + `(,fqdn NS + (ip . ,ip) (ns . ,ns) (ttl . ,ttl)))] + + [(#\=) ;; A + PTR: =fqdn:ip:ttl + (let ([fqdn (field parts 0 "")] + [ip (field parts 1 "")] + [ttl (field parts 2 "")]) + `(,fqdn A+PTR + (ip . ,ip) (ttl . ,ttl)))] + + [(#\+) ;; A: +fqdn:ip:ttl + (let ([fqdn (field parts 0 "")] + [ip (field parts 1 "")] + [ttl (field parts 2 "")]) + `(,fqdn A + (ip . ,ip) (ttl . ,ttl)))] + + [(#\@) ;; MX + A: @fqdn:ip:mx:priority:ttl + ;; Handle @fqdn@fqdn:... doubled-domain format + (let* ([fqdn-raw (field parts 0 "")] + [at-pos (let scan ([j 0]) + (cond + [(= j (string-length fqdn-raw)) #f] + [(char=? (string-ref fqdn-raw j) #\@) j] + [else (scan (+ j 1))]))] + [fqdn (if at-pos + (substring fqdn-raw 0 at-pos) + fqdn-raw)] + [ip (field parts 1 "")] + [mx (field parts 2 "")] + [pri (field parts 3 "10")] + [ttl (field parts 4 "")]) + `(,fqdn MX + (ip . ,ip) (mx . ,mx) (priority . ,pri) (ttl . ,ttl)))] + + [(#\C) ;; CNAME: Cfqdn:target:ttl + (let ([fqdn (field parts 0 "")] + [target (field parts 1 "")] + [ttl (field parts 2 "")]) + `(,fqdn CNAME + (target . ,target) (ttl . ,ttl)))] + + [(#\^) ;; PTR: ^fqdn:target:ttl + (let ([fqdn (field parts 0 "")] + [target (field parts 1 "")] + [ttl (field parts 2 "")]) + `(,fqdn PTR + (target . ,target) (ttl . ,ttl)))] + + [(#\') ;; TXT: 'fqdn:text:ttl + ;; Text can contain colons, so TTL is last field IF numeric + (if (< (length parts) 2) + #f + (let ([fqdn (car parts)]) + (let-values ([(text ttl) (extract-trailing-ttl parts 1)]) + (let ([decoded (decode-tinydns-octal text)]) + `(,fqdn TXT + (text . ,decoded) (ttl . ,ttl))))))] + + [(#\3) ;; AAAA: 3fqdn:ip6:ttl + (let ([fqdn (field parts 0 "")] + [ip6 (field parts 1 "")] + [ttl (field parts 2 "")]) + `(,fqdn AAAA + (ip6 . ,ip6) (ttl . ,ttl)))] + + [(#\6) ;; AAAA + PTR: 6fqdn:ip6:ttl + (let ([fqdn (field parts 0 "")] + [ip6 (field parts 1 "")] + [ttl (field parts 2 "")]) + `(,fqdn AAAA+PTR + (ip6 . ,ip6) (ttl . ,ttl)))] + + [(#\:) ;; Generic: :fqdn:type:rdata:ttl + ;; rdata can contain colons (though usually escaped as \072) + (if (< (length parts) 3) + #f + (let ([fqdn (car parts)] + [rtype (cadr parts)]) + (let-values ([(rdata ttl) (extract-trailing-ttl parts 2)]) + ;; Type 16 = TXT: strip length prefix byte, emit as TXT + (if (string=? rtype "16") + (let ([decoded (decode-tinydns-txt-rdata rdata)]) + `(,fqdn TXT + (text . ,decoded) (ttl . ,ttl))) + `(,fqdn GENERIC + (rtype . ,rtype) + (rdata . ,(decode-tinydns-octal rdata)) + (ttl . ,ttl))))))] + + [(#\%) ;; Location: %loc:prefix + (let ([loc (field parts 0 "")] + [prefix (field parts 1 "")]) + `("" LOCATION + (location . ,loc) (prefix . ,prefix)))] + + [else #f])))]))) + +;; ========== 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)] + ;; Blank line + [(= (string-length (string-trim line)) 0) + (loop entries current-comment)] + ;; Comment line (starts with # after trimming) + [(char=? (string-ref (string-trim line) 0) #\#) + (let* ([trimmed (string-trim line)] + ;; Strip all leading # and whitespace + [comment-text (let strip ([i 0]) + (cond + [(>= i (string-length trimmed)) + ""] + [(or (char=? (string-ref trimmed i) #\#) + (char-whitespace? (string-ref trimmed i))) + (strip (+ i 1))] + [else + (substring trimmed i (string-length trimmed))]))]) + ;; Commented-out records (e.g., "# +foo:1.2.3.4") — skip + (if (and (> (string-length comment-text) 0) + (memv (string-ref comment-text 0) + '(#\. #\& #\= #\+ #\@ #\C #\^ #\' #\3 #\6 #\: #\%))) + (loop entries current-comment) + (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)))]))))) + +;; ========== Group records by domain ========== + +(define (group-by-domain entries) + ;; Returns: ((domain comment (records ...)) ...) + ;; Preserves order of first appearance + (let ([domains '()] + [domain-map '()]) + (for-each + (lambda (entry) + (let* ([comment (car entry)] + [domain (cadr entry)] + [existing (assoc domain domain-map)]) + (if existing + (set-cdr! existing + (cons (or (cadr existing) comment) + (append (cddr existing) (list (cdr entry))))) + (begin + (set! domains (append domains (list domain))) + (set! domain-map + (cons (cons domain (cons comment (list (cdr entry)))) + domain-map)))))) + entries) + (map (lambda (d) + (let ([entry (assoc d domain-map)]) + (list d (cadr entry) (cddr entry)))) + domains))) + +;; ========== Output: Human-readable zone format ========== + +(define (rtype-name rtype-num) + (let ([n (string->number rtype-num)]) + (case n + [(1) "A"] [(2) "NS"] [(5) "CNAME"] [(6) "SOA"] + [(12) "PTR"] [(15) "MX"] [(16) "TXT"] [(28) "AAAA"] + [(33) "SRV"] [(255) "ANY"] + [else (string-append "TYPE" rtype-num)]))) + +(define (format-ttl ttl) + (if (or (string=? ttl "") (string=? ttl "86400")) + "" + (string-append " ttl=" ttl))) + +(define (quote-txt text) + ;; Quote text, escaping embedded quotes + (let loop ([i 0] [acc '(#\")]) + (cond + [(= i (string-length text)) + (list->string (reverse (cons #\" acc)))] + [(char=? (string-ref text i) #\") + (loop (+ i 1) (cons #\" (cons #\\ acc)))] + [else + (loop (+ i 1) (cons (string-ref text i) acc))]))) + +(define (emit-record port rec) + (let ([type (cadr rec)] + [fields (cddr rec)]) + (let ([get (lambda (key) + (let ([p (assoc key fields)]) + (if p (cdr p) "")))]) + (case type + [(SOA+NS+A) + (display (string-append " SOA ns=" (get 'ns) + " ip=" (get 'ip) + (format-ttl (get 'ttl)) "\n") port)] + [(NS) + (display (string-append " NS " (get 'ns) + (if (string=? (get 'ip) "") "" + (string-append " ip=" (get 'ip))) + (format-ttl (get 'ttl)) "\n") port)] + [(A) + (display (string-append " A " (get 'ip) + (format-ttl (get 'ttl)) "\n") port)] + [(A+PTR) + (display (string-append " A " (get 'ip) " +ptr" + (format-ttl (get 'ttl)) "\n") port)] + [(MX) + (display (string-append " MX " (get 'mx) + " priority=" (get 'priority) + (if (string=? (get 'ip) "") "" + (string-append " ip=" (get 'ip))) + (format-ttl (get 'ttl)) "\n") port)] + [(CNAME) + (display (string-append " CNAME " (get 'target) + (format-ttl (get 'ttl)) "\n") port)] + [(PTR) + (display (string-append " PTR " (get 'target) + (format-ttl (get 'ttl)) "\n") port)] + [(TXT) + (display (string-append " TXT " (quote-txt (get 'text)) + (format-ttl (get 'ttl)) "\n") port)] + [(AAAA) + (display (string-append " AAAA " (get 'ip6) + (format-ttl (get 'ttl)) "\n") port)] + [(AAAA+PTR) + (display (string-append " AAAA " (get 'ip6) " +ptr" + (format-ttl (get 'ttl)) "\n") port)] + [(GENERIC) + (display (string-append " " (rtype-name (get 'rtype)) + " " (quote-txt (get 'rdata)) + (format-ttl (get 'ttl)) "\n") port)] + [(LOCATION) + (display (string-append " LOCATION " (get 'location) + " prefix=" (get 'prefix) "\n") port)])))) + +(define (emit-zone port groups) + (for-each + (lambda (group) + (let ([domain (car group)] + [comment (cadr group)] + [records (caddr group)]) + (when (and comment (> (string-length comment) 0)) + (display (string-append "# " comment "\n") port)) + (if (string=? domain "") + (display "global:\n" port) + (display (string-append domain ":\n") port)) + (for-each (lambda (r) (emit-record port r)) records) + (newline port))) + groups)) + +;; ========== Main ========== + +(let* ([args (command-line-arguments)] + [input-path (if (>= (length args) 1) (car args) #f)] + [output-path (if (>= (length args) 2) (cadr args) #f)]) + + (let* ([entries (parse-tinydns-file input-path)] + [groups (group-by-domain entries)]) + (if output-path + (call-with-output-file output-path + (lambda (port) (emit-zone port groups)) + 'replace) + (emit-zone (current-output-port) groups)))) new file mode 100644 --- /dev/null +++ b/bin/jdns-data.ss @@ -0,0 +1,3 @@ +#!chezscheme +(import (chezscheme) (jerboa-dns main)) +(apply run-jdns-data! (cdr (command-line))) new file mode 100644 --- /dev/null +++ b/bin/jdns.ss @@ -0,0 +1,3 @@ +#!chezscheme +(import (chezscheme) (jerboa-dns main)) +(apply run-jdns! (cdr (command-line))) new file mode 100644 --- /dev/null +++ b/build.ss @@ -0,0 +1,12 @@ +(import (chezscheme)) +(compile-imported-libraries #t) +(generate-wpo-files #t) +(import + (jerboa-dns protocol) + (jerboa-dns cdb) + (jerboa-dns response) + (jerboa-dns zone) + (jerboa-dns zone-compiler) + (jerboa-dns lookup) + (jerboa-dns server) + (jerboa-dns main)) new file mode 100644 --- /dev/null +++ b/lib/jerboa-dns/cdb.sls @@ -0,0 +1,290 @@ +#!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 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 (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/lookup.sls @@ -0,0 +1,290 @@ +#!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) + (jerboa-dns cdb) + (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)] + [result (make-bytevector rdata-len)]) + (bytevector-copy! val rdata-start result 0 rdata-len) + result)) + + ;; ========== Domain Hierarchy Walking ========== + + (define (domain-parent bv offset) + ;; Return the offset of the parent domain (skip first label). + ;; e.g., for www.example.com, returns offset pointing to example.com + (let ([llen (bytevector-u8-ref bv offset)]) + (if (= llen 0) #f ;; root has no parent + (+ offset 1 llen)))) + + ;; ========== Authority Detection ========== + + (define (find-authority cdb-reader qname) + ;; Walk up the domain hierarchy looking for SOA/NS records. + ;; Returns (values auth-offset has-soa? has-ns?) or (values #f #f #f) + (let loop ([off 0]) + (let ([llen (bytevector-u8-ref qname off)]) + (if (= llen 0) + ;; At root + (check-authority cdb-reader qname off) + ;; Check at this level + (let-values ([(auth-off has-soa? has-ns?) + (check-authority cdb-reader qname off)]) + (if has-ns? + (values auth-off has-soa? has-ns?) + ;; Try parent + (loop (+ off 1 llen)))))))) + + (define (check-authority cdb-reader qname offset) + ;; Check if domain at offset has SOA and/or NS records in CDB + (let* ([key (dns-domain-copy qname offset)] + [records (cdb-find-all cdb-reader key 0 (bytevector-length key))] + [has-soa? (any-record-type? records DNS-T-SOA)] + [has-ns? (any-record-type? records DNS-T-NS)]) + (if (or has-soa? has-ns?) + (values offset has-soa? has-ns?) + (values #f #f #f)))) + + (define (any-record-type? records rtype) + (exists (lambda (val) (= (cdb-val-type val) rtype)) records)) + + ;; ========== Additional Section (Glue Records) ========== + + (define (add-glue-records! rs cdb-reader domain-bv) + ;; Add A/AAAA records for a domain name (glue records for NS/MX) + (let* ([key domain-bv] + [records (cdb-find-all cdb-reader key 0 (bytevector-length key))]) + (for-each + (lambda (val) + (let ([rtype (cdb-val-type val)] + [ttl (cdb-val-ttl val)] + [rdata (cdb-val-rdata val)]) + (when (or (= rtype DNS-T-A) (= rtype DNS-T-AAAA)) + (response-rstart! rs domain-bv 0 rtype ttl) + (response-addbytes! rs rdata 0 (bytevector-length rdata)) + (response-rfinish! rs RESPONSE-ADDITIONAL)))) + records))) + + ;; ========== Record Response Building ========== + + (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)] + [records (cdb-find-all cdb-reader key 0 (bytevector-length key))] + [added? #f]) + + ;; Check for CNAME first + (let ([cname-recs (filter (lambda (v) (= (cdb-val-type v) DNS-T-CNAME)) records)]) + (when (and (pair? cname-recs) + (not (= qtype DNS-T-CNAME)) + (not (= qtype DNS-T-ANY))) + ;; Add CNAME, then follow it + (let* ([val (car cname-recs)] + [ttl (cdb-val-ttl val)] + [rdata (cdb-val-rdata val)]) + (response-rstart! rs qname 0 DNS-T-CNAME ttl) + (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) + ))) + + ;; Add matching records + (for-each + (lambda (val) + (let ([rtype (cdb-val-type val)] + [ttl (cdb-val-ttl val)] + [rdata (cdb-val-rdata val)]) + (when (and (or (= qtype DNS-T-ANY) (= qtype rtype)) + (not (= rtype DNS-T-SOA)) ;; SOA goes in authority + ) + (response-rstart! rs qname 0 rtype ttl) + (case rtype + [(2 5 12) ;; NS, CNAME, PTR — rdata is a domain name + (response-addname! rs rdata 0)] + [(15) ;; MX — preference + domain name + (response-addbytes! rs rdata 0 2) ;; preference + (response-addname! rs rdata 2)] ;; exchange + [(6) ;; SOA — mname + rname + 5×uint32 + (let* ([mname-len (dns-domain-length rdata 0)] + [rname-off mname-len] + [rname-len (dns-domain-length rdata rname-off)] + [nums-off (+ rname-off rname-len)]) + (response-addname! rs rdata 0) + (response-addname! rs rdata rname-off) + (response-addbytes! rs rdata nums-off 20))] + [else + ;; A, AAAA, TXT, etc. — raw bytes + (response-addbytes! rs rdata 0 (bytevector-length rdata))]) + (response-rfinish! rs RESPONSE-ANSWER) + (set! added? #t) + ;; Add glue for NS and MX + (when (or (= rtype DNS-T-NS) (= rtype DNS-T-MX)) + (let ([target (case rtype + [(2 12) rdata] ;; NS, PTR + [(15) (dns-domain-copy rdata 2)] ;; MX exchange + [else #f])]) + (when target + (add-glue-records! rs cdb-reader target))))))) + records) + + ;; If qtype is ANY or SOA, also add SOA records + (when (or (= qtype DNS-T-ANY) (= qtype DNS-T-SOA)) + (for-each + (lambda (val) + (when (= (cdb-val-type val) DNS-T-SOA) + (let ([ttl (cdb-val-ttl val)] + [rdata (cdb-val-rdata val)]) + (response-rstart! rs qname 0 DNS-T-SOA ttl) + (let* ([mname-len (dns-domain-length rdata 0)] + [rname-off mname-len] + [rname-len (dns-domain-length rdata rname-off)] + [nums-off (+ rname-off rname-len)]) + (response-addname! rs rdata 0) + (response-addname! rs rdata rname-off) + (response-addbytes! rs rdata nums-off 20)) + (response-rfinish! rs RESPONSE-ANSWER)