X-Git-Url: https://git.distorted.org.uk/~mdw/zone/blobdiff_plain/d180e4a8771820af6aecfc5278a8b84ae2afbcac..HEAD:/zone.lisp

diff --git a/zone.lisp b/zone.lisp
index 6d6dce9..7649f54 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))
 
@@ -68,31 +68,66 @@
 	(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,28 +300,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 :hours)
+  "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 :minutes)
+  "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 :days)
+  "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.")
+(defvar *default-zone-min-ttl* '(4 :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 :hours)
+  "Default zone TTL (for records without explicit TTLs): four hours.")
 
 (export '*default-mx-priority*)
 (defvar *default-mx-priority* 50
@@ -552,7 +587,7 @@
        (retry *default-zone-retry*)
        (expire *default-zone-expire*)
        (min-ttl *default-zone-min-ttl*)
-       (ttl min-ttl)
+       (ttl *default-zone-ttl*)
        (serial (make-zone-serial raw-zname))
        &aux
        (zname (zone-parse-host raw-zname root-domain)))
@@ -687,9 +722,9 @@
 (defmacro defrevzone (head &body zf)
   "Define a reverse zone, with the correct name."
   (destructuring-bind (nets &rest args
-			    &key &allow-other-keys
-				 (family '*address-family*)
-				 prefix-bits)
+			    &key (family '*address-family*)
+				 prefix-bits
+				 &allow-other-keys)
       (listify head)
     (with-gensyms (ipn)
       `(dolist (,ipn (net-parse-to-ipnets ',nets ,family))
@@ -776,7 +811,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."
@@ -860,18 +895,160 @@
   ":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)
 
+(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
+	(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))
   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")
@@ -881,47 +1058,29 @@
 (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)
+	    (format out "~{~(~A~)=~A; ~}" plist)
+	    (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))))))))))
+
+(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))
@@ -946,26 +1105,23 @@
 			      (= (length words) 4))
 		   (error "Invalid SSHFP record."))
 		 (pop words)
-		 (destructuring-bind (alg type fpr) words
+		 (destructuring-bind (alg type fprhex) words
 		   (rec :data (list (parse-integer alg)
 				    (parse-integer type)
-				    fpr))))))))
+				    (decode-hex fprhex)))))))))
     (t
      (dolist (item (listify data))
-       (destructuring-bind (fpr &key (alg 'rsa) (type 'sha-1))
+       (destructuring-bind (fprhex &key (alg 'rsa) (type 'sha-1))
 	   (listify item)
 	 (rec :data (list (lookup-enum alg 'sshfp-algorithm :min 0 :max 255)
 			  (lookup-enum type 'sshfp-type :min 0 :max 255)
-			  fpr)))))))
+			  (decode-hex fprhex))))))))
 
 (defmethod zone-record-rrdata ((type (eql :sshfp)) zr)
   (destructuring-bind (alg type fpr) (zr-data zr)
     (rec-u8 alg)
     (rec-u8 type)
-    (do ((i 0 (+ i 2))
-	 (n (length fpr)))
-	((>= i n))
-      (rec-u8 (parse-integer fpr :start i :end (+ i 2) :radix 16))))
+    (rec-octet-vector fpr))
   44)
 
 (defenum tlsa-usage ()
@@ -1273,6 +1429,29 @@
     (rec-name host))
   33)
 
+(defenum caa-flag () (:critical 128))
+
+(defzoneparse :caa (name data rec)
+  ":caa ((TAG VALUE FLAG*)*)"
+  (dolist (prop data)
+    (destructuring-bind (tag value &rest flags) prop
+      (setf flags (reduce #'logior
+			  (mapcar (lambda (item)
+				    (lookup-enum 'caa-flag item
+						 :min 0 :max 255))
+				  flags)))
+      (ecase tag
+	((:issue :issuewild :iodef)
+	 (rec :name name
+	      :data (list flags tag value)))))))
+
+(defmethod zone-record-rrdata ((type (eql :caa)) zr)
+  (destructuring-bind (flags tag value) (zr-data zr)
+    (rec-u8 flags)
+    (rec-string (string-downcase tag))
+    (rec-raw-string value))
+  257)
+
 (defzoneparse :net (name data rec)
   ":net (NETWORK*)"
   (dolist (net (listify data))
@@ -1521,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)
@@ -1595,6 +1774,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))))
 
@@ -1609,13 +1791,19 @@ $TTL ~2@*~D~2%"
 			prio weight port (bind-hostname host))))
 
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :sshfp)) zr)
-  (bind-format-record zr "~{~2D ~2D ~A~}~%" (zr-data zr)))
+  (destructuring-bind (alg type fpr) (zr-data zr)
+    (bind-format-record zr "~2D ~2D " alg type)
+    (bind-write-hex fpr 12)))
 
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :tlsa)) zr)
   (destructuring-bind (usage selector match data) (zr-data zr)
     (bind-format-record zr "~2D ~2D ~2D " usage selector match)
     (bind-write-hex data 12)))
 
+(defmethod zone-write-record ((format (eql :bind)) (type (eql :caa)) zr)
+  (destructuring-bind (flags tag value) (zr-data zr)
+    (bind-format-record zr "~3D ~(~A~) ~S~%" flags tag value)))
+
 (defmethod zone-write-record ((format (eql :bind)) (type (eql :ds)) zr)
   (destructuring-bind (tag alg hashtype hash) (zr-data zr)
     (bind-format-record zr "~5D ~2D ~2D " tag alg hashtype)