backplane-dns/backplane-dns-store.lisp

(in-package #:backplane-dns-store)

(defclass dns-store () ())

;; This seems silly since it's empty, but it enables testing
(defclass postgres-dns-store (dns-store) ())

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

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

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

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

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

(defun get-domain (domain)
  (if-let ((domain (select-dao 'dns-domain (:= 'name domain))))
    domain
    (error 'domain-name-missing :domain domain)))

(defun get-records (domain name type)
  (let ((domain-id (domain-id (get-domain domain))))
    (select-dao 'dns-record (:and (:= 'domain-id domain-id)
                                  (:= 'name      (format nil "~A.~A" name domain))
                                  (:= 'type      type)))))

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

(defun insert-record (domain name type content)
  (let ((domain-id (domain-id (get-domain domain))))
    (insert-dao (make-instance 'dns-record
                             :domain-id domain-id
                             :name      (format nil "~A.~A" name domain)
                             :type      type
                             :content   content))
    t))

(defun insert-or-update-record (domain name type content)
  (if-let ((record (car (get-records domain name type))))
    (update-record-content record content)
    (insert-record domain name type content)))

(defun replace-records (domain name type contents)
  (let ((records (get-records domain name type)))
    (if (set-difference contents (mapcar #'record-content records))
        (with-transaction ()
          (dolist (record records)
            (delete-dao record))
          (dolist (content contents)
            (insert-record domain name type content)))
        t)))

(defgeneric set-ipv4 (store domain name ip))
(defgeneric set-ipv6 (store domain name ip))
(defgeneric set-sshfp (store domain name sshfp))

(defmethod set-ipv4 ((store postgres-dns-store)
                     (domain string)
                     (name   string)
                     (ip     string))
  (if (ipv4-p ip)
      (insert-or-update-record domain name "A" ip)
      (error :invalid-ip ip
             :msg        (format nil "not a valid v4 ip: ~A" ip))))

(defmethod set-ipv6 ((store  postgres-dns-store)
                     (domain string)
                     (name   string)
                     (ip     string))
  (if (ipv6-p ip)
      (insert-or-update-record domain name "AAAA" ip)
      (error :invalid-ip ip
             :msg        (format nil "not a valid v6 ip: ~A" ip))))

(defun sshfp-p (sshfp)
  (let ((els (split-sequence:split-sequence #\Space 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
            (error 'invalid-sshfp :sshfp sshfp)))))

(defmethod set-sshfp ((store postgres-dns-store)
                      (domain string)
                      (name   string)
                      (sshfps list))
  (if-let ((new-sshfps (mapcar #'sshfp-p sshfps)))
    (replace-records domain name "SSHFP" new-sshfps)))