From b65eda6228ee19360f4ceeb74b3e6b6c733723d2 Mon Sep 17 00:00:00 2001 From: Niten Date: Wed, 4 Nov 2020 12:34:28 -0800 Subject: [PATCH] Initial commit --- README.md | 9 ++ dns-backplane.asd | 18 ++++ dns-backplane.lisp | 207 +++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 13 +++ 4 files changed, 247 insertions(+) create mode 100644 README.md create mode 100644 dns-backplane.asd create mode 100644 dns-backplane.lisp create mode 100644 package.lisp diff --git a/README.md b/README.md new file mode 100644 index 0000000..fe3f995 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# dns-backplane +### _Your Name _ + +This is a project to do ... something. + +## License + +Specify license here + diff --git a/dns-backplane.asd b/dns-backplane.asd new file mode 100644 index 0000000..1d2f307 --- /dev/null +++ b/dns-backplane.asd @@ -0,0 +1,18 @@ +;;;; dns-backplane.asd + +(asdf:defsystem #:dns-backplane + :description "Describe dns-backplane here" + :author "Your Name " + :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"))) diff --git a/dns-backplane.lisp b/dns-backplane.lisp new file mode 100644 index 0000000..532fbdb --- /dev/null +++ b/dns-backplane.lisp @@ -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")))) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..a6f1461 --- /dev/null +++ b/package.lisp @@ -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))