backplane-dns/dns-backplane.lisp

;;;; 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)))

(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")
  (:keys       id))

(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)
  (: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)
  (car (select-dao 'dns-domain (:= 'name name))))

(define-condition domain-name-missing (error)
  ((missing-domain :initarg :domain :reader missing-domain)))

(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 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))
        (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))))))

(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)))

(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)
  (let ((from (xmpp:from message)))
    (trivia:match (split-string (xmpp:body message))

                  ((list "REQUEST-CHANGE-IPV4" domain ip)
                   (make-instance 'change-request-ipv4
                                  :sender     from
                                  :hostname   (sender-hostname from)
                                  :domain     domain
                                  :ip-address ip))

                  (_ (make-instance 'unknown-request
                                    :sender from
                                    :text   (xmpp:body message))))))

(defgeneric handle-message (message))

(defmethod handle-message ((message change-request-ipv4))
  (with-slots (hostname domain ip-address) message
    (handler-case
        (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
                    (parse-message)
                    (handle-message)
                    (render-result))))

(defun with-backplane (xmpp-host xmpp-username xmpp-password f)
  (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
                             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"))))