From a11a2fec3b215b5a85100161a3a060a6e20cfc14 Mon Sep 17 00:00:00 2001 From: Niten Date: Wed, 11 Nov 2020 08:59:40 -0800 Subject: [PATCH] Working commit --- .gitignore | 1 + dns-backplane.lisp | 142 +++++++++++++++++++++++---------------------- package.lisp | 1 + 3 files changed, 74 insertions(+), 70 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..be303db --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*.fasl diff --git a/dns-backplane.lisp b/dns-backplane.lisp index 532fbdb..ffb0191 100644 --- a/dns-backplane.lisp +++ b/dns-backplane.lisp @@ -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) - (get-domain) - (domain-id))) +(defun host-a-record (hostname domain) + (if-let ((domain-id (some-> domain + (get-domain) + (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) - (make-instance 'change-request-ipv4 - :sender from - :hostname (sender-hostname from) - :ip-address 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 diff --git a/package.lisp b/package.lisp index a6f1461..b40a8f3 100644 --- a/package.lisp +++ b/package.lisp @@ -9,5 +9,6 @@ #:if-let) (:import-from #:postmodern #:get-dao + #:select-dao #:update-dao #:insert-dao))