DNS backplane listener. Connects to a Jabber server and listens for updates from hosts.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 

187 lines
7.5 KiB

;;;; backplane-dns.lisp
(in-package #:backplane-dns)
(defvar *dns-store* nil)
(defun symbolize (str) (-> str string-upcase (intern :KEYWORD)))
(defclass dns-request ()
((hostname :initarg :hostname)
(domain :initarg :domain)
(msg-id :initarg :msg-id
:reader msg-id)))
(defclass request-change-ipv4 (dns-request)
((ip-address :initarg :ip-address)))
(defclass request-change-ipv6 (dns-request)
((ip-address :initarg :ip-address)))
(defclass request-change-sshfp (dns-request)
((sshfp :initarg :sshfp)))
(defclass unknown-dns-request (dns-request)
((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])")
(define-condition backplane-dns-error (error)
((msg :initarg :msg :initform nil :reader error-msg)))
(define-condition invalid-hostname (backplane-dns-error)
((hostname :initarg :hostname :reader invalid-hostname)))
(let ((hostname-extractor-rx
(cl-ppcre:create-scanner
`(:SEQUENCE :START-ANCHOR "host-"
(:REGISTER (:REGEX ,*hostname-rx*))
#\@
(:REGEX ,*hostname-rx*) :END-ANCHOR))))
(defun sender-hostname (sender)
(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 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)))))
(defgeneric handle-dns-message (message store))
(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
:hostname (sender-hostname sender)
:domain (cdr (assoc :DOMAIN message))
:ip-address (cdr (assoc :IP message))
:msg-id msg-id))
(defmethod parse-dns-message (sender (request (eql :CHANGE_IPV6)) message msg-id)
(make-instance 'request-change-ipv6
:hostname (sender-hostname sender)
:domain (cdr (assoc :DOMAIN message))
:ip-address (cdr (assoc :IP message))
:msg-id msg-id))
(defmethod parse-dns-message (sender (request (eql :CHANGE_SSHFP)) message msg-id)
(make-instance 'request-change-sshfp
: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-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
xmpp-password
db-host
db-name
db-username
db-password)
(let ((postmodern:*ignore-unknown-columns* t)
(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))
(start-listening backplane)))))
(defun read-file-line (filename)
(let ((input (open filename :if-does-not-exist nil)))
(if input
(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")
:xmpp-username (getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_USERNAME")
:xmpp-password (read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_PASSWORD_FILE"))
:db-name (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_NAME")
:db-username (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_USERNAME")
:db-host (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_HOSTNAME")
:db-password (read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_PASSWORD_FILE"))))