Initial commit
This commit is contained in:
commit
b65eda6228
|
|
@ -0,0 +1,9 @@
|
|||
# dns-backplane
|
||||
### _Your Name <your.name@example.com>_
|
||||
|
||||
This is a project to do ... something.
|
||||
|
||||
## License
|
||||
|
||||
Specify license here
|
||||
|
||||
|
|
@ -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")))
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -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))
|
||||
Loading…
Reference in New Issue