net.lisp (ipmask-cidr-slash): Rename from `ipmask-cidl-slash'.

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index a1e74b7..7649f54 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -26,7 +26,7 @@
 
 (defpackage #:zone
   (:use #:common-lisp
 
 (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))
 
        #:net #:services)
   (:import-from #:net #:round-down #:round-up))
 


@@ -68,31 +68,66 @@
        (push r a)
        (setf val q)))))
 
        (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."
 
 (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*)
   "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*)
 
 (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*)
 
 (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*)
 
 (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*)
 
 (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
 
 (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*)
        (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)))
        (serial (make-zone-serial raw-zname))
        &aux
        (zname (zone-parse-host raw-zname root-domain)))


@@ -776,7 +811,7 @@
 
 (export 'rec-raw-string)
 (defun rec-raw-string (s &key (start 0) end)
 
 (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."
 
    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)))
 
   ":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)
 
 (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*)"
 (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)
 
 
 (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")
 (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)
 (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))
 
 (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)
                              (= (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)
                   (rec :data (list (parse-integer alg)
                                    (parse-integer type)

-                                   fpr))))))))
+                                   (decode-hex fprhex)))))))))

     (t
      (dolist (item (listify data))
     (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)
           (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)
 
 (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 ()
   44)
 
 (defenum tlsa-usage ()


@@ -1273,6 +1429,29 @@
     (rec-name host))
   33)
 
     (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))
 (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 (
                  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)
              (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)
 
 (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 :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))))
 
 (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)
                        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 :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)
 (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)