From e9a4984fee371f9e041c5e061db4b383e9130cfe Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 28 Apr 2024 12:13:18 +0100 Subject: [PATCH 01/16] frontend.lisp: Allow command-line overrides of timeout parameters. --- frontend.lisp | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 57 insertions(+), 2 deletions(-) diff --git a/frontend.lisp b/frontend.lisp index e170731..661b80a 100644 --- a/frontend.lisp +++ b/frontend.lisp @@ -22,7 +22,7 @@ ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (defpackage #:zone.frontend - (:use #:common-lisp #:mdw.sys-base #:optparse #:net #:zone + (:use #:common-lisp #:mdw.base #:mdw.sys-base #:optparse #:net #:zone #+(or cmu clisp) #:mop #+sbcl #:sb-mop) (:export #:main)) @@ -60,7 +60,46 @@ (if (and path (not (pathname-name path))) (setf var path) - (option-parse-error "path `~A' doesn't name a directory." arg))))) + (option-parse-error "path `~A' doesn't name a directory." arg)))) + (let ((duration-units (make-hash-table :test #'equal))) + (dolist (item '((("Gs") #.(* 1000 1000 1000)) + (("Ms") #.(* 1000 1000)) + (("ks") 1000) + (("hs") 100) + (("das") 10) + (("yr" "year" "years" "y") #.(* 365 24 60 60)) + (("wk" "week" "weeks" "w") #.(* 7 24 60 60)) + (("day" "days" "dy" "d") #.(* 24 60 60)) + (("hr" "hour" "hours" "h") #.(* 60 60)) + (("min" "minute" "minutes" "m") 60) + (("s" "second" "seconds" "sec" "") 1))) + (dolist (name (car item)) + (setf (gethash name duration-units) (cadr item)))) + (defopthandler dur (var arg) () + (let ((len (length arg))) + (multiple-value-bind (n i) (parse-integer arg :junk-allowed t) + (unless n + (option-parse-error "invalid duration `~A': ~ + integer expected" arg)) + (loop (cond ((or (>= i len) + (not (whitespace-char-p (char arg i)))) + (return)) + (t + (incf i)))) + (let ((u0 i)) + (loop (cond ((or (>= i len) + (whitespace-char-p (char arg i))) + (return)) + (t + (incf i)))) + (let* ((u1 i) + (unit (subseq arg u0 u1)) + (scale (gethash unit duration-units))) + (unless scale + (option-parse-error "invalid duration `~A': ~ + unknown unit `~A'" + arg unit)) + (setf var (* n scale))))))))) (define-program :version "1.0.0" :usage "ZONEDEF..." @@ -75,6 +114,22 @@ "Designate NET as a preferred subnet.") (#\D "debug" (set opt-debug) "Produce stack backtrace on error.") + "Timeout options" + (#\E "expire" (:arg "DURATION") + (dur *default-zone-expire*) + "Set default zone expiry period.") + (#\N "min-ttl" (:arg "DURATION") + (dur *default-zone-min-ttl*) + "Set default zone minimum/negative time-to-live.") + (#\R "refresh" (:arg "DURATION") + (dur *default-zone-refresh*) + "Set default zone refresh period.") + (#\T "ttl" (:arg "DURATION") + (dur *default-zone-ttl*) + "Set default zone time-to-live.") + (#\Y "retry" (:arg "DURATION") + (dur *default-zone-retry*) + "Set default zone retry period.") "Output options" (#\d "directory" (:arg "DIRECTORY") (dir *zone-output-path*) -- 2.11.0 From 76ffa76c1bafa87edf2de90b1432fe3f4cb1d651 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 30 Apr 2024 01:39:00 +0100 Subject: [PATCH 02/16] frontend.lisp: Return a non-nil result for `cl-launch''s benefit. --- frontend.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/frontend.lisp b/frontend.lisp index 661b80a..1c1a442 100644 --- a/frontend.lisp +++ b/frontend.lisp @@ -165,7 +165,8 @@ (progv *zone-config* (mapcar #'symbol-value *zone-config*) (load f :verbose nil :print nil :if-does-not-exist :error) (delete-package *package*)))) - (zone-save opt-zones :format opt-format))) + (zone-save opt-zones :format opt-format) + t)) (with-unix-error-reporting () (unless (option-parse-try (do-options () -- 2.11.0 From 3946fde66b356e98d274702d5d4e450d865451a0 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 30 Apr 2024 17:08:23 +0100 Subject: [PATCH 03/16] zone.lisp: Tighten up the default SOA parameters. Reduce all of the timeouts. The TTL is halved from eight to four hours, because I think I can cope. And the secondary synchronization parameters are reduced partly because everything uses `NOTIFY' these days, and partly because I'm using DNSSEC with short validity periods, and holding on to records for longer is just pointless. --- zone.lisp | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/zone.lisp b/zone.lisp index f7717ff..321c091 100644 --- a/zone.lisp +++ b/zone.lisp @@ -265,28 +265,28 @@ "The default zone source: the current host's name.") (export '*default-zone-refresh*) -(defvar *default-zone-refresh* (* 24 60 60) - "Default zone refresh interval: one day.") +(defvar *default-zone-refresh* (* 8 60 60) + "Default zone refresh interval: eight hours.") (export '*default-zone-admin*) (defvar *default-zone-admin* nil "Default zone administrator's email address.") (export '*default-zone-retry*) -(defvar *default-zone-retry* (* 60 60) - "Default znoe retry interval: one hour.") +(defvar *default-zone-retry* (* 20 60) + "Default zone retry interval: twenty minutes.") (export '*default-zone-expire*) -(defvar *default-zone-expire* (* 14 24 60 60) - "Default zone expiry time: two weeks.") +(defvar *default-zone-expire* (* 3 24 60 60) + "Default zone expiry time: three days.") (export '*default-zone-min-ttl*) (defvar *default-zone-min-ttl* (* 4 60 60) - "Default zone minimum TTL/negative TTL: four hours.") + "Default zone minimum/negative TTL: four hours.") (export '*default-zone-ttl*) -(defvar *default-zone-ttl* (* 8 60 60) - "Default zone TTL (for records without explicit TTLs): 8 hours.") +(defvar *default-zone-ttl* (* 4 60 60) + "Default zone TTL (for records without explicit TTLs): four hours.") (export '*default-mx-priority*) (defvar *default-mx-priority* 50 -- 2.11.0 From 498c01428a61df0f3d534f83d4b898b33bb25e53 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 30 Apr 2024 17:33:39 +0100 Subject: [PATCH 04/16] zone.lisp: Support `DNAME' records. --- zone.lisp | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/zone.lisp b/zone.lisp index 321c091..a80428f 100644 --- a/zone.lisp +++ b/zone.lisp @@ -860,6 +860,10 @@ ":cname HOST" (rec :data (zone-parse-host data zname))) +(defzoneparse :dname (name data rec :zname zname) + ":dname HOST" + (rec :data (zone-parse-host data zname))) + (defmethod zone-record-rrdata ((type (eql :cname)) zr) (rec-name (zr-data zr)) 5) @@ -1615,6 +1619,9 @@ $TTL ~2@*~D~2%" (defmethod zone-write-record ((format (eql :bind)) (type (eql :cname)) zr) (bind-format-record zr "~A~%" (bind-hostname (zr-data zr)))) +(defmethod zone-write-record ((format (eql :bind)) (type (eql :dname)) zr) + (bind-format-record zr "~A~%" (bind-hostname (zr-data zr)))) + (defmethod zone-write-record ((format (eql :bind)) (type (eql :ns)) zr) (bind-format-record zr "~A~%" (bind-hostname (zr-data zr)))) -- 2.11.0 From a679ee5921154ab32d8177fd17e8f76c1432d9e0 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 5 May 2024 00:52:04 +0100 Subject: [PATCH 05/16] zone.lisp (rec-raw-string): Fix garbled punctuation in commentary. --- zone.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/zone.lisp b/zone.lisp index a80428f..031a15d 100644 --- a/zone.lisp +++ b/zone.lisp @@ -776,7 +776,7 @@ (export 'rec-raw-string) (defun rec-raw-string (s &key (start 0) end) - "Append (a (substring of) a raw string S to the current record. + "Append (a substring of) a raw string S to the current record. No arrangement is made for reporting the length of the string. That must be done by the caller, if necessary." -- 2.11.0 From 63b00b21ca8bd03fa839195a760243e588ac94cc Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 3 May 2024 01:11:25 +0100 Subject: [PATCH 06/16] net.lisp: Print addresses and nets usefully when `*print-escape*' is off. --- net.lisp | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/net.lisp b/net.lisp index aa7e395..7996827 100644 --- a/net.lisp +++ b/net.lisp @@ -269,8 +269,10 @@ (:documentation "Transform the address IP into a numeric textual form.")) (defmethod print-object ((addr ipaddr) stream) - (print-unreadable-object (addr stream :type t) - (write-string (ipaddr-string addr) stream))) + (if *print-escape* + (print-unreadable-object (addr stream :type t) + (write-string (ipaddr-string addr) stream)) + (write-string (ipaddr-string addr) stream))) (export 'ipaddrp) (defun ipaddrp (ip) @@ -388,8 +390,10 @@ (ipaddr-string (make-instance (class-of net) :addr mask)))))) (defmethod print-object ((ipn ipnet) stream) - (print-unreadable-object (ipn stream :type t) - (write-string (ipnet-string ipn) stream))) + (if *print-escape* + (print-unreadable-object (ipn stream :type t) + (write-string (ipnet-string ipn) stream)) + (write-string (ipnet-string ipn) stream))) (defun parse-subnet (class width max str &key (start 0) (end nil) (slashp t)) "Parse a subnet description from (a substring of) STR. -- 2.11.0 From 48c0bf44ad8cdbaf60811f03e08d14caef1964be Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 3 May 2024 01:14:43 +0100 Subject: [PATCH 07/16] zone.lisp: Split a single `:txt' string into small enough pieces. The substrings of a `:txt' record can be at most 255 bytes long. If the argument is a single string that's too long then split it into pieces; prefer to split at semicolons, or spaces. If the argument is a list of strings, then respect their split. Theoretically, the split positions are semantically transparent, but it's possible that some programs are sensitive to the boundaries. --- zone.lisp | 31 +++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/zone.lisp b/zone.lisp index 031a15d..5589361 100644 --- a/zone.lisp +++ b/zone.lisp @@ -26,7 +26,7 @@ (defpackage #:zone (:use #:common-lisp - #:mdw.base #:mdw.str #:collect #:safely + #:mdw.base #:mdw.str #:anaphora #:collect #:safely #:net #:services) (:import-from #:net #:round-down #:round-up)) @@ -868,9 +868,36 @@ (rec-name (zr-data zr)) 5) +(defun split-txt-data (data) + (collecting () + (let ((i 0) (n (length data))) + (loop + (let ((end (+ i 255))) + (when (<= n end) (return)) + (let ((split (acond ((position #\; data :from-end t + :start i :end end) + (+ it 1)) + ((position #\space data :from-end t + :start i :end end) + (+ it 1)) + (t end)))) + (loop + (when (or (>= split end) + (char/= (char data split) #\space)) + (return)) + (incf split)) + (collect (subseq data i split)) + (setf i split)))) + (collect (subseq data i))))) + (defzoneparse :txt (name data rec) ":txt (TEXT*)" - (rec :data (listify data))) + (rec :data (cond ((stringp data) (split-txt-data data)) + (t + (dolist (piece data) + (unless (<= (length piece) 255) + (error "`:txt' record piece `~A' too long" piece))) + data)))) (defmethod zone-record-rrdata ((type (eql :txt)) zr) (mapc #'rec-string (zr-data zr)) -- 2.11.0 From 5969df58acec66f58f74bfa68ef294c1dc8ba79c Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 3 May 2024 01:23:16 +0100 Subject: [PATCH 08/16] zone.lisp (:dkim): Use new splitting machinery. --- zone.lisp | 61 ++++++++++++++++++++----------------------------------------- 1 file changed, 20 insertions(+), 41 deletions(-) diff --git a/zone.lisp b/zone.lisp index 5589361..5e41a5d 100644 --- a/zone.lisp +++ b/zone.lisp @@ -912,47 +912,26 @@ (defzoneparse :dkim (name data rec) ":dkim (KEYFILE {:TAG VALUE}*)" (destructuring-bind (file &rest plist) (listify data) - (let ((things nil) (out nil)) - (labels ((flush () - (when out - (push (get-output-stream-string out) things) - (setf out nil))) - (emit (text) - (let ((len (length text))) - (when (and out (> (+ (file-position out) - (length text)) - 64)) - (flush)) - (when (plusp len) - (cond ((< len 64) - (unless out - (setf out (make-string-output-stream))) - (write-string text out)) - (t - (do ((i 0 j) - (j 64 (+ j 64))) - ((>= i len)) - (push (subseq text i (min j len)) - things)))))))) - (do ((p plist (cddr p))) - ((endp p)) - (emit (format nil "~(~A~)=~A;" (car p) (cadr p)))) - (emit (with-output-to-string (out) - (write-string "p=" out) - (when file - (with-open-file - (in (merge-pathnames file *dkim-pathname-defaults*)) - (loop - (when (string= (read-line in) - "-----BEGIN PUBLIC KEY-----") - (return))) - (loop - (let ((line (read-line in))) - (if (string= line "-----END PUBLIC KEY-----") - (return) - (write-string line out))))))))) - (rec :type :txt - :data (nreverse things))))) + (rec :type :txt + :data + (split-txt-data + (with-output-to-string (out) + (do ((p plist (cddr p))) + ((endp p)) + (format out "~(~A~)=~A;" (car p) (cadr p))) + (write-string "p=" out) + (when file + (with-open-file + (in (merge-pathnames file *dkim-pathname-defaults*)) + (loop + (when (string= (read-line in) + "-----BEGIN PUBLIC KEY-----") + (return))) + (loop + (let ((line (read-line in))) + (when (string= line "-----END PUBLIC KEY-----") + (return)) + (write-string line out)))))))))) (defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3) (:ed25519 4)) (defenum sshfp-type () (:sha-1 1) (:sha-256 2)) -- 2.11.0 From b7dab7e34d90eae17ceff848ee03634c356a6c0d Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 5 May 2024 00:54:58 +0100 Subject: [PATCH 09/16] zone.lisp (:dkim): Replace a loop with `format' trickery. --- zone.lisp | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/zone.lisp b/zone.lisp index 5e41a5d..b1e3050 100644 --- a/zone.lisp +++ b/zone.lisp @@ -916,9 +916,7 @@ :data (split-txt-data (with-output-to-string (out) - (do ((p plist (cddr p))) - ((endp p)) - (format out "~(~A~)=~A;" (car p) (cadr p))) + (format out "~{~(~A~)=~A; ~}" plist) (write-string "p=" out) (when file (with-open-file -- 2.11.0 From 9c799478caee5865a3c1029625ffe239b6b2a576 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 3 May 2024 01:24:07 +0100 Subject: [PATCH 10/16] zone.lisp: Add support for building SPF records. This uses a fancy S-expression syntax rather than the raw text format, so that it can look things up in the hosts and networks databases. --- zone.lisp | 106 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) diff --git a/zone.lisp b/zone.lisp index b1e3050..914c6c5 100644 --- a/zone.lisp +++ b/zone.lisp @@ -903,6 +903,112 @@ (mapc #'rec-string (zr-data zr)) 16) +(defzoneparse :spf (name data rec :zname zname) + ":spf ([[ (:version STRING) | + ({:pass | :fail | :soft | :shrug} + {:all | + :include LABEL | + :a [[ :label LABEL | :v4mask MASK | :v6mask MASK ]] | + :ptr [LABEL] | + {:ip | :ip4 | :ip6} {STRING | NET | HOST}}) | + (:redirect LABEL) | + (:exp LABEL) ]])" + (rec :type :txt + :data + (split-txt-data + (with-output-to-string (out) + (let ((firstp t)) + (dolist (item data) + (if firstp (setf firstp nil) + (write-char #\space out)) + (let ((head (car item)) + (tail (cdr item))) + (ecase head + (:version (destructuring-bind (ver) tail + (format out "v=~A" ver))) + ((:pass :fail :soft :shrug) + (let ((qual (ecase head + (:pass #\+) + (:fail #\-) + (:soft #\~) + (:shrug #\?)))) + (setf head (pop tail)) + (ecase head + (:all + (destructuring-bind () tail + (format out "~Aall" qual))) + ((:include :exists) + (destructuring-bind (label) tail + (format out "~A~(~A~):~A" + qual head + (if (stringp label) label + (zone-parse-host label zname))))) + ((:a :mx) + (destructuring-bind (&key label v4mask v6mask) tail + (format out "~A~(~A~)~@[:~A~]~@[/~D~]~@[//~D~]" + qual head + (cond ((null label) nil) + ((stringp label) label) + (t (zone-parse-host label zname))) + v4mask + v6mask))) + (:ptr + (destructuring-bind (&optional label) tail + (format out "~Aptr~@[:~A~]" + qual + (cond ((null label) nil) + ((stringp label) label) + (t (zone-parse-host label zname)))))) + ((:ip :ip4 :ip6) + (let* ((family (ecase head + (:ip t) + (:ip4 :ipv4) + (:ip6 :ipv6))) + (nets + (collecting () + (dolist (net tail) + (acond + ((host-find net) + (let ((any nil)) + (dolist (addr (host-addrs it)) + (when (or (eq family t) + (eq family + (ipaddr-family addr))) + (setf any t) + (collect (make-ipnet + addr + (ipaddr-width addr))))) + (unless any + (error + "No matching addresses for `~A'" + net)))) + (t + (collect-append + (net-parse-to-ipnets net family)))))))) + (setf firstp t) + (dolist (net nets) + (if firstp (setf firstp nil) + (write-char #\space out)) + (let* ((width (ipnet-width net)) + (mask (ipnet-mask net)) + (plen (ipmask-cidl-slash width mask))) + (unless plen + (error "invalid netmask in network ~A" net)) + (format out "~A~A:~A~@[/~D~]" + qual + (ecase (ipnet-family net) + (:ipv4 "ip4") + (:ipv6 "ip6")) + (ipnet-net net) + (and (/= plen width) plen))))))))) + ((:redirect :exp) + (destructuring-bind (label) tail + (format out "~(~A~)=~A" + head + (if (stringp label) label + (zone-parse-host label zname))))))))))))) + + (export '*dkim-pathname-defaults*) (defvar *dkim-pathname-defaults* (make-pathname :directory '(:relative "keys") -- 2.11.0 From 382d444fbf6310ffd1a040fde9c281a08f84eb3d Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 5 May 2024 00:55:21 +0100 Subject: [PATCH 11/16] zone.lisp: Add a parser for DMARC policy records. --- zone.lisp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/zone.lisp b/zone.lisp index 914c6c5..f68af5d 100644 --- a/zone.lisp +++ b/zone.lisp @@ -1037,6 +1037,11 @@ (return)) (write-string line out)))))))))) +(defzoneparse :dmarc (name data rec) + ":dmarc ({:TAG VALUE}*)" + (rec :type :txt + :data (split-txt-data (format nil "~{~(~A~)=~A~^; ~}" data)))) + (defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3) (:ed25519 4)) (defenum sshfp-type () (:sha-1 1) (:sha-256 2)) -- 2.11.0 From b5746aa40ba5c7a756538ec06a884df8d3a4b531 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 5 May 2024 02:43:30 +0100 Subject: [PATCH 12/16] zone.lisp (split-txt-data): Add documentation. --- zone.lisp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/zone.lisp b/zone.lisp index f68af5d..f50c6d7 100644 --- a/zone.lisp +++ b/zone.lisp @@ -869,6 +869,11 @@ 5) (defun split-txt-data (data) + "Split the string DATA into pieces small enough to fit in a TXT record. + + Return a list of strings L such that (a) (apply #'concatenate 'string L) + is equal to the original string DATA, and (b) (every (lambda (s) (<= + (length s) 255)) L) is true." (collecting () (let ((i 0) (n (length data))) (loop -- 2.11.0 From bb94753b6d10c0d54cba7f6ae387f63d1b0546ff Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 5 May 2024 02:48:34 +0100 Subject: [PATCH 13/16] zone.lisp (timespec-seconds): Rewrite using a table of units. --- zone.lisp | 61 ++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 36 insertions(+), 25 deletions(-) diff --git a/zone.lisp b/zone.lisp index f50c6d7..d5d2072 100644 --- a/zone.lisp +++ b/zone.lisp @@ -68,31 +68,42 @@ (push r a) (setf val q))))) -(export 'timespec-seconds) -(defun timespec-seconds (ts) - "Convert a timespec TS to seconds. - - A timespec may be a real count of seconds, or a list (COUNT UNIT). UNIT - may be any of a number of obvious time units." - (cond ((null ts) 0) - ((realp ts) (floor ts)) - ((atom ts) - (error "Unknown timespec format ~A" ts)) - ((null (cdr ts)) - (timespec-seconds (car ts))) - (t (+ (to-integer (* (car ts) - (case (intern (string-upcase - (stringify (cadr ts))) - '#:zone) - ((s sec secs second seconds) 1) - ((m min mins minute minutes) 60) - ((h hr hrs hour hours) #.(* 60 60)) - ((d dy dys day days) #.(* 24 60 60)) - ((w wk wks week weeks) #.(* 7 24 60 60)) - ((y yr yrs year years) #.(* 365 24 60 60)) - (t (error "Unknown time unit ~A" - (cadr ts)))))) - (timespec-seconds (cddr ts)))))) +(let ((unit-scale (make-hash-table))) + + (dolist (item `(((:second :seconds :sec :secs :s) ,1) + ((:minute :minutes :min :mins :m) ,60) + ((:hour :hours :hr :hrs :h) ,(* 60 60)) + ((:day :days :dy :dys :d) ,(* 24 60 60)) + ((:week :weeks :wk :wks :w) ,(* 7 24 60 60)))) + (destructuring-bind (units scale) item + (dolist (unit units) (setf (gethash unit unit-scale) scale)))) + + (export 'timespec-seconds) + (defun timespec-seconds (ts) + "Convert a timespec TS to seconds. + + A timespec may be a real count of seconds, or a list ({COUNT UNIT}*). + UNIT may be any of a number of obvious time units." + (labels ((convert (acc ts) + (cond ((null ts) acc) + ((realp ts) (+ acc (floor ts))) + ((atom ts) (error "Unknown timespec format ~A" ts)) + (t + (destructuring-bind + (count &optional unit &rest tail) ts + (let ((scale + (acond ((null unit) 1) + ((gethash (intern (string-upcase + (stringify unit)) + :keyword) + unit-scale) + it) + (t + (error "Unknown time unit ~S" + unit))))) + (convert (+ acc (to-integer (* count scale))) + tail))))))) + (convert 0 ts)))) (defun hash-table-keys (ht) "Return a list of the keys in hashtable HT." -- 2.11.0 From f0b4f74bf2d46dd5a10abc1bf024c2a77dfd3928 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 5 May 2024 02:49:12 +0100 Subject: [PATCH 14/16] zone.lisp: Initialize the default timeouts with timespec forms. Mostly to show that it can be done. --- zone.lisp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/zone.lisp b/zone.lisp index d5d2072..3456b45 100644 --- a/zone.lisp +++ b/zone.lisp @@ -276,7 +276,7 @@ "The default zone source: the current host's name.") (export '*default-zone-refresh*) -(defvar *default-zone-refresh* (* 8 60 60) +(defvar *default-zone-refresh* '(8 :hours) "Default zone refresh interval: eight hours.") (export '*default-zone-admin*) @@ -284,19 +284,19 @@ "Default zone administrator's email address.") (export '*default-zone-retry*) -(defvar *default-zone-retry* (* 20 60) +(defvar *default-zone-retry* '(20 :minutes) "Default zone retry interval: twenty minutes.") (export '*default-zone-expire*) -(defvar *default-zone-expire* (* 3 24 60 60) +(defvar *default-zone-expire* '(3 :days) "Default zone expiry time: three days.") (export '*default-zone-min-ttl*) -(defvar *default-zone-min-ttl* (* 4 60 60) +(defvar *default-zone-min-ttl* '(4 :hours) "Default zone minimum/negative TTL: four hours.") (export '*default-zone-ttl*) -(defvar *default-zone-ttl* (* 4 60 60) +(defvar *default-zone-ttl* '(4 :hours) "Default zone TTL (for records without explicit TTLs): four hours.") (export '*default-mx-priority*) -- 2.11.0 From 3cccef13dd0ed83b823cfafeb95856636e7be319 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 5 May 2024 02:50:03 +0100 Subject: [PATCH 15/16] zone.lisp: Add seconds-to-timespec conversion and use it when dumping SOA. --- zone.lisp | 52 ++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 38 insertions(+), 14 deletions(-) diff --git a/zone.lisp b/zone.lisp index 3456b45..0979120 100644 --- a/zone.lisp +++ b/zone.lisp @@ -68,15 +68,20 @@ (push r a) (setf val q))))) -(let ((unit-scale (make-hash-table))) +(let ((unit-scale (make-hash-table)) + (scales nil)) (dolist (item `(((:second :seconds :sec :secs :s) ,1) ((:minute :minutes :min :mins :m) ,60) ((:hour :hours :hr :hrs :h) ,(* 60 60)) ((:day :days :dy :dys :d) ,(* 24 60 60)) ((:week :weeks :wk :wks :w) ,(* 7 24 60 60)))) - (destructuring-bind (units scale) item - (dolist (unit units) (setf (gethash unit unit-scale) scale)))) + (destructuring-bind + ((&whole units singular plural &rest hunoz) scale) item + (declare (ignore hunoz)) + (dolist (unit units) (setf (gethash unit unit-scale) scale)) + (push (cons scale (cons singular plural)) scales))) + (setf scales (sort scales #'> :key #'car)) (export 'timespec-seconds) (defun timespec-seconds (ts) @@ -103,7 +108,26 @@ unit))))) (convert (+ acc (to-integer (* count scale))) tail))))))) - (convert 0 ts)))) + (convert 0 ts))) + + (export 'seconds-timespec) + (defun seconds-timespec (secs) + "Convert a count of seconds to a time specification." + (let ((sign (if (minusp secs) -1 +1)) (secs (abs secs))) + (collecting () + (loop (cond ((zerop secs) + (unless (collected) (collect-append '(0 :seconds))) + (return)) + ((< secs 60) + (collect (* secs sign)) + (collect (if (= secs 1) :second :seconds)) + (return)) + (t + (let ((match (find secs scales :test #'>= :key #'car))) + (multiple-value-bind (quot rem) (floor secs (car match)) + (collect (* quot sign)) + (collect (if (= quot 1) (cadr match) (cddr match))) + (setf secs rem)))))))))) (defun hash-table-keys (ht) "Return a list of the keys in hashtable HT." @@ -1676,20 +1700,20 @@ $TTL ~2@*~D~2%" copy))) (format *zone-output-stream* "~ ~A~30TIN SOA~40T~A ( -~55@A~60T ;administrator -~45T~10D~60T ;serial -~45T~10D~60T ;refresh -~45T~10D~60T ;retry -~45T~10D~60T ;expire -~45T~10D )~60T ;min-ttl~2%" +~55@A~58T; administrator +~45T~10D~58T; serial +~45T~10D~58T; refresh: ~{~D ~(~A~)~^ ~} +~45T~10D~58T; retry: ~{~D ~(~A~)~^ ~} +~45T~10D~58T; expire: ~{~D ~(~A~)~^ ~} +~45T~10D )~58T; min-ttl: ~{~D ~(~A~)~^ ~}~2%" (bind-output-hostname (zone-name zone)) (bind-hostname (soa-source soa)) admin (soa-serial soa) - (soa-refresh soa) - (soa-retry soa) - (soa-expire soa) - (soa-min-ttl soa)))) + (soa-refresh soa) (seconds-timespec (soa-refresh soa)) + (soa-retry soa) (seconds-timespec (soa-retry soa)) + (soa-expire soa) (seconds-timespec (soa-expire soa)) + (soa-min-ttl soa) (seconds-timespec (soa-min-ttl soa))))) (export 'bind-format-record) (defun bind-format-record (zr format &rest args) -- 2.11.0 From 88dc0b1c096ab8f8103ecd69de780b96e1de277d Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Wed, 8 May 2024 13:51:49 +0100 Subject: [PATCH 16/16] net.lisp (ipmask-cidr-slash): Rename from `ipmask-cidl-slash'. I can only plead incompetence. --- net.lisp | 8 ++++---- zone.lisp | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/net.lisp b/net.lisp index 7996827..13f390c 100644 --- a/net.lisp +++ b/net.lisp @@ -301,8 +301,8 @@ "Given an integer I, return an N-bit netmask with its I top bits set." (- (ash 1 n) (ash 1 (- n i)))) -(export 'ipmask-cidl-slash) -(defun ipmask-cidl-slash (width mask) +(export 'ipmask-cidr-slash) +(defun ipmask-cidr-slash (width mask) "Given a netmask MASK, try to compute a prefix length. Return an integer N such that (integer-netmask WIDTH N) = MASK, or nil if @@ -386,7 +386,7 @@ (with-ipnet (net nil mask) ipn (format nil "~A/~A" (ipaddr-string net) - (or (ipmask-cidl-slash (ipnet-width ipn) mask) + (or (ipmask-cidr-slash (ipnet-width ipn) mask) (ipaddr-string (make-instance (class-of net) :addr mask)))))) (defmethod print-object ((ipn ipnet) stream) @@ -484,7 +484,7 @@ (let* ((addr-class (extract-class-name (ipnet-net ipn))) (width (ipaddr-width addr-class)) (max (- width - (or (ipmask-cidl-slash width (ipnet-mask ipn)) + (or (ipmask-cidr-slash width (ipnet-mask ipn)) (error "Base network has complex netmask"))))) (multiple-value-bind (addr mask) (parse-subnet addr-class width max (stringify str) diff --git a/zone.lisp b/zone.lisp index 0979120..7649f54 100644 --- a/zone.lisp +++ b/zone.lisp @@ -1031,7 +1031,7 @@ (write-char #\space out)) (let* ((width (ipnet-width net)) (mask (ipnet-mask net)) - (plen (ipmask-cidl-slash width mask))) + (plen (ipmask-cidr-slash width mask))) (unless plen (error "invalid netmask in network ~A" net)) (format out "~A~A:~A~@[/~D~]" -- 2.11.0