X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/blobdiff_plain/5969df58acec66f58f74bfa68ef294c1dc8ba79c..HEAD:/zone.lisp diff --git a/zone.lisp b/zone.lisp index 5e41a5d..7649f54 100644 --- a/zone.lisp +++ b/zone.lisp @@ -68,31 +68,66 @@ (defun to-mixed-base (base val) (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)) + (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 + ((&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) + "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))) + + (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." @@ -265,7 +300,7 @@ (defvar *default-zone-source* "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*) @@ -273,19 +308,19 @@ (defvar *default-zone-admin* nil "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*) @@ -869,6 +904,11 @@ (defmethod zone-record-rrdata ((type (eql :cname)) zr) 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 @@ -903,6 +943,112 @@ (defmethod zone-record-rrdata ((type (eql :txt)) zr) (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-cidr-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") @@ -916,9 +1062,7 @@ (defzoneparse :dkim (name data rec) :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 @@ -933,6 +1077,11 @@ (defzoneparse :dkim (name data rec) (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)) @@ -1551,20 +1700,20 @@ (defmethod zone-write-header ((format (eql :bind)) zone) 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)