public/backplane-dns
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Refactored for testability.

Browse Source 
Factored out storage into a separate package, and added tests.
This commit is contained in:
niten
2020-12-03 21:09:07 -08:00
parent 3aad2b6a87
commit fdb04c90f1
5 changed files with 457 additions and 216 deletions
Download Patch File Download Diff File Expand all files Collapse all files
backplane-dns.lisp
+90 -207
View File
@@ -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-<hostname>"
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")