302 lines
12 KiB
Common Lisp
302 lines
12 KiB
Common Lisp
;;;; 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)))
|
|
|
|
(defun symbolize (str) (-> str string-upcase (intern :KEYWORD)))
|
|
|
|
(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 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))
|
|
|
|
(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-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 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))
|
|
(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)))))
|
|
|
|
(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))
|
|
(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)))))
|
|
|
|
(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 (eql :CHANGE_SSHFP)) message msg-id)
|
|
(make-instance 'change-request-sshfp
|
|
:msg-id msg-id
|
|
:sender sender
|
|
:hostname (sender-hostname sender)
|
|
:domain (cdr (assoc :DOMAIN message))
|
|
:sshfp (cdr (assoc :SSHFP 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)
|
|
(cl-postgres:*query-log* *standard-output*))
|
|
(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)))))
|
|
|
|
(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 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"))))
|