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

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