backplane-dns/backplane-dns.lisp

;;;; backplane-dns.lisp

(in-package #:backplane-dns)

(defvar *dns-store* nil)

(defun symbolize (str) (-> str string-upcase (intern :KEYWORD)))

(defclass dns-request ()
  ((hostname :initarg :hostname)
   (domain   :initarg :domain)
   (msg-id   :initarg :msg-id
             :reader  msg-id)))

(defclass request-change-ipv4 (dns-request)
  ((ip-address :initarg :ip-address)))

(defclass request-change-ipv6 (dns-request)
  ((ip-address :initarg :ip-address)))

(defclass request-change-sshfp (dns-request)
  ((sshfp      :initarg :sshfp)))

(defclass unknown-dns-request (dns-request)
  ((request-type :initarg :request-type
                 :reader  request-type)))

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

(define-condition backplane-dns-error (error)
  ((msg :initarg :msg :initform nil :reader error-msg)))

(define-condition invalid-hostname (backplane-dns-error)
  ((hostname :initarg :hostname :reader invalid-hostname)))

(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)
    (if-let ((hostname (cl-ppcre:register-groups-bind (extracted-hostname nil)
                           (hostname-extractor-rx sender)
                         extracted-hostname)))
      hostname
      (error 'invalid-hostname
             :hostname sender
             :msg (format nil "unable to extract hostname from ~A, expecting format host-<hostname>"
                          sender)))))

(defmethod backplane-server:handle-message ((message dns-request))
  (handler-case
      (if-let ((store *dns-store*))
        (-> message
            (handle-dns-message store)
            (handle-dns-response (msg-id message)))
        (make-error :msg "dns store is not initialized"
                    :msg-id (msg-id message)))      
    (domain-name-missing (err)
      (make-error :msg (format nil "missing domain name: ~A"
                               (missing-domain err))
                  :msg-id (msg-id message)))
    (invalid-ip (err)
      (make-error :msg (error-msg err)
                  :msg-id (msg-id message)))
    (invalid-sshfp (err)
      (make-error :msg (format nil "invalid ssh fingerprint: ~A"
                               (invalid-sshfp err))
                  :msg-id (msg-id message)))
    (error (e)
      (declare (ignorable e))
      (make-error :msg (format nil "an unknown error occurred: ~A"
                               e) 
                  :msg-id (msg-id message)))))

(defgeneric handle-dns-message (message store))

(defmethod handle-dns-message ((message request-change-ipv4) store)
  (with-slots (hostname domain ip-address) message
    (backplane-dns-store:set-ipv4 store domain hostname ip-address)
    (make-instance 'dns-success
                   :msg (format nil "successfully set ipv4 for ~A.~A to ~A"
                                hostname domain ip-address))))

(defmethod handle-dns-message ((message request-change-ipv6) store)
  (with-slots (hostname domain ip-address) message
    (backplane-dns-store:set-ipv6 store domain hostname ip-address)
    (make-instance 'dns-success
                   :msg (format nil "successfully set ipv6 for ~A.~A to ~A"
                                hostname domain ip-address))))

(defmethod handle-dns-message ((message request-change-sshfp) store)
  (with-slots (hostname domain sshfp) message
    (backplane-dns-store:set-sshfp store domain hostname sshfp)
    (make-instance 'dns-success
                   :msg (format nil "successfully set sshfps for ~A.~A"
                                hostname domain))))

(defmethod handle-dns-message ((message unknown-dns-request) store)
  (make-instance 'dns-error
                 :msg (format nil "unknown request to the dns service: ~A"
                              (request-type message))))

(defgeneric parse-dns-message (sender request message msg-id)
  (:documentation "Parse a DNS service message of type REQUEST"))

(defmethod parse-dns-message (sender (request (eql :CHANGE_IPV4)) message msg-id)
  (make-instance 'request-change-ipv4
                 :hostname   (sender-hostname sender)
                 :domain     (cdr (assoc :DOMAIN message))
                 :ip-address (cdr (assoc :IP message))
                 :msg-id     msg-id))

(defmethod parse-dns-message (sender (request (eql :CHANGE_IPV6)) message msg-id)
  (make-instance 'request-change-ipv6
                 :hostname   (sender-hostname sender)
                 :domain     (cdr (assoc :DOMAIN message))
                 :ip-address (cdr (assoc :IP message))
                 :msg-id     msg-id))

(defmethod parse-dns-message (sender (request (eql :CHANGE_SSHFP)) message msg-id)
  (make-instance 'request-change-sshfp
                 :hostname   (sender-hostname sender)
                 :domain     (cdr (assoc :DOMAIN message))
                 :sshfp      (cdr (assoc :SSHFP message))
                 :msg-id     msg-id))

(defmethod parse-dns-message (sender request message msg-id)
  (make-instance 'unknown-dns-request
                 :request-type request
                 :msg-id       msg-id))

(defmethod backplane-server:parse-message (sender (service (eql :DNS)) api-version message msg-id)
  (parse-dns-message sender (symbolize (cdr (assoc :REQUEST message))) message msg-id))

(defclass dns-response ()
  ((msg :initarg :msg :reader msg)))
(defclass dns-success (dns-response) ())
(defclass dns-error (dns-response) ())

(defgeneric handle-dns-response (resp msg-id))
(defmethod handle-dns-response ((resp dns-success) msg-id)
  (make-success :msg (msg resp) :msg-id msg-id))
(defmethod handle-dns-response ((resp dns-error) msg-id)
  (make-error :msg (msg resp) :msg-id msg-id))

(defun backplane-dns-listen (&key
                               xmpp-host
                               xmpp-username
                               xmpp-password
                               db-host
                               db-port
                               db-name
                               db-username
                               db-password
                               db-use-ssl)
  (format t "Got XMPP password: ~A" xmpp-password)
  (let ((postmodern:*ignore-unknown-columns* t)
        (cl-postgres:*query-log* *standard-output*)
        (*dns-store* (make-instance 'backplane-dns-store:postgres-dns-store)))
    (postmodern:with-connection (list db-name db-username db-password db-host
                                      :port db-port
                                      :use-ssl (symbolize db-use-ssl))
      (with-backplane (backplane (backplane-connect xmpp-host xmpp-username xmpp-password))
        (start-listening backplane)))))

(defun read-file-line (filename)
  (let ((input (open filename :if-does-not-exist nil)))
    (if input
        (read-line input)
        (uiop:die 1 "unable to read file: ~A" filename))))

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

(defun start-listener-with-env ()
  (backplane-dns-listen
   :xmpp-host     (getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_HOSTNAME")
   :xmpp-username (getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_USERNAME")
   :xmpp-password (read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_XMPP_PASSWORD_FILE"))

   :db-name       (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_NAME")
   :db-username   (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_USERNAME")
   :db-host       (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_HOSTNAME")
   :db-port       (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_PORT" 5432)
   :db-password   (read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_PASSWORD_FILE"))
   :db-use-ssl    (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_USE_SSL" "no")))