diff --git a/backplane-dns-store.lisp b/backplane-dns-store.lisp new file mode 100644 index 0000000..b645df2 --- /dev/null +++ b/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))) diff --git a/backplane-dns.asd b/backplane-dns.asd index 8d1ec99..272a1c3 100644 --- a/backplane-dns.asd +++ b/backplane-dns.asd @@ -3,15 +3,40 @@ (asdf:defsystem #:backplane-dns :description "Server to listen on Fudo backplane for DNS updates" :author "Niten " - :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 " + :version "0.1.0" + :serial t + :depends-on (:alexandria + :arrows :cl-ppcre :ip-utils - :postmodern - :trivia) + :postmodern) :components ((:file "package") - (:file "backplane-dns"))) + (:file "backplane-dns-store"))) + +(asdf:defsystem #:backplane-dns/test + :description "XMPP Backplane DNS Server Tests" + :author "Niten " + :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))) diff --git a/backplane-dns.lisp b/backplane-dns.lisp index a4edf33..d235576 100644 --- a/backplane-dns.lisp +++ b/backplane-dns.lisp @@ -2,21 +2,15 @@ (in-package #:backplane-dns) -(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))) +(defvar *dns-store* nil) (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))) - -(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)) + ((request-type :initarg :request-type + :reader request-type))) (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) - (car (select-dao 'dns-domain (:= 'name name)))) +(define-condition backplane-dns-error (error) + ((msg :initarg :msg :initform nil :reader error-msg))) -(define-condition backplane-dns-error (error) ()) - -(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)) +(define-condition invalid-hostname (backplane-dns-error) + ((hostname :initarg :hostname :reader invalid-hostname))) (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) - (hostname-extractor-rx sender) - hostname))) + (if-let ((hostname (cl-ppcre:register-groups-bind (extracted-hostname nil) + (hostname-extractor-rx sender) + extracted-hostname))) + hostname + (error 'invalid-hostname + :hostname sender + :msg (format nil "unable to extract hostname from ~A, expecting format host-" + sender))))) -(defmethod backplane-server:handle-message ((message request-change-sshfp)) - (with-slots (hostname domain sshfp msg-id) message - (if (not (listp sshfp)) - (make-error :msg (format nil "expected list of sshfp records, got: ~A" sshfp) - :msg-id msg-id) - (handler-case - (progn (set-host-sshfp hostname domain sshfp) - (make-success :msg (format nil "set ssh fingerprints for host ~A in domain ~A" - hostname domain) - :msg-id msg-id)) - (invalid-sshfp (err) - (make-error :msg (format nil "bad sshfp for host ~A: ~A" - hostname - (sshfp err)))) - (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 ssh fingerprints: ~A" - text) - :msg-id msg-id)))))) +(defmethod backplane-server:handle-message ((message dns-request)) + (handler-case + (if-let ((store *dns-store*)) + (-> message + (handle-dns-message store) + (handle-dns-response (msg-id message))) + (make-error :msg "dns store is not initialized" + :msg-id (msg-id message))) + (domain-name-missing (err) + (make-error :msg (format nil "missing domain name: ~A" + (missing-domain err)) + :msg-id (msg-id message))) + (invalid-ip (err) + (make-error :msg (error-msg err) + :msg-id (msg-id message))) + (invalid-sshfp (err) + (make-error :msg (format nil "invalid ssh fingerprint: ~A" + (invalid-sshfp err)) + :msg-id (msg-id message))) + (error (e) + (declare (ignorable e)) + (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)) - (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))))) +(defgeneric handle-dns-message (message store)) -(defmethod backplane-server:handle-message ((message request-change-ipv6)) - (with-slots (hostname domain ip-address msg-id) message - (handler-case - (progn (set-host-v6ip hostname domain ip-address) - (make-success :msg (format nil "ipv6 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 ipv6: ~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 v6ip: ~A" - text) - :msg-id msg-id))))) +(defmethod handle-dns-message ((message request-change-ipv4) store) + (with-slots (hostname domain ip-address) message + (backplane-dns-store:set-ipv4 store domain hostname ip-address) + (make-instance 'dns-success + :msg (format nil "successfully set ipv4 for ~A.~A to ~A" + hostname domain ip-address)))) + +(defmethod handle-dns-message ((message request-change-ipv6) store) + (with-slots (hostname domain ip-address) message + (backplane-dns-store:set-ipv6 store domain hostname ip-address) + (make-instance 'dns-success + :msg (format nil "successfully set ipv6 for ~A.~A to ~A" + hostname domain ip-address)))) + +(defmethod handle-dns-message ((message request-change-sshfp) store) + (with-slots (hostname domain sshfp) message + (backplane-dns-store:set-sshfp store domain hostname sshfp) + (make-instance 'dns-success + :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 - :sender sender + (make-instance 'unknown-dns-request :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") diff --git a/package.lisp b/package.lisp index 3ecaa4a..4b9622d 100644 --- a/package.lisp +++ b/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 - #:backplane-dns-listen - #:parse-message)) + + (:export #:set-ipv4 + #:set-ipv6 + #:set-sshfp + #:postgres-dns-store + #:invalid-ip + #:invalid-sshfp + #:domain-name-missing + #:missing-domain + #:dns-store + #:sshfp-p + #:error-msg)) diff --git a/test/backplane-dns-test.lisp b/test/backplane-dns-test.lisp new file mode 100644 index 0000000..53e67f8 --- /dev/null +++ b/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)