Working commit

.gitignore

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

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)
+(defun host-a-record (hostname domain)
-  (some-> (host-domain host)
+  (if-let ((domain-id (some-> domain
-          (get-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)
+(defun set-host-v4ip (host domain v4ip)
-  (if-let ((domain-id (host-domain-id host)))
+  (let* ((full-hostname (format nil "~A.~A" host domain))
-    (get-dao 'dns-record :name      host
+         (a-record (host-a-record full-hostname domain)))
-                         :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
+        (if-let ((domain-id (some-> domain (get-domain) (id))))
-                                           :domain-id (host-domain-id host)
+                (insert-dao (make-instance 'dns-record
-                                           :name      host
+                                           :domain-id domain-id
+                                           :name      full-hostname
                                            :type      "A"
-                                           :content   v4ip)))
+                                           :content   v4ip))))))
-          (insert-dao new-a-record)))))
 
 (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)
+(defun parse-message (message)
-  (trivia:match (first 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
+                   (make-instance 'change-request-ipv4
-                    :sender from
+                                  :sender     from
-                    :hostname (sender-hostname from)
+                                  :hostname   (sender-hostname from)
-                    :ip-address ip))
+                                  :domain     domain
+                                  :ip-address ip))
 
-    ((list* message) (make-error
+                  (_ (make-instance 'unknown-request
-                      (format nil "unknown or bad operation: ~a" message)))))
+                                    :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)
+                    (parse-message)
-                    (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)))
+  (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

package.lisp

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