195 lines
7.9 KiB
Common Lisp
195 lines
7.9 KiB
Common Lisp
;;;; 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-port
|
|
db-name
|
|
db-username
|
|
db-password
|
|
db-use-ssl)
|
|
(format t "Got XMPP password: ~A" xmpp-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
|
|
:port db-port
|
|
:use-ssl (symbolize db-use-ssl))
|
|
(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-port (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_PORT" 5432)
|
|
:db-password (read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_PASSWORD_FILE"))
|
|
:db-use-ssl (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_USE_SSL" "no")))
|