From 799c35d89f0900c139ce538422845ec553fa4bd5 Mon Sep 17 00:00:00 2001
From: Niten <niten@fudo.org>
Date: Fri, 13 Nov 2020 09:42:17 -0800
Subject: [PATCH] Added support for IPv6

---
 backplane-dns.lisp | 92 ++++++++++++++++++++++++++++++++--------------
 1 file changed, 64 insertions(+), 28 deletions(-)

diff --git a/backplane-dns.lisp b/backplane-dns.lisp
index 76d5a3c..8949681 100644
--- a/backplane-dns.lisp
+++ b/backplane-dns.lisp
@@ -56,6 +56,16 @@
    (domain     :initarg :domain)
    (ip-address :initarg :ip-address)))
 
+(defclass change-request-ipv6 (request)
+  ((hostname   :initarg :hostname)
+   (domain     :initarg :domain)
+   (ip-address :initarg :ip-address)))
+
+(defclass change-request-sshfp (request)
+  ((hostname   :initarg :hostname)
+   (domain     :initarg :domain)
+   (sshfp      :initarg :sshfp)))
+
 (defclass unknown-request (request)
   ((text :initarg :text
          :reader  text)))
@@ -81,28 +91,38 @@
 (define-condition domain-name-missing (error)
   ((missing-domain :initarg :domain :reader missing-domain)))
 
-(defun host-a-record (hostname domain)
+(defun find-host-records-by-type (host domain type)
   (if-let ((domain-id (some-> domain
                               (get-domain)
                               (id))))
-          (car (select-dao 'dns-record
-                           (:= 'name (format nil "~A.~A" hostname domain))
-                           (:= 'domain-id domain-id)
-                           (:= 'type "A")))
-          (error 'domain-name-missing :domain domain)))
+    (select-dao 'dns-record
+        (:= 'name      (format nil "~A.~A" host domain))
+        (:= 'domain-id domain-id)
+        (:= 'type      type))
+    (error 'domain-name-missing :domain domain)))
+
+(defun consider-update-content (record content)
+  (if (equalp (record-content record) content)
+      t
+      (progn (setf (record-content record) content)
+             (update-dao record))))
+
+(defun update-host-record-by-type (host domain type content)
+  (let ((record (car (find-host-records-by-type host domain type))))
+    (if record
+        (consider-update-content record content)
+        (if-let ((domain-id (some-> domain (get-domain) (id))))
+          (insert-dao (make-instance 'dns-record
+                                     :domain-id domain-id
+                                     :name      (format nil "~A.~A" host domain)
+                                     :type      type
+                                     :content   content))))))
 
 (defun set-host-v4ip (host domain v4ip)
-  (let* ((full-hostname (format nil "~A.~A" host domain))
-         (a-record (host-a-record host domain)))
-    (if a-record
-        (progn (setf (record-content a-record) v4ip)
-               (update-dao a-record))
-        (if-let ((domain-id (some-> domain (get-domain) (id))))
-                (insert-dao (make-instance 'dns-record
-                                           :domain-id domain-id
-                                           :name      full-hostname
-                                           :type      "A"
-                                           :content   v4ip))))))
+  (update-host-record-by-type host domain "A" v4ip))
+
+(defun set-host-v6ip (host domain v6ip)
+  (update-host-record-by-type host domain "AAAA" v6ip))
 
 (defun split-string (string &optional (char #\Space))
   (split-sequence:split-sequence char string))
@@ -136,16 +156,23 @@
   (let ((from (xmpp:from message)))
     (trivia:match (split-string (xmpp:body message))
 
-                  ((list "REQUEST-CHANGE-IPV4" domain ip)
-                   (make-instance 'change-request-ipv4
-                                  :sender     from
-                                  :hostname   (sender-hostname from)
-                                  :domain     domain
-                                  :ip-address ip))
+      ((list "REQUEST-CHANGE-IPV4" domain ip)
+       (make-instance 'change-request-ipv4
+                      :sender     from
+                      :hostname   (sender-hostname from)
+                      :domain     domain
+                      :ip-address ip))
 
-                  (_ (make-instance 'unknown-request
-                                    :sender from
-                                    :text   (xmpp:body message))))))
+      ((list "REQUEST-CHANGE-IPV6" domain ip)
+       (make-instance 'change-request-ipv6
+                      :sender     from
+                      :hostname   (sender-hostname from)
+                      :domain     domain
+                      :ip-address ip))
+
+      (_ (make-instance 'unknown-request
+                        :sender from
+                        :text   (xmpp:body message))))))
 
 (defgeneric handle-message (message))
 
@@ -159,6 +186,16 @@
         (make-error (format nil "unknown error setting host v4ip: ~A"
                             text))))))
 
+(defmethod handle-message ((message change-request-ipv6))
+  (with-slots (hostname domain ip-address) message
+    (handler-case
+        (progn (set-host-v6ip hostname domain ip-address)
+               (make-success (format nil "ipv6 for host ~a in domain ~a set to ~a"
+                                     hostname domain ip-address)))
+      (error (text)
+        (make-error (format nil "unknown error setting host v6ip: ~A"
+                            text))))))
+
 (defmethod handle-message ((message unknown-request))
   (make-error (format nil "unknown message: ~A" (text message))))
 
@@ -186,8 +223,7 @@
                                db-host
                                db-name
                                db-username
-                               db-password
-                               db-tls)
+                               db-password)
   (let ((postmodern:*ignore-unknown-columns* t))
     (postmodern:with-connection (list db-name db-username db-password db-host)
       (with-backplane xmpp-host xmpp-username xmpp-password