;;;; backplane-dns.lisp (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))) (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)) (defclass change-request-ipv4 (request) ((hostname :initarg :hostname) (domain :initarg :domain) (ip-address :initarg :ip-address))) (defclass change-request-ipv6 (request) ((hostname :initarg :hostname) (domain :initarg :domain) (ip-address :initarg :ip-address))) (defclass change-request-sshfp (request) ((hostname :initarg :hostname) (domain :initarg :domain) (sshfp :initarg :sshfp))) (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 domain-name-missing (error) ((missing-domain :initarg :domain :reader missing-domain))) (defun find-host-records-by-type (host domain type) (if-let ((domain-id (some-> domain (get-domain) (id)))) (select-dao 'dns-record (:= '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) (update-host-record-by-type host domain "A" v4ip)) (defun set-host-v6ip (host domain v6ip) (update-host-record-by-type host domain "AAAA" v6ip)) (defun split-string (string &optional (char #\Space)) (split-sequence:split-sequence char string)) (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) (cl-ppcre:register-groups-bind (hostname nil) (hostname-extractor-rx sender) hostname))) (defmethod handle-message ((message change-request-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)) (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 handle-message ((message change-request-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)) (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))))) (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 'change-request-ipv4 :msg-id msg-id :sender sender :hostname (sender-hostname sender) :domain (cdr (assoc :DOMAIN message)) :ip-address (cdr (assoc :IP message)))) (defmethod parse-dns-message (sender (request (eql :CHANGE_IPV6)) message msg-id) (make-instance 'change-request-ipv6 :msg-id msg-id :sender sender :hostname (sender-hostname sender) :domain (cdr (assoc :DOMAIN message)) :ip-address (cdr (assoc :IP message)))) (defmethod parse-dns-message (sender request message msg-id) (make-instance 'unknown-request :msg-id msg-id :sender sender :request request)) (defmethod parse-message (sender (service (eql :DNS)) api-version message msg-id) (parse-dns-message sender (symbolize (cdr (assoc :REQUEST message))) message 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)) (postmodern:with-connection (list db-name db-username db-password db-host) (let ((backplane (backplane-connect xmpp-host xmpp-username xmpp-password))) (xmpp:receive-stanza-loop backplane))))) (defun read-file-line (filename) (let ((input (open filename :if-does-not-exist nil))) (read-line input))) (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"))))