Refactor lib/jerboa-dns to idiomatic Jerboa where it helps
ober
fbea7661aa0b5bd61c69e038269efcfbd4c63ea5
--- a/lib/jerboa-dns/cdb.ss +++ b/lib/jerboa-dns/cdb.ss @@ -237,8 +237,7 @@ [header (make-bytevector 2048 0)]) ;; Write each of the 256 hash tables - (do ([i 0 (+ i 1)]) - ((= i 256)) + (for ([i (in-range 256)]) (let* ([entries (reverse (vector-ref tables i))] [count (length entries)] ;; Hash table size is 2× entry count (for open addressing) @@ -267,8 +266,7 @@ ;; Write slots (let ([buf (make-bytevector 8 0)]) - (do ([s 0 (+ s 1)]) - ((= s table-size)) + (for ([s (in-range table-size)]) (let ([entry (vector-ref slots s)]) (if entry (begin --- a/lib/jerboa-dns/log.ss +++ b/lib/jerboa-dns/log.ss @@ -58,14 +58,9 @@ ;; ── 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))]))) + (for/or ([c (in-string s)]) + (or (char=? c #\space) (char=? c #\=) (char=? c #\") + (char<? c #\space)))) (def (write-quoted! port s) (write-char #\" port) @@ -171,7 +166,7 @@ (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)) + (for ([i (in-range m)]) (let* ([b (bytevector-u8-ref bv i)] [hi (quotient b 16)] [lo (remainder b 16)]) --- a/lib/jerboa-dns/lookup.ss +++ b/lib/jerboa-dns/lookup.ss @@ -86,7 +86,7 @@ (values #f #f #f)))) (def (any-record-type? records rtype) - (exists (lambda (val) (= (cdb-val-type val) rtype)) records)) + (any (lambda (val) (= (cdb-val-type val) rtype)) records)) ;; ========== Additional Section (Glue Records) ========== @@ -105,6 +105,17 @@ (response-rfinish! rs RESPONSE-ADDITIONAL)))) records))) + ;; SOA rdata = mname + rname + 5×uint32; the two names are written + ;; uncompressed and the 20-byte numeric tail is copied verbatim. + (def (response-add-soa-rdata! rs rdata) + (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))) + ;; ========== Record Response Building ========== (def MAX-CNAME-DEPTH 8) @@ -112,7 +123,7 @@ (add-answer-records/depth! rs cdb-reader qname qtype 0 '())) (def (domain-in-list? name names) - (exists (lambda (candidate) + (any (lambda (candidate) (dns-domain-equal? name 0 candidate 0)) names)) @@ -162,13 +173,7 @@ (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))] + (response-add-soa-rdata! rs rdata)] [else ;; A, AAAA, TXT, etc. — raw bytes (response-addbytes! rs rdata 0 (bytevector-length rdata))]) @@ -192,13 +197,7 @@ (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-add-soa-rdata! rs rdata) (response-rfinish! rs RESPONSE-ANSWER) (set! added? #t)))) records)) @@ -240,13 +239,7 @@ (let ([ttl (cdb-val-ttl val)] [rdata (cdb-val-rdata val)]) (response-rstart! rs auth-name 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-add-soa-rdata! rs rdata) (response-rfinish! rs RESPONSE-AUTHORITY)))) records) --- a/lib/jerboa-dns/main.ss +++ b/lib/jerboa-dns/main.ss @@ -22,10 +22,7 @@ ;; ========== Server Entry Point ========== (def (truthy-env? s) - (and s - (let ([s (string-downcase s)]) - (not (or (string=? s "") (string=? s "0") - (string=? s "false") (string=? s "no")))))) + (and s (not (member (string-downcase s) '("" "0" "false" "no"))))) (def (run-jdns! args) ;; Configuration from environment variables (djbdns convention) @@ -45,43 +42,42 @@ (let process-args ([rest args] [ip ip] [port port] [root-dir root-dir] [uid uid] [gid gid] [data-file data-file]) - (cond - [(null? rest) - (let ([config (make-server-config ip port root-dir uid gid data-file)]) - (run-server! config))] - [(string=? (car rest) "--ip") - (process-args (cddr rest) (cadr rest) port root-dir uid gid data-file)] - [(string=? (car rest) "--port") - (process-args (cddr rest) ip (string->number (cadr rest)) - root-dir uid gid data-file)] - [(string=? (car rest) "--root") - (process-args (cddr rest) ip port (cadr rest) uid gid data-file)] - [(string=? (car rest) "--uid") - (process-args (cddr rest) ip port root-dir - (string->number (cadr rest)) gid data-file)] - [(string=? (car rest) "--gid") - (process-args (cddr rest) ip port root-dir - 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)] - [(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)])))) + (match rest + ('() + (run-server! (make-server-config ip port root-dir uid gid data-file))) + ((cons "--ip" (cons v more)) + (process-args more v port root-dir uid gid data-file)) + ((cons "--port" (cons v more)) + (process-args more ip (string->number v) root-dir uid gid data-file)) + ((cons "--root" (cons v more)) + (process-args more ip port v uid gid data-file)) + ((cons "--uid" (cons v more)) + (process-args more ip port root-dir (string->number v) gid data-file)) + ((cons "--gid" (cons v more)) + (process-args more ip port root-dir uid (string->number v) data-file)) + ((cons "--data" (cons v more)) + (process-args more ip port root-dir uid gid v)) + ((cons "--log-queries" more) + (set-log-queries! #t) + (process-args more ip port root-dir uid gid data-file)) + ((cons "--allow-sandbox-fallback" more) + (putenv "JDNS_ALLOW_SANDBOX_FALLBACK" "1") + (process-args more ip port root-dir uid gid data-file)) + ((cons opt _) + (display (format "jdns: unknown option ~a\n" opt) + (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 ========== (def (run-jdns-data! args) - (let ([input (if (and (pair? args)) (car args) "data")] - [output (if (and (pair? args) (pair? (cdr args))) (cadr args) "data.cdb")]) + (let-values ([(input output) + (match args + ((cons in (cons out _)) (values in out)) + ((cons in _) (values in "data.cdb")) + (_ (values "data" "data.cdb")))]) (display (format "Compiling ~a -> ~a\n" input output) (current-error-port)) (compile-zone-file! input output) --- a/lib/jerboa-dns/server.ss +++ b/lib/jerboa-dns/server.ss @@ -55,19 +55,10 @@ ;; ========== Platform Detection ========== - (def (string-contains-substr str sub) - (let ([slen (string-length str)] - [sublen (string-length sub)]) - (let lp ([i 0]) - (cond - [(> (+ i sublen) slen) #f] - [(string=? (substring str i (+ i sublen)) sub) #t] - [else (lp (+ i 1))])))) - (def *machine-type-str* (symbol->string (machine-type))) - (def *on-freebsd* (string-contains-substr *machine-type-str* "fb")) - (def *on-linux* (string-contains-substr *machine-type-str* "le")) - (def *on-macos* (string-contains-substr *machine-type-str* "osx")) + (def *on-freebsd* (and (string-contains *machine-type-str* "fb") #t)) + (def *on-linux* (and (string-contains *machine-type-str* "le") #t)) + (def *on-macos* (and (string-contains *machine-type-str* "osx") #t)) ;; ========== Server Configuration ========== --- a/lib/jerboa-dns/wasm-cdb.ss +++ b/lib/jerboa-dns/wasm-cdb.ss @@ -80,14 +80,11 @@ (def (resolve-wasm-path) (or (getenv "JDNS_CDB_WASM") - (let loop ([candidates - '("lib/jerboa-dns/sandbox/cdb_parser.wasm" - "sandbox/cdb_parser.wasm" - "/etc/jdns/cdb_parser.wasm")]) - (cond - [(null? candidates) "lib/jerboa-dns/sandbox/cdb_parser.wasm"] - [(file-exists? (car candidates)) (car candidates)] - [else (loop (cdr candidates))])))) + (find file-exists? + '("lib/jerboa-dns/sandbox/cdb_parser.wasm" + "sandbox/cdb_parser.wasm" + "/etc/jdns/cdb_parser.wasm")) + "lib/jerboa-dns/sandbox/cdb_parser.wasm")) (def %module #f) @@ -102,18 +99,19 @@ [%module #t] [(not (wasm-sandbox-available?)) #f] [else - (guard (e [#t (set! %module #f) #f]) + (try (let* ([path (resolve-wasm-path)] [bytes (and (file-exists? path) (load-wasm-bytes path))]) (if (not bytes) #f (let ([m (wasm-sandbox-load bytes)]) (set! %module m) - #t))))])) + #t))) + (catch (e) (set! %module #f) #f))])) (def (wasm-cdb-shutdown!) (when %module - (guard (e [#t (void)]) (wasm-sandbox-free-module %module)) + (try (wasm-sandbox-free-module %module) (catch (e) (void))) (set! %module #f))) (def (sandbox-available?) @@ -125,10 +123,7 @@ (def (require-sandbox?) (or *require-sandbox?* (let ([v (getenv "JDNS_REQUIRE_WASM_CDB")]) - (and v - (not (string=? v "")) - (not (string=? v "0")) - (not (string=? v "false")))))) + (and v (not (member v '("" "0" "false"))))))) (def (set-require-sandbox! flag) (set! *require-sandbox?* (and flag #t))) @@ -183,29 +178,32 @@ (load-bv-into-fresh-instance bv len)))) (def (load-bv-into-fresh-instance bv len) - (guard (e [#t #f]) + (try (let ([inst (wasm-sandbox-instantiate %module)]) - (guard (e [#t (wasm-sandbox-free inst) #f]) - (wasm-sandbox-add-fuel inst FUEL-PER-QUERY) - ;; Refuse oversized files before touching the sandbox memory. - (let ([cap (wasm-sandbox-call/i32 inst "cdb_capacity")]) - (cond - [(> len cap) - (wasm-sandbox-free inst) - #f] - [else - (let ([buf-ptr (wasm-sandbox-call/i32 inst "cdb_buffer_ptr")]) - ;; Write the full file directly into the CDB buffer. - ;; wasmi grows linear memory on demand to cover the - ;; range; the buffer was statically reserved in the - ;; module so the write address is fixed. - (wasm-sandbox-memory-write inst buf-ptr bv) - (let ([rc (wasm-sandbox-call inst "cdb_finalize" len)]) - (cond - [(and (integer? rc) (zero? rc)) inst] - [else - (wasm-sandbox-free inst) - #f])))])))))) + (try + (begin + (wasm-sandbox-add-fuel inst FUEL-PER-QUERY) + ;; Refuse oversized files before touching the sandbox memory. + (let ([cap (wasm-sandbox-call/i32 inst "cdb_capacity")]) + (cond + [(> len cap) + (wasm-sandbox-free inst) + #f] + [else + (let ([buf-ptr (wasm-sandbox-call/i32 inst "cdb_buffer_ptr")]) + ;; Write the full file directly into the CDB buffer. + ;; wasmi grows linear memory on demand to cover the + ;; range; the buffer was statically reserved in the + ;; module so the write address is fixed. + (wasm-sandbox-memory-write inst buf-ptr bv) + (let ([rc (wasm-sandbox-call inst "cdb_finalize" len)]) + (cond + [(and (integer? rc) (zero? rc)) inst] + [else + (wasm-sandbox-free inst) + #f])))]))) + (catch (e) (wasm-sandbox-free inst) #f))) + (catch (e) #f))) (def (get-file-size path) (let ([p (open-file-input-port path)]) @@ -238,13 +236,14 @@ [(sandboxed-cdb-reader-instance reader) => (lambda (inst) - (guard (e [#t - (when (require-sandbox?) - (raise e)) - (warn-fallback-once! "sandbox call raised") - (cdb-find-all (sandboxed-cdb-reader-cdb-fallback reader) - key-bv key-off key-len)]) - (sandboxed-cdb-find-all/wasm inst reader key-bv key-off key-len)))] + (try + (sandboxed-cdb-find-all/wasm inst reader key-bv key-off key-len) + (catch (e) + (when (require-sandbox?) + (raise e)) + (warn-fallback-once! "sandbox call raised") + (cdb-find-all (sandboxed-cdb-reader-cdb-fallback reader) + key-bv key-off key-len))))] [else (cdb-find-all (sandboxed-cdb-reader-cdb-fallback reader) key-bv key-off key-len)])) @@ -292,7 +291,7 @@ (unless (sandboxed-cdb-reader-closed reader) (let ([inst (sandboxed-cdb-reader-instance reader)]) (when inst - (guard (e [#t (void)]) (wasm-sandbox-free inst)) + (try (wasm-sandbox-free inst) (catch (e) (void))) (sandboxed-cdb-reader-instance-set! reader #f))) (sandboxed-cdb-reader-closed-set! reader #t))) --- a/lib/jerboa-dns/wasm-dns.ss +++ b/lib/jerboa-dns/wasm-dns.ss @@ -64,14 +64,11 @@ (def (resolve-wasm-path) (or (getenv "JDNS_PARSER_WASM") ;; Search the same places the Makefile populates. - (let loop ([candidates - '("lib/jerboa-dns/sandbox/dns_parser.wasm" - "sandbox/dns_parser.wasm" - "/etc/jdns/dns_parser.wasm")]) - (cond - [(null? candidates) "lib/jerboa-dns/sandbox/dns_parser.wasm"] - [(file-exists? (car candidates)) (car candidates)] - [else (loop (cdr candidates))])))) + (find file-exists? + '("lib/jerboa-dns/sandbox/dns_parser.wasm" + "sandbox/dns_parser.wasm" + "/etc/jdns/dns_parser.wasm")) + "lib/jerboa-dns/sandbox/dns_parser.wasm")) (def %module #f) (def %instance #f) @@ -86,10 +83,7 @@ [%instance #t] [(not (wasm-sandbox-available?)) #f] [else - (guard (e [#t - (set! %module #f) - (set! %instance #f) - #f]) + (try (let* ([path (resolve-wasm-path)] [bytes (and (file-exists? path) (load-wasm-bytes path))]) (if (not bytes) @@ -98,14 +92,18 @@ [i (wasm-sandbox-instantiate m)]) (set! %module m) (set! %instance i) - #t))))])) + #t))) + (catch (e) + (set! %module #f) + (set! %instance #f) + #f))])) (def (wasm-dns-shutdown!) (when %instance - (guard (e [#t (void)]) (wasm-sandbox-free %instance)) + (try (wasm-sandbox-free %instance) (catch (e) (void))) (set! %instance #f)) (when %module - (guard (e [#t (void)]) (wasm-sandbox-free-module %module)) + (try (wasm-sandbox-free-module %module) (catch (e) (void))) (set! %module #f))) (def (sandbox-available?) @@ -120,10 +118,7 @@ (def (require-sandbox?) (or *require-sandbox?* (let ([v (getenv "JDNS_REQUIRE_WASM_PARSER")]) - (and v - (not (string=? v "")) - (not (string=? v "0")) - (not (string=? v "false")))))) + (and v (not (member v '("" "0" "false"))))))) (def (set-require-sandbox! flag) (set! *require-sandbox?* (and flag #t))) @@ -142,7 +137,7 @@ ;; Returns (values id qname qtype qclass) or #f for a malformed stream. ;; The wasm side already validated the input; this is defense-in-depth ;; against a buggy/compromised module returning garbage. - (guard (e [#t #f]) + (try (let ([pos 0]) (def (read-byte) (when (>= pos n) @@ -193,7 +188,8 @@ (= (bytevector-u8-ref qname (- nlen 1)) 0) (= (dns-domain-length qname 0) nlen)) (error 'decode-output "bad qname framing")) - (values id qname qtype qclass)))))) + (values id qname qtype qclass)))) + (catch (e) #f))) ;; ---------- Error mapping ---------- @@ -213,11 +209,23 @@ ;; same semantics as parse-query returning #f. Distinct from runtime ;; errors (-1..-3) which we surface as exceptions. (def (parse-rejection? code) - (or (= code -4) (= code -5) (= code -6) - (= code -7) (= code -8))) + (and (memv code '(-4 -5 -6 -7 -8)) #t)) ;; ---------- Public entry ---------- + (def (parse-query-fallback pkt-bv pkt-len) + ;; In-process parse-query, absorbing exceptions as #f. parse-query can + ;; raise on a malformed packet (e.g. a self-referential compression + ;; pointer); the sandbox contract is "#f for any unanswerable query". + (try + (call-with-values + (lambda () (parse-query pkt-bv pkt-len)) + (case-lambda + [() #f] + [(v) v] + [(id qn t c) (values id qn t c)])) + (catch (e) #f))) + (def (parse-query-sandboxed pkt-bv pkt-len) ;; Mirror the wasm-side input cap on both paths so the fallback ;; doesn't quietly accept larger packets than the sandbox. @@ -233,17 +241,7 @@ "JDNS_REQUIRE_WASM_PARSER set but sandbox unavailable" reason)) (warn-fallback-once! reason) - ;; parse-query can raise on a malformed packet (e.g. a - ;; self-referential compression pointer trips an internal - ;; let-values arity mismatch). The sandbox contract is "#f - ;; for any unanswerable query", so absorb those exceptions. - (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)]))))] + (parse-query-fallback pkt-bv pkt-len))] [else (parse-query-sandboxed/wasm pkt-bv pkt-len)])) @@ -255,13 +253,7 @@ (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)]))))] + (parse-query-fallback pkt-bv pkt-len))] [(> 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.ss +++ b/lib/jerboa-dns/zone-compiler.ss @@ -17,24 +17,13 @@ iota 1+ 1- partition make-date make-time) - (except (jerboa prelude) meta atom? string-trim) + (except (jerboa prelude) meta atom?) (jerboa-dns protocol) (jerboa-dns cdb) (jerboa-dns zone)) ;; ========== Zone Line Parsing ========== - (def (split-fields str) - ;; Split colon-separated fields: "a:b:c" → ("a" "b" "c") - (let loop ([i 0] [start 0] [result '()]) - (cond - [(= i (string-length str)) - (reverse (cons (substring str start i) result))] - [(char=? (string-ref str i) #\:) - (loop (+ i 1) (+ i 1) (cons (substring str start i) result))] - [else - (loop (+ i 1) start result)]))) - (def (field-ref fields idx default) (if (< idx (length fields)) (let ([f (list-ref fields idx)]) @@ -251,7 +240,7 @@ ;; RFC 3596 reverse nibble form under ip6.arpa. (let loop ([i 15] [parts '()]) (if (< i 0) - (join-strings (append parts '("ip6" "arpa")) ".") + (string-join (append parts (list "ip6" "arpa")) ".") (let* ([b (bytevector-u8-ref ip6 i)] [hi (bitwise-and (bitwise-arithmetic-shift-right b 4) #x0f)] [lo (bitwise-and b #x0f)]) @@ -260,12 +249,6 @@ (list (string (hex-nibble lo)) (string (hex-nibble hi))))))))) - (def (join-strings lst sep) - (if (null? lst) "" - (let loop ([rest (cdr lst)] [acc (car lst)]) - (if (null? rest) acc - (loop (cdr rest) (string-append acc sep (car rest))))))) - (def (zone-last-pair lst) (if (null? (cdr lst)) lst (zone-last-pair (cdr lst)))) @@ -282,9 +265,9 @@ (let* ([parts (list-tail fields start-idx)] [last (and (pair? parts) (car (zone-last-pair parts)))] [ttl (and last (string->number last))] - [full (join-strings parts ":")] + [full (string-join parts ":")] [without-last (zone-drop-last parts)] - [without-last-str (join-strings without-last ":")]) + [without-last-str (string-join without-last ":")]) (cond [(null? parts) (values "" default-ttl)] [(and (> (length parts) 1) @@ -357,74 +340,69 @@ (error 'process-sexpr-record! "record must be a list" rec)) (let ([rtype (sexpr-type-name 'process-sexpr-record! (car rec))] [args (cdr rec)]) - (cond - [(string=? rtype "soa") + (match rtype + ("soa" (let-values ([(data ttl) (sexpr-split-ttl 'soa args TTL-NS)]) (sexpr-require-arity 'soa rec data 1 2) (add-soa-ns-record! writer fqdn (if (= (length data) 2) (sexpr-string 'soa (cadr data)) "") (sexpr-string 'soa (car data)) - ttl))] + ttl))) - [(string=? rtype "ns") + ("ns" (let-values ([(data ttl) (sexpr-split-ttl 'ns args TTL-NS)]) (sexpr-require-arity 'ns rec data 1 2) (add-ns-record! writer fqdn (if (= (length data) 2) (sexpr-string 'ns (cadr data)) "") (sexpr-string 'ns (car data)) - ttl))] + ttl))) - [(string=? rtype "a") + ("a" (let-values ([(data ttl) (sexpr-split-ttl 'a args TTL-POSITIVE)]) (sexpr-require-arity 'a rec data 1 1) - (add-a-record! writer fqdn (sexpr-string 'a (car data)) ttl))] + (add-a-record! writer fqdn (sexpr-string 'a (car data)) ttl))) - [(or (string=? rtype "a+ptr") (string=? rtype "aptr")) + ((or "a+ptr" "aptr") (let-values ([(data ttl) (sexpr-split-ttl 'a+ptr args TTL-POSITIVE)]) (sexpr-require-arity 'a+ptr rec data 1 1) - (add-a-ptr-record! writer fqdn (sexpr-string 'a+ptr (car data)) ttl))] - - [(string=? rtype "mx") - (begin - (sexpr-require-arity 'mx rec args 1 4) - (let ([mx-name (sexpr-string 'mx (car args))] - [priority 10] - [ip ""] - [ttl TTL-POSITIVE] - [rest (cdr args)]) - (case (length rest) - [(0) (void)] - [(1) - (if (sexpr-uint32-datum? (car rest)) - (set! priority (sexpr->uint16 'mx (car rest))) - (set! ip (sexpr-string 'mx (car rest))))] - [(2) - (if (sexpr-uint32-datum? (car rest)) - (begin - (set! priority (sexpr->uint16 'mx (car rest))) - (if (sexpr-uint32-datum? (cadr rest)) - (set! ttl (sexpr->uint32 'mx (cadr rest))) - (set! ip (sexpr-string 'mx (cadr rest))))) - (begin - (set! ip (sexpr-string 'mx (car rest))) - (set! ttl (sexpr->uint32 'mx (cadr rest)))))] - [else - (set! priority (sexpr->uint16 'mx (car rest))) - (set! ip (sexpr-string 'mx (cadr rest))) - (set! ttl (sexpr->uint32 'mx (caddr rest)))]) - (add-mx-record! writer fqdn ip mx-name priority ttl)))] - - [(string=? rtype "cname") + (add-a-ptr-record! writer fqdn (sexpr-string 'a+ptr (car data)) ttl))) + + ("mx" + (sexpr-require-arity 'mx rec args 1 4) + (let ([mx-name (sexpr-string 'mx (car args))]) + ;; After the exchange name, the optional priority / IP / TTL can + ;; appear in several orders; numbers are priority-then-TTL, a + ;; non-number is the glue IP. Disambiguate by shape. + (let-values + ([(priority ip ttl) + (match (cdr args) + ('() (values 10 "" TTL-POSITIVE)) + ((list (and (? sexpr-uint32-datum?) p)) + (values (sexpr->uint16 'mx p) "" TTL-POSITIVE)) + ((list x) + (values 10 (sexpr-string 'mx x) TTL-POSITIVE)) + ((list (and (? sexpr-uint32-datum?) p) (and (? sexpr-uint32-datum?) t)) + (values (sexpr->uint16 'mx p) "" (sexpr->uint32 'mx t))) + ((list (and (? sexpr-uint32-datum?) p) x) + (values (sexpr->uint16 'mx p) (sexpr-string 'mx x) TTL-POSITIVE)) + ((list x t) + (values 10 (sexpr-string 'mx x) (sexpr->uint32 'mx t))) + ((cons (and (? sexpr-uint32-datum?) p) (cons x (cons t _))) + (values (sexpr->uint16 'mx p) (sexpr-string 'mx x) (sexpr->uint32 'mx t))) + (_ (error 'mx "invalid record arity" rec)))]) + (add-mx-record! writer fqdn ip mx-name priority ttl)))) + + ("cname" (let-values ([(data ttl) (sexpr-split-ttl 'cname args TTL-POSITIVE)]) (sexpr-require-arity 'cname rec data 1 1) - (add-cname-record! writer fqdn (sexpr-string 'cname (car data)) ttl))] + (add-cname-record! writer fqdn (sexpr-string 'cname (car data)) ttl))) - [(string=? rtype "ptr") + ("ptr" (let-values ([(data ttl) (sexpr-split-ttl 'ptr args TTL-POSITIVE)]) (sexpr-require-arity 'ptr rec data 1 1) - (add-ptr-record! writer fqdn (sexpr-string 'ptr (car data)) ttl))] + (add-ptr-record! writer fqdn (sexpr-string 'ptr (car data)) ttl))) - [(string=? rtype "txt") + ("txt" (let-values ([(data ttl) (sexpr-split-ttl 'txt args TTL-POSITIVE)]) (sexpr-require-arity 'txt rec data 1 2) (if (= (length data) 1) @@ -432,20 +410,20 @@ (add-txt-record! writer (sexpr-relative-fqdn (car data) fqdn) (sexpr-string 'txt (cadr data)) - ttl)))] + ttl)))) - [(string=? rtype "aaaa") + ("aaaa" (let-values ([(data ttl) (sexpr-split-ttl 'aaaa args TTL-POSITIVE)]) (sexpr-require-arity 'aaaa rec data 1 1) - (add-aaaa-record! writer fqdn (sexpr-string 'aaaa (car data)) ttl))] + (add-aaaa-record! writer fqdn (sexpr-string 'aaaa (car data)) ttl))) - [(or (string=? rtype "aaaa+ptr") (string=? rtype "aaaaptr")) + ((or "aaaa+ptr" "aaaaptr") (let-values ([(data ttl) (sexpr-split-ttl 'aaaa+ptr args TTL-POSITIVE)]) (sexpr-require-arity 'aaaa+ptr rec data 1 1) - (add-aaaa-ptr-record! writer fqdn (sexpr-string 'aaaa+ptr (car data)) ttl))] + (add-aaaa-ptr-record! writer fqdn (sexpr-string 'aaaa+ptr (car data)) ttl))) - [else - (error 'process-sexpr-record! "unknown s-expression record type" rec)]))) + (_ + (error 'process-sexpr-record! "unknown s-expression record type" rec))))) (def (process-sexpr-domain! writer form) (unless (and (pair? form) (>= (length form) 2)) @@ -493,7 +471,7 @@ (not (char=? (string-ref line 0) #\#)) (not (char=? (string-ref line 0) #\-))) (let ([prefix (string-ref line 0)] - [fields (split-fields (substring line 1 (string-length line)))]) + [fields (string-split (substring line 1 (string-length line)) #\:)]) (case prefix ;; . = SOA + NS + A [(#\.) @@ -595,13 +573,10 @@ (let ([ch (skip-leading-space-and-comments! input-port)]) (if (and (not (eof-object? ch)) (char=? ch #\()) (process-sexpr-zone! writer (read input-port)) - (let loop () - (let ([line (get-line input-port)]) - (unless (eof-object? line) - (let ([trimmed (string-trim line)]) - (when (> (string-length trimmed) 0) - (process-zone-line! writer trimmed))) - (loop)))))) + (for ([line (in-lines input-port)]) + (let ([trimmed (string-trim line)]) + (unless (string-empty? trimmed) + (process-zone-line! writer trimmed)))))) (cdb-finish! writer) ;; Chez/POSIX rename atomically replaces an existing output file. (rename-file tmp-path output-path))) @@ -612,14 +587,4 @@ (lambda (port) (compile-zone-port! port output-path)))) - (def (string-trim str) - (let* ([len (string-length str)] - [start (let loop ([i 0]) - (if (and (< i len) (char-whitespace? (string-ref str i))) - (loop (+ i 1)) i))] - [end (let loop ([i len]) - (if (and (> i start) (char-whitespace? (string-ref str (- i 1)))) - (loop (- i 1)) i))]) - (substring str start end))) - ) ;; end library