Refactored for testability.

Factored out storage into a separate package, and added tests.

backplane-dns-store.lisp

@@ -0,0 +1,142 @@
+
+(in-package #:backplane-dns-store)
+
+(defclass dns-store () ())
+
+;; This seems silly since it's empty, but it enables testing
+(defclass postgres-dns-store (dns-store) ())
+
+(defclass dns-record ()
+  ((id        :col-type integer
+              :col-identity t
+              :reader   id)
+   (domain-id :col-type integer
+              :col-name "domain_id"
+              :initarg  :domain-id
+              :reader   domain-id)
+   (name      :col-type (varchar 255)
+              :initarg  :name
+              :reader   record-name)
+   (type      :col-type (varchar 10)
+              :initarg  :type
+              :reader   record-type)
+   (content   :col-type (varchar 65535)
+              :initarg  :content
+              :accessor record-content))
+  (:metaclass  postmodern:dao-class)
+  (:table-name "records")
+  (:keys       id))
+
+(defclass dns-domain ()
+  ((id        :col-type integer
+              :col-identity t
+              :reader   id)
+   (name      :col-type (varchar 255)
+              :initarg  :name
+              :reader   domain-name)
+   (master    :col-type (or (varchar 128) db-null)
+              :initarg  :master
+              :reader   domain-master)
+   (type      :col-type (varchar 6)
+              :initarg  :type
+              :reader   domain-type))
+  (:metaclass  postmodern:dao-class)
+  (:table-name domains)
+  (:keys       id))
+
+(define-condition backplane-dns-store-error () ())
+
+(define-condition domain-name-missing (backplane-dns-store-error)
+  ((missing-domain :initarg :domain
+                   :reader missing-domain)))
+
+(define-condition invalid-sshfp (backplane-dns-store-error)
+  ((sshfp :initarg :sshfp
+          :reader  invalid-sshfp)))
+
+(define-condition invalid-ip (backplane-dns-store-error)
+  ((ip :initarg :ip
+       :reader  invalid-ip)
+   (msg :initarg :msg
+        :reader error-msg)))
+
+(defun get-domain (domain)
+  (if-let ((domain (select-dao 'dns-domain (:= 'name domain))))
+    domain
+    (error 'domain-name-missing :domain domain)))
+
+(defun get-records (domain name type)
+  (let ((domain-id (id (get-domain domain))))
+    (select-dao 'dns-record (:and (:= 'domain-id domain-id)
+                                  (:= 'name      (format nil "~A.~A" name domain))
+                                  (:= 'type      type)))))
+
+(defun update-record-content (record content)
+  (if (equalp (record-content record) content)
+      (id record)
+      (progn (setf (record-content record) content)
+             (update-dao record)
+             (id record))))
+
+(defun insert-record (domain name type content)
+  (let ((domain-id (id (get-domain domain))))
+    (insert-dao (make-instance 'dns-record
+                             :domain-id domain-id
+                             :name      (format nil "~A.~A" name domain)
+                             :type      type
+                             :content   content))
+    t))
+
+(defun insert-or-update-record (domain name type content)
+  (if-let ((record (car (get-records domain name type))))
+    (update-record-content record content)
+    (insert-record domain name type content)))
+
+(defun replace-records (domain name type contents)
+  (let ((records (get-records domain name type)))
+    (if (set-difference contents (mapcar #'record-content records))
+        (with-transaction ()
+          (dolist (record records)
+            (delete-dao record))
+          (dolist (content contents)
+            (insert-record domain name type content)))
+        t)))
+
+(defgeneric set-ipv4 (store domain name ip))
+(defgeneric set-ipv6 (store domain name ip))
+(defgeneric set-sshfp (store domain name sshfp))
+
+(defmethod set-ipv4 ((store postgres-dns-store)
+                     (domain string)
+                     (name   string)
+                     (ip     string))
+  (if (ipv4-p ip)
+      (insert-or-update-record domain name "A" ip)
+      (error :invalid-ip ip
+             :msg        (format nil "not a valid v4 ip: ~A" ip))))
+
+(defmethod set-ipv6 ((store  postgres-dns-store)
+                     (domain string)
+                     (name   string)
+                     (ip     string))
+  (if (ipv6-p ip)
+      (insert-or-update-record domain name "AAAA" ip)
+      (error :invalid-ip ip
+             :msg        (format nil "not a valid v6 ip: ~A" ip))))
+
+(defun sshfp-p (sshfp)
+  (let ((els (split-sequence:split-sequence #\Space sshfp)))
+    (if (not (= (length els) 3))
+        (error 'invalid-sshfp :sshfp sshfp)
+        (if (and (< 0 (parse-integer (car els)) 9)
+                 (< 0 (parse-integer (cadr els)) 9)
+                 (cl-ppcre:scan "^[A-Fa-f0-9]{32,256}$" (caddr els)))
+            sshfp
+            (error 'invalid-sshfp :sshfp sshfp)))))
+
+(defmethod set-sshfp ((store postgres-dns-store)
+                      (domain string)
+                      (name   string)
+                      (sshfps list))
+  (if-let ((new-sshfps (mapcar #'sshfp-p sshfps)))
+    (replace-records domain name "SSHFP" new-sshfps)))

backplane-dns.asd

@@ -3,15 +3,40 @@
 (asdf:defsystem #:backplane-dns
   :description "Server to listen on Fudo backplane for DNS updates"
   :author "Niten <niten@fudo.org>"
-  :license  "Specify license here"
   :version "0.1.0"
   :serial t
   :depends-on (:alexandria
                :arrows
+               :backplane-dns-store
                :backplane-server
+               :cl-ppcre)
+  :components ((:file "package")
+               (:file "backplane-dns"))
+  :in-order-to ((test-op (test-op :backplane-dns/test))))
+
+(asdf:defsystem #:backplane-dns-store
+  :description "Storage for Fudo DNS backplane"
+  :author "Niten <niten@fudo.org>"
+  :version "0.1.0"
+  :serial t
+  :depends-on (:alexandria
+               :arrows
                :cl-ppcre
                :ip-utils
-               :postmodern
+               :postmodern)
-               :trivia)
   :components ((:file "package")
-               (:file "backplane-dns")))
+               (:file "backplane-dns-store")))
+
+(asdf:defsystem #:backplane-dns/test
+  :description "XMPP Backplane DNS Server Tests"
+  :author "Niten <niten@fudo.org>"
+  :depends-on (:arrows
+               :backplane-dns
+               :ip-utils
+               :prove)
+  :defsystem-depends-on (:prove-asdf)
+  :components ((:module "test"
+                :serial t
+                :components ((:test-file "backplane-dns-test"))))
+  :perform (asdf:test-op (op c)
+                         (uiop:symbol-call :prove '#:run '#:backplane-dns/test)))

backplane-dns.lisp

@@ -2,21 +2,15 @@
 
 (in-package #:backplane-dns)
 
-(defun getenv-or-fail (env-var &optional default)
+(defvar *dns-store* nil)
-  (let ((value (uiop:getenv env-var)))
-    (if (null value)
-        (if default
-            default
-            (uiop:die 1 "unable to find required env var: ~A" env-var))
-        value)))
 
 (defun symbolize (str) (-> str string-upcase (intern :KEYWORD)))
 
 (defclass dns-request ()
   ((hostname :initarg :hostname)
    (domain   :initarg :domain)
-   (sender   :initarg :sender)
+   (msg-id   :initarg :msg-id
-   (msg-id   :initarg :msg-id)))
+             :reader  msg-id)))
 
 (defclass request-change-ipv4 (dns-request)
   ((ip-address :initarg :ip-address)))
@@ -28,139 +22,17 @@
   ((sshfp      :initarg :sshfp)))
 
 (defclass unknown-dns-request (dns-request)
-  ((request-type :initarg :request-type)))
+  ((request-type :initarg :request-type
-
+                 :reader  request-type)))
-(defclass dns-record ()
-  ((id        :col-type integer
-              :col-identity t
-              :reader   id)
-   (domain-id :col-type integer
-              :col-name "domain_id"
-              :initarg  :domain-id
-              :reader   domain-id)
-   (name      :col-type (varchar 255)
-              :initarg  :name
-              :reader   record-name)
-   (type      :col-type (varchar 10)
-              :initarg  :type
-              :reader   record-type)
-   (content   :col-type (varchar 65535)
-              :initarg  :content
-              :accessor record-content))
-  (:metaclass  postmodern:dao-class)
-  (:table-name "records")
-  (:keys       id))
-
-(defclass dns-domain ()
-  ((id        :col-type integer
-              :col-identity t
-              :reader   id)
-   (name      :col-type (varchar 255)
-              :initarg  :name
-              :reader   domain-name)
-   (master    :col-type (or (varchar 128) db-null)
-              :initarg  :master
-              :reader   domain-master)
-   (type      :col-type (varchar 6)
-              :initarg  :type
-              :reader   domain-type))
-  (:metaclass  postmodern:dao-class)
-  (:table-name domains)
-  (:keys       id))
 
 (defparameter *hostname-rx*
   "(([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9])")
 
-(defun get-domain (name)
+(define-condition backplane-dns-error (error)
-  (car (select-dao 'dns-domain (:= 'name name))))
+  ((msg :initarg :msg :initform nil :reader error-msg)))
 
-(define-condition backplane-dns-error (error) ())
+(define-condition invalid-hostname (backplane-dns-error)
-
+  ((hostname :initarg :hostname :reader invalid-hostname)))
-(define-condition domain-name-missing (backplane-dns-error)
-  ((missing-domain :initarg :domain :reader missing-domain)))
-
-(define-condition invalid-sshfp (backplane-dns-error)
-  ((sshfp :initarg :sshfp
-          :reader  sshfp)))
-
-(define-condition invalid-ip (backplane-dns-error)
-  ((ip :initarg :ip
-       :reader  ip)))
-
-(defun find-host-records-by-type (host domain type)
-  (if-let ((domain-id (some-> domain
-                              (get-domain)
-                              (id))))
-    (select-dao 'dns-record
-        (:and (:= '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)
-  (if (not (ipv4-p v4ip))
-      (error 'invalid-ipv4 :ip v4ip)
-      (update-host-record-by-type host domain "A" v4ip)))
-
-(defun set-host-v6ip (host domain v6ip)
-  (if (not (ipv6-p v6ip))
-      (error 'invalid-ipv6 :ip v6ip)
-      (update-host-record-by-type host domain "AAAA" v6ip)))
-
-(defun validate-sshfp (sshfp)
-  (let ((els (split-string sshfp)))
-    (if (not (= (length els) 3))
-        (error 'invalid-sshfp :sshfp sshfp)
-        (if (and (< 0 (parse-integer (car els)) 9)
-                 (< 0 (parse-integer (cadr els)) 9)
-                 (cl-ppcre:scan "^[A-Fa-f0-9]{32,256}$" (caddr els)))
-            sshfp
-            nil))))
-
-(defun set-host-sshfp (host domain incoming-sshfps)
-  (if-let ((domain-id (some-> domain
-                              (get-domain)
-                              (id))))
-    (let* ((new-sshfps (mapcar #'validate-sshfp incoming-sshfps))
-           (full-hostname (format nil "~A.~A" host domain))
-           (sshfp-records (select-dao 'dns-record
-                              (:and (:= 'name      full-hostname)
-                                    (:= 'domain-id domain-id)
-                                    (:= 'type      "SSHFP"))))
-           (existing-sshfps (mapcar #'record-content sshfp-records)))
-      (if (not (set-difference new-sshfps existing-sshfps))
-          t
-          (with-transaction ()
-            (dolist (record sshfp-records)
-              (delete-dao record))
-            (dolist (sshfp new-sshfps)
-              (insert-dao
-               (make-instance 'dns-record
-                              :domain-id domain-id
-                              :name      full-hostname
-                              :type      "SSHFP"
-                              :content   sshfp))))))
-    (error 'domain-name-missing :domain domain)))
-
-(defun split-string (string &optional (char #\Space))
-  (split-sequence:split-sequence char string))
 
 (let ((hostname-extractor-rx
         (cl-ppcre:create-scanner
@@ -169,79 +41,73 @@
                      #\@
                      (:REGEX ,*hostname-rx*) :END-ANCHOR))))
   (defun sender-hostname (sender)
-    (cl-ppcre:register-groups-bind (hostname nil)
+    (if-let ((hostname (cl-ppcre:register-groups-bind (extracted-hostname nil)
-        (hostname-extractor-rx sender)
+                           (hostname-extractor-rx sender)
-      hostname)))
+                         extracted-hostname)))
+      hostname
+      (error 'invalid-hostname
+             :hostname sender
+             :msg (format nil "unable to extract hostname from ~A, expecting format host-<hostname>"
+                          sender)))))
 
-(defmethod backplane-server:handle-message ((message request-change-sshfp))
+(defmethod backplane-server:handle-message ((message dns-request))
-  (with-slots (hostname domain sshfp msg-id) message
+  (handler-case
-    (if (not (listp sshfp))
+      (if-let ((store *dns-store*))
-        (make-error :msg (format nil "expected list of sshfp records, got: ~A" sshfp)
+        (-> message
-                    :msg-id msg-id)
+            (handle-dns-message store)
-        (handler-case
+            (handle-dns-response (msg-id message)))
-            (progn (set-host-sshfp hostname domain sshfp)
+        (make-error :msg "dns store is not initialized"
-                   (make-success :msg (format nil "set ssh fingerprints for host ~A in domain ~A"
+                    :msg-id (msg-id message)))      
-                                              hostname domain)
+    (domain-name-missing (err)
-                                 :msg-id msg-id))
+      (make-error :msg (format nil "missing domain name: ~A"
-          (invalid-sshfp (err)
+                               (missing-domain err))
-            (make-error :msg (format nil "bad sshfp for host ~A: ~A"
+                  :msg-id (msg-id message)))
-                                     hostname
+    (invalid-ip (err)
-                                     (sshfp err))))
+      (make-error :msg (error-msg err)
-          (domain-name-missing (err)
+                  :msg-id (msg-id message)))
-            (make-error :msg (format nil "missing domain name: ~A"
+    (invalid-sshfp (err)
-                                     (missing-domain err))
+      (make-error :msg (format nil "invalid ssh fingerprint: ~A"
-                        :msg-id msg-id))
+                               (invalid-sshfp err))
-          (error (text)
+                  :msg-id (msg-id message)))
-            (make-error :msg (format nil "unknown error setting host ssh fingerprints: ~A"
+    (error (e)
-                                     text)
+      (declare (ignorable e))
-                        :msg-id msg-id))))))
+      (make-error :msg (format nil "an unknown error occurred: ~A"
+                               e) 
+                  :msg-id (msg-id message)))))
 
-(defmethod backplane-server:handle-message ((message request-change-ipv4))
+(defgeneric handle-dns-message (message store))
-  (with-slots (hostname domain ip-address msg-id) message
-    (handler-case
-        (progn (set-host-v4ip hostname domain ip-address)
-               (make-success :msg (format nil "ipv4 for host ~A in domain ~A set to ~A"
-                                          hostname domain ip-address)
-                             :msg-id msg-id))
-      (invalid-ip (err)
-        (declare (ignorable err))
-        (make-error :msg (format nil "invalid ipv4: ~A" ip-address)
-                    :msg-id msg-id))
-      (domain-name-missing (err)
-        (make-error :msg (format nil "missing domain name: ~A"
-                                 (missing-domain err))
-                    :msg-id msg-id))
-      (error (text)
-        (make-error :msg (format nil "unknown error setting host v4ip: ~A"
-                                 text)
-                    :msg-id msg-id)))))
 
-(defmethod backplane-server:handle-message ((message request-change-ipv6))
+(defmethod handle-dns-message ((message request-change-ipv4) store)
-  (with-slots (hostname domain ip-address msg-id) message
+  (with-slots (hostname domain ip-address) message
-    (handler-case
+    (backplane-dns-store:set-ipv4 store domain hostname ip-address)
-        (progn (set-host-v6ip hostname domain ip-address)
+    (make-instance 'dns-success
-               (make-success :msg (format nil "ipv6 for host ~A in domain ~A set to ~A"
+                   :msg (format nil "successfully set ipv4 for ~A.~A to ~A"
-                                          hostname domain ip-address)
+                                hostname domain ip-address))))
-                             :msg-id msg-id))
+
-      (invalid-ip (err)
+(defmethod handle-dns-message ((message request-change-ipv6) store)
-        (declare (ignorable err))
+  (with-slots (hostname domain ip-address) message
-        (make-error :msg (format nil "invalid ipv6: ~A" ip-address)
+    (backplane-dns-store:set-ipv6 store domain hostname ip-address)
-                    :msg-id msg-id))
+    (make-instance 'dns-success
-      (domain-name-missing (err)
+                   :msg (format nil "successfully set ipv6 for ~A.~A to ~A"
-        (make-error :msg (format nil "missing domain name: ~A"
+                                hostname domain ip-address))))
-                                 (missing-domain err))
+
-                    :msg-id msg-id))
+(defmethod handle-dns-message ((message request-change-sshfp) store)
-      (error (text)
+  (with-slots (hostname domain sshfp) message
-        (make-error :msg (format nil "unknown error setting host v6ip: ~A"
+    (backplane-dns-store:set-sshfp store domain hostname sshfp)
-                                 text)
+    (make-instance 'dns-success
-                    :msg-id msg-id)))))
+                   :msg (format nil "successfully set sshfps for ~A.~A"
+                                hostname domain))))
+
+(defmethod handle-dns-message ((message unknown-dns-request) store)
+  (make-instance 'dns-error
+                 :msg (format nil "unknown request to the dns service: ~A"
+                              (request-type message))))
 
 (defgeneric parse-dns-message (sender request message msg-id)
   (:documentation "Parse a DNS service message of type REQUEST"))
 
 (defmethod parse-dns-message (sender (request (eql :CHANGE_IPV4)) message msg-id)
   (make-instance 'request-change-ipv4
-                 :sender     sender
                  :hostname   (sender-hostname sender)
                  :domain     (cdr (assoc :DOMAIN message))
                  :ip-address (cdr (assoc :IP message))
@@ -249,7 +115,6 @@
 
 (defmethod parse-dns-message (sender (request (eql :CHANGE_IPV6)) message msg-id)
   (make-instance 'request-change-ipv6
-                 :sender     sender
                  :hostname   (sender-hostname sender)
                  :domain     (cdr (assoc :DOMAIN message))
                  :ip-address (cdr (assoc :IP message))
@@ -257,21 +122,30 @@
 
 (defmethod parse-dns-message (sender (request (eql :CHANGE_SSHFP)) message msg-id)
   (make-instance 'request-change-sshfp
-                 :sender     sender
                  :hostname   (sender-hostname sender)
                  :domain     (cdr (assoc :DOMAIN message))
                  :sshfp      (cdr (assoc :SSHFP message))
                  :msg-id     msg-id))
 
 (defmethod parse-dns-message (sender request message msg-id)
-  (make-instance 'unknown-request
+  (make-instance 'unknown-dns-request
-                 :sender       sender
                  :request-type request
                  :msg-id       msg-id))
 
 (defmethod backplane-server:parse-message (sender (service (eql :DNS)) api-version message msg-id)
   (parse-dns-message sender (symbolize (cdr (assoc :REQUEST message))) message msg-id))
 
+(defclass dns-response ()
+  ((msg :initarg :msg :reader msg)))
+(defclass dns-success (dns-response) ())
+(defclass dns-error (dns-response) ())
+
+(defgeneric handle-dns-response (resp msg-id))
+(defmethod handle-dns-response ((resp dns-success) msg-id)
+  (make-success :msg (msg resp) :msg-id msg-id))
+(defmethod handle-dns-response ((resp dns-error) msg-id)
+  (make-error :msg (msg resp) :msg-id msg-id))
+
 (defun backplane-dns-listen (&key
                                xmpp-host
                                xmpp-username
@@ -281,10 +155,11 @@
                                db-username
                                db-password)
   (let ((postmodern:*ignore-unknown-columns* t)
-        (cl-postgres:*query-log* *standard-output*))
+        (cl-postgres:*query-log* *standard-output*)
+        (*dns-store* (make-instance 'backplane-dns-store:postgres-dns-store)))
     (postmodern:with-connection (list db-name db-username db-password db-host)
       (with-backplane (backplane (backplane-connect xmpp-host xmpp-username xmpp-password))
-        (xmpp:receive-stanza-loop backplane)))))
+        (start-listening backplane)))))
 
 (defun read-file-line (filename)
   (let ((input (open filename :if-does-not-exist nil)))
@@ -292,6 +167,14 @@
         (read-line input)
         (uiop:die 1 "unable to read file: ~A" filename))))
 
+(defun getenv-or-fail (env-var &optional default)
+  (let ((value (uiop:getenv env-var)))
+    (if (null value)
+        (if default
+            default
+            (uiop:die 1 "unable to find required env var: ~A" env-var))
+        value)))
+
 (defun start-listener-with-env ()
   (backplane-dns-listen
    :xmpp-host     (getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_HOSTNAME")

package.lisp

@@ -12,18 +12,48 @@
                 #:backplane-connect
                 #:make-error
                 #:make-success
+                #:start-listening
                 #:with-backplane)
+  (:import-from #:backplane-dns-store
+                #:invalid-sshfp
+                #:missing-domain
+                #:invalid-ip
+                #:domain-name-missing
+                #:error-msg)
+  
+  (:export      #:start-listener-with-env
+                #:backplane-dns-listen
+                #:parse-message
+                #:handle-message
+                #:unknown-dns-request
+                #:request-change-ipv4
+                #:request-change-ipv6
+                #:request-change-sshfp
+                #:*dns-store*))
+
+(defpackage #:backplane-dns-store
+  (:use #:cl)
+
+  (:import-from #:arrows #:->)
+  (:import-from #:alexandria #:if-let)
   (:import-from #:ip-utils
                 #:ipv4-p
                 #:ipv6-p)
   (:import-from #:postmodern
-                #:get-dao
                 #:select-dao
                 #:update-dao
                 #:insert-dao
                 #:delete-dao
                 #:with-transaction)
-
+  
-  (:export      #:start-listener-with-env
+  (:export      #:set-ipv4
-                #:backplane-dns-listen
+                #:set-ipv6
-                #:parse-message))
+                #:set-sshfp
+                #:postgres-dns-store
+                #:invalid-ip
+                #:invalid-sshfp
+                #:domain-name-missing
+                #:missing-domain
+                #:dns-store
+                #:sshfp-p
+                #:error-msg))

test/backplane-dns-test.lisp

@@ -0,0 +1,161 @@
+;;;; backplane-dns-test.lisp
+
+(defpackage #:backplane-dns/test
+  (:use #:cl
+        #:backplane-dns
+        #:prove)
+  (:import-from #:arrows
+                #:->)
+  (:import-from #:ip-utils
+                #:ipv4-p #:ipv6-p))
+
+(in-package #:backplane-dns/test)
+
+(plan 20)
+
+(defun ipv4-body (ip &key (domain "test.org"))
+  `((:REQUEST . "change_ipv4")
+    (:DOMAIN  . ,domain)
+    (:IP      . ,ip)))
+
+(defun ipv6-body (ip &key (domain "test.org"))
+  `((:REQUEST . "change_ipv6")
+    (:DOMAIN  . ,domain)
+    (:IP      . ,ip)))
+
+(defun sshfp-body (sshfps &key (domain "test.org"))
+  `((:REQUEST . "change_sshfp")
+    (:DOMAIN  . ,domain)
+    (:SSHFP   . ,sshfps)))
+
+(defun parse-request (body &key
+                             (sender "host-tester@backplane.test")
+                             (api-version "1")
+                             (msg-id "1"))
+  (backplane-server:parse-message sender :DNS api-version body msg-id))
+
+(is-type (parse-request '())
+         'backplane-dns:unknown-dns-request)
+
+(is-type (parse-request '((:REQUEST . "oops")))
+         'backplane-dns:unknown-dns-request)
+
+(is-type (parse-request (ipv4-body "1.1.1.1"))
+         'backplane-dns:request-change-ipv4)
+
+(is-type (parse-request (ipv6-body "a::3"))
+         'backplane-dns:request-change-ipv6)
+
+(is-type (parse-request (sshfp-body (list "123")))
+         'backplane-dns:request-change-sshfp)
+
+(defclass simple-test-store (backplane-dns-store:dns-store)
+  ((ops :initform '() :reader ops)))
+
+(defmethod backplane-dns-store:set-ipv4 ((store simple-test-store) domain name ip)
+  (with-slots (ops) store
+    (setf ops (cons (cons :set-ipv4 ip) ops))
+    t))
+
+(defmethod backplane-dns-store:set-ipv6 ((store simple-test-store) domain name ip)
+  (with-slots (ops) store
+    (setf ops (cons (cons :set-ipv6 ip) ops))
+    t))
+
+(defmethod backplane-dns-store:set-sshfp ((store simple-test-store) domain name sshfp)
+  (with-slots (ops) store
+    (setf ops (cons (cons :set-sshfp sshfp) ops))
+    t))
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'simple-test-store)))
+           (backplane-server:handle-message (parse-request (ipv4-body "1.1.1.1"))))
+         'backplane-server:result/success)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'simple-test-store)))
+           (backplane-server:handle-message (parse-request (ipv6-body "1:1::1"))))
+         'backplane-server:result/success)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'simple-test-store)))
+           (backplane-server:handle-message (parse-request (sshfp-body '("fake-key")))))
+         'backplane-server:result/success)
+
+(let ((backplane-dns:*dns-store* (make-instance 'simple-test-store))
+      (ip "1.1.1.1"))
+  (is (progn (backplane-server:handle-message (parse-request (ipv4-body ip)))
+             (car (ops backplane-dns:*dns-store*)))
+      (cons :set-ipv4 ip)))
+
+(let ((backplane-dns:*dns-store* (make-instance 'simple-test-store))
+      (ip "aa::1"))
+  (is (progn (backplane-server:handle-message (parse-request (ipv6-body ip)))
+             (car (ops backplane-dns:*dns-store*)))
+      (cons :set-ipv6 ip)))
+
+(let ((backplane-dns:*dns-store* (make-instance 'simple-test-store))
+      (sshfp '("1 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
+  (is (progn (backplane-server:handle-message (parse-request (sshfp-body sshfp)))
+             (car (ops backplane-dns:*dns-store*)))
+      (cons :set-sshfp sshfp)))
+
+(defclass verifying-test-store (backplane-dns-store:dns-store)
+  ((ops :initform '() :reader ops)))
+
+(defmethod backplane-dns-store:set-ipv4 ((store verifying-test-store) domain name ip)
+  (if (not (ipv4-p ip))
+      (error 'backplane-dns-store:invalid-ip
+             :msg "invalid ipv4")
+      (with-slots (ops) store
+        (setf ops (cons (cons :set-ipv4 ip) ops))
+        t)))
+
+(defmethod backplane-dns-store:set-ipv6 ((store verifying-test-store) domain name ip)
+  (if (not (ipv6-p ip))
+      (error 'backplane-dns-store:invalid-ip
+             :msg "invalid ipv6")
+      (with-slots (ops) store
+        (setf ops (cons (cons :set-ipv6 ip) ops))
+        t)))
+
+(defmethod backplane-dns-store:set-sshfp ((store verifying-test-store) domain name sshfp)
+  (let ((new-sshfp (mapcar #'backplane-dns-store:sshfp-p sshfp)))
+    (with-slots (ops) store
+        (setf ops (cons (cons :set-sshfp new-sshfp) ops))
+      t)))
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (ipv4-body "1.1.1.1"))))
+         'backplane-server:result/success)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (ipv6-body "1:1::1"))))
+         'backplane-server:result/success)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (sshfp-body '("1 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
+         'backplane-server:result/success)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (ipv4-body "1.1:1.1"))))
+         'backplane-server:result/error)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (ipv6-body "1:1.:1"))))
+         'backplane-server:result/error)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (sshfp-body '("oops")))))
+         'backplane-server:result/error)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (sshfp-body '("1 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
+         'backplane-server:result/error)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (sshfp-body '("10 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
+         'backplane-server:result/error)
+
+(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
+           (backplane-server:handle-message (parse-request (sshfp-body '("1 0 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
+         'backplane-server:result/error)
+
+(finalize)