214 lines
7.3 KiB
Common Lisp
214 lines
7.3 KiB
Common Lisp
;;;; backplane-dns.lisp
|
|
|
|
(in-package #:backplane-dns)
|
|
|
|
(defun xmpp-connect (hostname username password)
|
|
(let ((conn (xmpp:connect-tls :hostname hostname)))
|
|
(xmpp:auth conn username password "backplane")
|
|
conn))
|
|
|
|
(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 request ()
|
|
((sender :initarg :sender)))
|
|
|
|
(defclass change-request-ipv4 (request)
|
|
((hostname :initarg :hostname)
|
|
(domain :initarg :domain)
|
|
(ip-address :initarg :ip-address)))
|
|
|
|
(defclass unknown-request (request)
|
|
((text :initarg :text
|
|
:reader text)))
|
|
|
|
(defclass result ()
|
|
((message :initarg :message)))
|
|
|
|
(defclass result/success (result) ())
|
|
(defclass result/error (result) ())
|
|
|
|
(defun make-success (&optional msg)
|
|
(make-instance 'result/success :message msg))
|
|
|
|
(defun make-error (&optional msg)
|
|
(make-instance 'result/error :message msg))
|
|
|
|
(defparameter *hostname-rx*
|
|
"([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 host-a-record (hostname domain)
|
|
(if-let ((domain-id (some-> domain
|
|
(get-domain)
|
|
(id))))
|
|
(car (select-dao 'dns-record
|
|
(:= 'name hostname)
|
|
(:= 'domain-id domain-id)
|
|
(:= 'type "A")))
|
|
(error 'domain-name-missing :domain domain)))
|
|
|
|
(defun set-host-v4ip (host domain v4ip)
|
|
(let* ((full-hostname (format nil "~A.~A" host domain))
|
|
(a-record (host-a-record full-hostname domain)))
|
|
(if a-record
|
|
(progn (setf (record-content a-record) v4ip)
|
|
(update-dao a-record))
|
|
(if-let ((domain-id (some-> domain (get-domain) (id))))
|
|
(insert-dao (make-instance 'dns-record
|
|
:domain-id domain-id
|
|
:name full-hostname
|
|
:type "A"
|
|
:content v4ip))))))
|
|
|
|
(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)))
|
|
|
|
(defgeneric render-result (result))
|
|
|
|
(defmethod render-result ((res result/success))
|
|
(with-slots (message) res
|
|
(if message
|
|
(format nil "OK: ~A" message)
|
|
"OK")))
|
|
|
|
(defmethod render-result ((res result/error))
|
|
(with-slots (message) res
|
|
(if message
|
|
(format nil "ERROR: ~A" message)
|
|
"ERROR")))
|
|
|
|
(defun parse-message (message)
|
|
(let ((from (xmpp:from message)))
|
|
(trivia:match (split-string (xmpp:body message))
|
|
|
|
((list "REQUEST-CHANGE-IPV4" domain ip)
|
|
(make-instance 'change-request-ipv4
|
|
:sender from
|
|
:hostname (sender-hostname from)
|
|
:domain domain
|
|
:ip-address ip))
|
|
|
|
(_ (make-instance 'unknown-request
|
|
:sender from
|
|
:text (xmpp:body message))))))
|
|
|
|
(defgeneric handle-message (message))
|
|
|
|
(defmethod handle-message ((message change-request-ipv4))
|
|
(with-slots (hostname domain ip-address) message
|
|
(handler-case
|
|
(progn (set-host-v4ip hostname domain ip-address)
|
|
(make-success (format nil "ipv4 for host ~a in domain ~a set to ~a"
|
|
hostname domain ip-address)))
|
|
(error (text)
|
|
(make-error (format nil "unknown error setting host v4ip: ~A"
|
|
text))))))
|
|
|
|
(defmethod handle-message ((message unknown-request))
|
|
(make-error (format nil "unknown message: ~A" (text message))))
|
|
|
|
(defmethod xmpp:handle ((conn xmpp:connection) (message xmpp:message))
|
|
(xmpp:message conn
|
|
(xmpp:from message)
|
|
(-> message
|
|
(parse-message)
|
|
(handle-message)
|
|
(render-result))))
|
|
|
|
(defun with-backplane (xmpp-host xmpp-username xmpp-password f)
|
|
(let ((backplane (xmpp:connect-tls :hostname xmpp-host)))
|
|
(xmpp:auth backplane
|
|
xmpp-username
|
|
xmpp-password
|
|
"server"
|
|
:mechanism :sasl-plain)
|
|
(funcall f backplane)))
|
|
|
|
(defun backplane-dns-listen (&key
|
|
xmpp-host
|
|
xmpp-username
|
|
xmpp-password
|
|
db-host
|
|
db-name
|
|
db-username
|
|
db-password)
|
|
(postmodern:with-connection (list db-name db-username db-password db-host :use-ssl :try)
|
|
(with-backplane xmpp-host xmpp-username xmpp-password
|
|
(lambda (backplane)
|
|
(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"))))
|