public
/
backplane-dns
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit

This commit is contained in:
Niten 2020-11-04 12:34:28 -08:00
commit b65eda6228
4 changed files with 247 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
README.md Normal file
View File

@ -0,0 +1,9 @@
# dns-backplane
### _Your Name <your.name@example.com>_
This is a project to do ... something.
## License
Specify license here

18
dns-backplane.asd Normal file
View File

@ -0,0 +1,18 @@
;;;; dns-backplane.asd
(asdf:defsystem #:dns-backplane
:description "Describe dns-backplane here"
:author "Your Name <your.name@example.com>"
:license "Specify license here"
:version "0.0.1"
:serial t
:depends-on (:alexandria
:arrows
:cl-ppcre
:cl+ssl
:cl-xmpp
:cl-xmpp-tls
:postmodern
:trivia)
:components ((:file "package")
(:file "dns-backplane")))

207
dns-backplane.lisp Normal file
View File

@ -0,0 +1,207 @@
;;;; dns-backplane.lisp
(in-package #:dns-backplane)
(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)))
(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])")
(let ((domain-extractor-rx
(cl-ppcre:create-scanner
`(:SEQUENCE :START-ANCHOR
(:GREEDY-REPETITION 1 nil
(:INVERTED-CHAR-CLASS #\.))
(:GREEDY-REPETITION 0 1 ".")
(:REGISTER ,*hostname-rx*)))))
(defun host-domain (hostname)
(cl-ppcre:register-groups-bind (hostname)
(domain-extractor-rx hostname)
hostname)))
(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"))
(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))
(defun get-domain (name)
(get-dao 'dns-domain :name name))
(define-condition domain-name-missing (error)
((missing-domain :initarg :domain :reader missing-domain)))
(defun host-domain-id (host)
(some-> (host-domain host)
(get-domain)
(domain-id)))
(defun host-a-record (host)
(if-let ((domain-id (host-domain-id host)))
(get-dao 'dns-record :name host
:domain-id domain-id
:type "A")
(error 'domain-name-missing :domain (host-domain host))))
(defun set-host-v4ip (host v4ip)
(let ((a-record (host-a-record host)))
(if a-record
(progn (setf (record-content a-record) v4ip)
(update-dao a-record))
(let ((new-a-record (make-instance 'dns-record
:domain-id (host-domain-id host)
:name host
:type "A"
:content v4ip)))
(insert-dao new-a-record)))))
(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)))
(defclass request ()
((sender :initarg :sender)))
(defclass change-request-ipv4 (request)
((hostname :initarg :hostname)
(ip-address :initarg :ip-address)))
(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))
(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 from)
(trivia:match (first message)
((list "CHANGE-REQUEST-IPV4" ip)
(make-instance 'change-request-ipv4
:sender from
:hostname (sender-hostname from)
:ip-address ip))
((list* message) (make-error
(format nil "unknown or bad operation: ~a" message)))))
(defgeneric handle-message (message))
(defmethod handle-message ((message change-request-ipv4))
(with-slots (hostname ip-address) message
(handler-case
(set-host-v4ip hostname ip-address)
(error (text)
(make-error (format nil "unknown error setting host v4ip: ~A"
text))))))
(defmethod xmpp:handle ((conn xmpp:connection) (message xmpp:message))
(xmpp:message conn
(xmpp:from message)
(-> message
(xmpp:body)
(split-string)
(parse-message (xmpp:from message))
(handle-message)
(render-result))))
(defun with-backplane (xmpp-host xmpp-username xmpp-password f)
(let ((backplane (xmpp-connect xmpp-host xmpp-username xmpp-password)))
(funcall f backplane)))
(defun dns-backplane-listen (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 t)
(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-dns-backplane-listener-with-env ()
(dns-backplane-listen
(getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_HOSTNAME" "backplane.fudo.org")
(getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_USERNAME" "dns")
(read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_PASSWORD_FILE"))
(getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_NAME" "pdns")
(getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_USERNAME" "dns_backplane")
(getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_HOSTNAME")
(read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_PASSWORD_FILE"))))

13
package.lisp Normal file
View File

@ -0,0 +1,13 @@
;;;; package.lisp
(defpackage #:dns-backplane
(:use #:cl)
(:import-from #:arrows
#:->
#:some->)
(:import-from #:alexandria
#:if-let)
(:import-from #:postmodern
#:get-dao
#:update-dao
#:insert-dao))