From: Mark Wooding <mdw@distorted.org.uk>
Date: Fri, 3 May 2024 00:24:07 +0000 (+0100)
Subject: zone.lisp: Add support for building SPF records.
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/zone/commitdiff_plain/9c799478caee5865a3c1029625ffe239b6b2a576

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 b1e3050..914c6c5 100644
--- 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")