;;;; backplane-dns.lisp

(in-package #:backplane-dns)

(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 symbolize (str) (-> str string-upcase (intern :KEYWORD)))

(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 change-request-ipv4 (request)
  ((hostname   :initarg :hostname)
   (domain     :initarg :domain)
   (ip-address :initarg :ip-address)))

(defclass change-request-ipv6 (request)
  ((hostname   :initarg :hostname)
   (domain     :initarg :domain)
   (ip-address :initarg :ip-address)))

(defclass change-request-sshfp (request)
  ((hostname   :initarg :hostname)
   (domain     :initarg :domain)
   (sshfp      :initarg :sshfp)))

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

(defun get-domain (name)
  (car (select-dao 'dns-domain (:= 'name name))))

(define-condition backplane-dns-error (error) ())

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

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

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

(defun find-host-records-by-type (host domain type)
  (if-let ((domain-id (some-> domain
                              (get-domain)
                              (id))))
    (select-dao 'dns-record
        (:and (:= 'name      (format nil "~A.~A" host domain))
              (:= 'domain-id domain-id)
              (:= 'type      type)))
    (error 'domain-name-missing :domain domain)))

(defun consider-update-content (record content)
  (if (equalp (record-content record) content)
      t
      (progn (setf (record-content record) content)
             (update-dao record))))

(defun update-host-record-by-type (host domain type content)
  (let ((record (car (find-host-records-by-type host domain type))))
    (if record
        (consider-update-content record content)
        (if-let ((domain-id (some-> domain (get-domain) (id))))
          (insert-dao (make-instance 'dns-record
                                     :domain-id domain-id
                                     :name      (format nil "~A.~A" host domain)
                                     :type      type
                                     :content   content))))))

(defun set-host-v4ip (host domain v4ip)
  (if (not (ipv4-p v4ip))
      (error 'invalid-ipv4 :ip v4ip)
      (update-host-record-by-type host domain "A" v4ip)))

(defun set-host-v6ip (host domain v6ip)
  (if (not (ipv6-p v6ip))
      (error 'invalid-ipv6 :ip v6ip)
      (update-host-record-by-type host domain "AAAA" v6ip)))

(defun validate-sshfp (sshfp)
  (let ((els (split-string sshfp)))
    (if (not (= (length els) 3))
        (error 'invalid-sshfp :sshfp sshfp)
        (if (and (< 0 (parse-integer (car els)) 9)
                 (< 0 (parse-integer (cadr els)) 9)
                 (cl-ppcre:scan "^[A-Fa-f0-9]{32,256}$" (caddr els)))
            sshfp
            nil))))

(defun set-host-sshfp (host domain incoming-sshfps)
  (if-let ((domain-id (some-> domain
                              (get-domain)
                              (id))))
    (let* ((new-sshfps (mapcar #'validate-sshfp incoming-sshfps))
           (full-hostname (format nil "~A.~A" host domain))
           (sshfp-records (select-dao 'dns-record
                              (:and (:= 'name      full-hostname)
                                    (:= 'domain-id domain-id)
                                    (:= 'type      "SSHFP"))))
           (existing-sshfps (mapcar #'record-content sshfp-records)))
      (if (not (set-difference new-sshfps existing-sshfps))
          t
          (with-transaction ()
            (dolist (record sshfp-records)
              (delete-dao record))
            (dolist (sshfp new-sshfps)
              (insert-dao
               (make-instance 'dns-record
                              :domain-id domain-id
                              :name      full-hostname
                              :type      "SSHFP"
                              :content   sshfp))))))
    (error 'domain-name-missing :domain domain)))

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

(defmethod handle-message ((message change-request-sshfp))
  (with-slots (hostname domain sshfp msg-id) message
    (if (not (listp sshfp))
        (make-error :msg (format nil "expected list of sshfp records, got: ~A" sshfp)
                    :msg-id msg-id)
        (handler-case
            (progn (set-host-sshfp hostname domain sshfp)
                   (make-success :msg (format nil "set ssh fingerprints for host ~A in domain ~A"
                                              hostname domain)
                                 :msg-id msg-id))
          (invalid-sshfp (err)
            (make-error :msg (format nil "bad sshfp for host ~A: ~A"
                                     hostname
                                     (sshfp err))))
          (domain-name-missing (err)
            (make-error :msg (format nil "missing domain name: ~A"
                                     (missing-domain err))
                        :msg-id msg-id))
          (error (text)
            (make-error :msg (format nil "unknown error setting host ssh fingerprints: ~A"
                                     text)
                        :msg-id msg-id))))))

(defmethod handle-message ((message change-request-ipv4))
  (with-slots (hostname domain ip-address msg-id) message
    (handler-case
        (progn (set-host-v4ip hostname domain ip-address)
               (make-success :msg (format nil "ipv4 for host ~A in domain ~A set to ~A"
                                          hostname domain ip-address)
                             :msg-id msg-id))
      (invalid-ip (err)
        (declare (ignorable err))
        (make-error :msg (format nil "invalid ipv4: ~A" ip-address)
                    :msg-id msg-id))
      (domain-name-missing (err)
        (make-error :msg (format nil "missing domain name: ~A"
                                 (missing-domain err))
                    :msg-id msg-id))
      (error (text)
        (make-error :msg (format nil "unknown error setting host v4ip: ~A"
                                 text)
                    :msg-id msg-id)))))

(defmethod handle-message ((message change-request-ipv6))
  (with-slots (hostname domain ip-address msg-id) message
    (handler-case
        (progn (set-host-v6ip hostname domain ip-address)
               (make-success :msg (format nil "ipv6 for host ~A in domain ~A set to ~A"
                                          hostname domain ip-address)
                             :msg-id msg-id))
      (invalid-ip (err)
        (declare (ignorable err))
        (make-error :msg (format nil "invalid ipv6: ~A" ip-address)
                    :msg-id msg-id))
      (domain-name-missing (err)
        (make-error :msg (format nil "missing domain name: ~A"
                                 (missing-domain err))
                    :msg-id msg-id))
      (error (text)
        (make-error :msg (format nil "unknown error setting host v6ip: ~A"
                                 text)
                    :msg-id msg-id)))))

(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 'change-request-ipv4
                 :msg-id     msg-id
                 :sender     sender
                 :hostname   (sender-hostname sender)
                 :domain     (cdr (assoc :DOMAIN message))
                 :ip-address (cdr (assoc :IP message))))

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

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

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

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

(defun backplane-dns-listen (&key
                               xmpp-host
                               xmpp-username
                               xmpp-password
                               db-host
                               db-name
                               db-username
                               db-password)
  (let ((postmodern:*ignore-unknown-columns* t)
        (cl-postgres:*query-log* *standard-output*))
    (postmodern:with-connection (list db-name db-username db-password db-host)
      (with-backplane (backplane (backplane-connect xmpp-host xmpp-username xmpp-password))
        (xmpp:receive-stanza-loop 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 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-password   (read-file-line (getenv-or-fail "FUDO_DNS_BACKPLANE_DATABASE_PASSWORD_FILE"))))