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.

diff --git a/zone.lisp b/zone.lisp
index b1e3050bb148d9a31cd3931095080f89fcdb76f7..914c6c5310294366f3799bb86aeb2f466352fe17 100644 (file)
--- a/zone.lisp
+++ b/zone.lisp
@@ -903,6 +903,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-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")