zone.lisp: Add support for CAA records (RFC 6844).

[zone] / zone.lisp

diff --git a/zone.lisp b/zone.lisp
index bd3cd3f..2267026 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -237,10 +237,6 @@
   min-ttl
   serial)
 
-(export 'zone-text-name)
-(defun zone-text-name (zone)
-  (princ-to-string (zone-name zone)))
-
 (export 'mx)
 (defstruct (mx (:predicate mxp))
   "Mail-exchange record information."
@@ -255,6 +251,10 @@
   name
   records)
 
+(export 'zone-text-name)
+(defun zone-text-name (zone)
+  (princ-to-string (zone-name zone)))
+
 ;;;--------------------------------------------------------------------------
 ;;; Zone defaults.  It is intended that scripts override these.
 
@@ -497,7 +497,7 @@
                                      :ttl ttl :records (cdr r))
                                     sub)))
                         (t
-                         (error "Unexpected record form ~A" (car r))))))))
+                         (error "Unexpected record form ~A" r)))))))
 
           (process (rec dom ttl)
             ;; Recursirvely process the record list REC, with a list DOM of
@@ -687,9 +687,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))
@@ -923,7 +923,7 @@
       (rec :type :txt
           :data (nreverse things)))))
 
-(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3))
+(defenum sshfp-algorithm () (:rsa 1) (:dsa 2) (:ecdsa 3) (:ed25519 4))
 (defenum sshfp-type () (:sha-1 1) (:sha-256 2))
 
 (export '*sshfp-pathname-defaults*)
@@ -1273,6 +1273,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))
@@ -1616,6 +1639,10 @@ $TTL ~2@*~D~2%"
     (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)