distorted.lisp: Better processing of anycast addresses.

[zones] / distorted.lisp

diff --git a/distorted.lisp b/distorted.lisp
index a9a2b1f..b2118a4 100644 (file)
--- a/distorted.lisp
+++ b/distorted.lisp
@@ -3,6 +3,36 @@
 (load "hosts.lisp" :verbose nil)
 
 ;;;--------------------------------------------------------------------------
+;;; Anycast services.
+
+(defvar *anycast-routable-families* (list :ipv6))
+
+(defzoneparse :anycast (name data rec :prefix prefix :zname zname)
+  (destructuring-bind (any-provider default-provider &rest other-providers)
+      data
+
+    ;; First, the default address.  If the anycast network is preferred then
+    ;; this is easy; otherwise we have something complicated to do because
+    ;; IPv6 anycast addresses are globally routable, while IPv4 ones aren't.
+    (if (zone-preferred-subnet-p (car any-provider))
+       (zone-set-address #'rec (cdr any-provider) :make-ptr-p t)
+       (dolist (addr (host-addrs (host-parse (cdr any-provider))))
+         (let ((family (ipaddr-family addr)))
+           (if (member family *anycast-routable-families*)
+               (zone-set-address #'rec addr
+                                 :family family :make-ptr-p t)
+               (zone-set-address #'rec (cdr default-provider)
+                                 :family family :make-ptr-p nil)))))
+
+    ;; Now for all of the others.
+    (dolist (provider (list* any-provider default-provider other-providers))
+      (zone-set-address #'rec (cdr provider)
+                       :make-ptr-p (eq provider any-provider)
+                       :name (concatenate 'string prefix "."
+                                          (string-downcase (car provider))
+                                          "." (string-downcase zname))))))
+
+;;;--------------------------------------------------------------------------
 ;;; Other definitions.
 
 (setf *default-zone-admin* "hostmaster@distorted.org.uk")
@@ -38,44 +68,44 @@
          :v "DKIM1" :k "rsa" :h "sha256" :s "email"))
 
   ;; Anycast services.
-  (dns0 (any :a dns0.any)
-       (jump :svc precision.jump)
-       (dmz :svc radius.dmz)
-       (unsafe :svc radius.unsafe)
-       (colo :svc precision.colo))
-  (dns1 (any :a dns1.any)
-       (jump :svc telecaster.jump)
-       (dmz :svc vampire.dmz)
-       (unsafe :svc vampire.unsafe)
-       (colo :svc telecaster.colo))
+  (dns0 :anycast ((any dns0.any)
+                 (jump precision.jump)
+                 (colo precision.colo)
+                 (dmz radius.dmz)
+                 (unsafe radius.unsafe)))
+  (dns1 :anycast ((any dns1.any)
+                 (jump telecaster.jump)
+                 (dmz vampire.dmz)
+                 (unsafe vampire.unsafe)
+                 (colo telecaster.colo)))
   (dns :cname dns0)
 
-  (ntp0 (any :a ntp0.any)
-       (jump :svc fender.jump)
-       (dmz :svc ibanez.dmz)
-       (unsafe :svc ibanez.unsafe)
-       (colo :svc fender.colo))
-  (ntp1 (any :a ntp1.any)
-       (dmz :svc vampire.dmz)
-       (unsafe :svc vampire.unsafe))
+  (ntp0 :anycast ((any ntp0.any)
+                 (jump fender.jump)
+                 (dmz ibanez.dmz)
+                 (unsafe ibanez.unsafe)
+                 (colo  fender.colo)))
+  (ntp1 :anycast ((any ntp1.any)
+                 (dmz vampire.dmz)
+                 (unsafe vampire.unsafe)))
   (ntp :cname ntp0)
 
-  (www-cache (any :a www-cache.any)
-            (jump :svc telecaster.jump)
-            (dmz :svc roadstar.dmz)
-            (unsafe :svc roadstar.unsafe)
-            (colo :svc telecaster.colo))
+  (www-cache :anycast ((any www-cache.any)
+                      (jump telecaster.jump)
+                      (dmz roadstar.dmz)
+                      (unsafe roadstar.unsafe)
+                      (colo telecaster.colo)))
   (wpad :cname www-cache)
 
   (_kerberos :txt "DISTORTED.ORG.UK")
-  (krb0 (any :a krb0.any)
-       (jump :svc precision.jump)
-       (dmz :svc radius.dmz)
-       (unsafe :svc radius.unsafe)
-       (colo :svc precision.colo))
-  (krb1 (any :a krb1.any)
-       (dmz :svc vampire.dmz)
-       (unsafe :svc vampire.unsafe))
+  (krb0 :anycast ((any krb0.any)
+                 (jump precision.jump)
+                 (dmz radius.dmz)
+                 (unsafe radius.unsafe)
+                 (colo precision.colo)))
+  (krb1 :anycast ((any krb1.any)
+                 (dmz vampire.dmz)
+                 (unsafe vampire.unsafe)))
   (krb-master (unsafe :svc radius.unsafe)
              (dmz :svc radius.dmz))
   :srv (((:kerberos :protocol :udp)