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

Working commit

This commit is contained in:
Niten 2020-11-11 08:59:40 -08:00
parent b65eda6228
commit a11a2fec3b
3 changed files with 74 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
*.fasl

132
dns-backplane.lisp
View File

@ -15,21 +15,6 @@
(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
@ -48,7 +33,8 @@
:initarg :content
:accessor record-content))
(:metaclass postmodern:dao-class)
(:table-name "records"))
(:table-name "records")
(:keys id))
(defclass dns-domain ()
((id :col-type integer
@ -64,37 +50,61 @@
:initarg :type
:reader domain-type))
(:metaclass postmodern:dao-class)
(:table-name domains))
(: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))
(defun get-domain (name)
(get-dao 'dns-domain :name name))
(car (select-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)
(defun host-a-record (hostname domain)
(if-let ((domain-id (some-> domain
(get-domain)
(domain-id)))
(id))))
(car (select-dao 'dns-record
(:= 'name hostname)
(:= 'domain-id domain-id)
(:= 'type "A")))
(error 'domain-name-missing :domain domain)))
(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)))
(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))
(let ((new-a-record (make-instance 'dns-record
:domain-id (host-domain-id host)
:name host
(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)))
(insert-dao new-a-record)))))
:content v4ip))))))
(defun split-string (string &optional (char #\Space))
(split-sequence:split-sequence char string))
@ -110,25 +120,6 @@
(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))
@ -143,40 +134,51 @@
(format nil "ERROR: ~A" message)
"ERROR")))
(defun parse-message (message from)
(trivia:match (first message)
(defun parse-message (message)
(let ((from (xmpp:from message)))
(trivia:match (split-string (xmpp:body message))
((list "CHANGE-REQUEST-IPV4" ip)
((list "REQUEST-CHANGE-IPV4" domain ip)
(make-instance 'change-request-ipv4
:sender from
:hostname (sender-hostname from)
:domain domain
:ip-address ip))
((list* message) (make-error
(format nil "unknown or bad operation: ~a" message)))))
(_ (make-instance 'unknown-request
:sender from
:text (xmpp:body message))))))
(defgeneric handle-message (message))
(defmethod handle-message ((message change-request-ipv4))
(with-slots (hostname ip-address) message
(with-slots (hostname domain ip-address) message
(handler-case
(set-host-v4ip hostname ip-address)
(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
(xmpp:body)
(split-string)
(parse-message (xmpp:from message))
(parse-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)))
(let ((backplane (xmpp:connect-tls :hostname xmpp-host)))
(xmpp:auth backplane
xmpp-username
xmpp-password
"server"
:mechanism :sasl-plain)
(funcall f backplane)))
(defun dns-backplane-listen (xmpp-host

1
package.lisp
View File

@ -9,5 +9,6 @@
#:if-let)
(:import-from #:postmodern
#:get-dao
#:select-dao
#:update-dao
#:insert-dao))