Refactored for testability.
Factored out storage into a separate package, and added tests.
This commit is contained in:
parent
3aad2b6a87
commit
fdb04c90f1
|
|
@ -0,0 +1,142 @@
|
|||
|
||||
(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 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 (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 (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)))
|
||||
|
|
@ -3,15 +3,40 @@
|
|||
(asdf:defsystem #:backplane-dns
|
||||
:description "Server to listen on Fudo backplane for DNS updates"
|
||||
:author "Niten <niten@fudo.org>"
|
||||
:license "Specify license here"
|
||||
:version "0.1.0"
|
||||
:serial t
|
||||
:depends-on (:alexandria
|
||||
:arrows
|
||||
:backplane-dns-store
|
||||
:backplane-server
|
||||
:cl-ppcre)
|
||||
:components ((:file "package")
|
||||
(:file "backplane-dns"))
|
||||
:in-order-to ((test-op (test-op :backplane-dns/test))))
|
||||
|
||||
(asdf:defsystem #:backplane-dns-store
|
||||
:description "Storage for Fudo DNS backplane"
|
||||
:author "Niten <niten@fudo.org>"
|
||||
:version "0.1.0"
|
||||
:serial t
|
||||
:depends-on (:alexandria
|
||||
:arrows
|
||||
:cl-ppcre
|
||||
:ip-utils
|
||||
:postmodern
|
||||
:trivia)
|
||||
:postmodern)
|
||||
:components ((:file "package")
|
||||
(:file "backplane-dns")))
|
||||
(:file "backplane-dns-store")))
|
||||
|
||||
(asdf:defsystem #:backplane-dns/test
|
||||
:description "XMPP Backplane DNS Server Tests"
|
||||
:author "Niten <niten@fudo.org>"
|
||||
:depends-on (:arrows
|
||||
:backplane-dns
|
||||
:ip-utils
|
||||
:prove)
|
||||
:defsystem-depends-on (:prove-asdf)
|
||||
:components ((:module "test"
|
||||
:serial t
|
||||
:components ((:test-file "backplane-dns-test"))))
|
||||
:perform (asdf:test-op (op c)
|
||||
(uiop:symbol-call :prove '#:run '#:backplane-dns/test)))
|
||||
|
|
|
|||
|
|
@ -2,21 +2,15 @@
|
|||
|
||||
(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)))
|
||||
(defvar *dns-store* nil)
|
||||
|
||||
(defun symbolize (str) (-> str string-upcase (intern :KEYWORD)))
|
||||
|
||||
(defclass dns-request ()
|
||||
((hostname :initarg :hostname)
|
||||
(domain :initarg :domain)
|
||||
(sender :initarg :sender)
|
||||
(msg-id :initarg :msg-id)))
|
||||
(msg-id :initarg :msg-id
|
||||
:reader msg-id)))
|
||||
|
||||
(defclass request-change-ipv4 (dns-request)
|
||||
((ip-address :initarg :ip-address)))
|
||||
|
|
@ -28,139 +22,17 @@
|
|||
((sshfp :initarg :sshfp)))
|
||||
|
||||
(defclass unknown-dns-request (dns-request)
|
||||
((request-type :initarg :request-type)))
|
||||
|
||||
(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))
|
||||
((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])")
|
||||
|
||||
(defun get-domain (name)
|
||||
(car (select-dao 'dns-domain (:= 'name name))))
|
||||
(define-condition backplane-dns-error (error)
|
||||
((msg :initarg :msg :initform nil :reader error-msg)))
|
||||
|
||||
(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))
|
||||
(define-condition invalid-hostname (backplane-dns-error)
|
||||
((hostname :initarg :hostname :reader invalid-hostname)))
|
||||
|
||||
(let ((hostname-extractor-rx
|
||||
(cl-ppcre:create-scanner
|
||||
|
|
@ -169,79 +41,73 @@
|
|||
#\@
|
||||
(:REGEX ,*hostname-rx*) :END-ANCHOR))))
|
||||
(defun sender-hostname (sender)
|
||||
(cl-ppcre:register-groups-bind (hostname nil)
|
||||
(if-let ((hostname (cl-ppcre:register-groups-bind (extracted-hostname nil)
|
||||
(hostname-extractor-rx sender)
|
||||
hostname)))
|
||||
|
||||
(defmethod backplane-server:handle-message ((message request-change-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"
|
||||
extracted-hostname)))
|
||||
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))))))
|
||||
(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 request-change-ipv4))
|
||||
(with-slots (hostname domain ip-address msg-id) message
|
||||
(defmethod backplane-server:handle-message ((message dns-request))
|
||||
(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))
|
||||
(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))
|
||||
(error (text)
|
||||
(make-error :msg (format nil "unknown error setting host v4ip: ~A"
|
||||
text)
|
||||
:msg-id msg-id)))))
|
||||
: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)))))
|
||||
|
||||
(defmethod backplane-server:handle-message ((message request-change-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 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
|
||||
:sender sender
|
||||
:hostname (sender-hostname sender)
|
||||
:domain (cdr (assoc :DOMAIN message))
|
||||
:ip-address (cdr (assoc :IP message))
|
||||
|
|
@ -249,7 +115,6 @@
|
|||
|
||||
(defmethod parse-dns-message (sender (request (eql :CHANGE_IPV6)) message msg-id)
|
||||
(make-instance 'request-change-ipv6
|
||||
:sender sender
|
||||
:hostname (sender-hostname sender)
|
||||
:domain (cdr (assoc :DOMAIN message))
|
||||
:ip-address (cdr (assoc :IP message))
|
||||
|
|
@ -257,21 +122,30 @@
|
|||
|
||||
(defmethod parse-dns-message (sender (request (eql :CHANGE_SSHFP)) message msg-id)
|
||||
(make-instance 'request-change-sshfp
|
||||
:sender sender
|
||||
: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-request
|
||||
:sender sender
|
||||
(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
|
||||
|
|
@ -281,10 +155,11 @@
|
|||
db-username
|
||||
db-password)
|
||||
(let ((postmodern:*ignore-unknown-columns* t)
|
||||
(cl-postgres:*query-log* *standard-output*))
|
||||
(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)
|
||||
(with-backplane (backplane (backplane-connect xmpp-host xmpp-username xmpp-password))
|
||||
(xmpp:receive-stanza-loop backplane)))))
|
||||
(start-listening backplane)))))
|
||||
|
||||
(defun read-file-line (filename)
|
||||
(let ((input (open filename :if-does-not-exist nil)))
|
||||
|
|
@ -292,6 +167,14 @@
|
|||
(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")
|
||||
|
|
|
|||
38
package.lisp
38
package.lisp
|
|
@ -12,18 +12,48 @@
|
|||
#:backplane-connect
|
||||
#:make-error
|
||||
#:make-success
|
||||
#:start-listening
|
||||
#:with-backplane)
|
||||
(:import-from #:backplane-dns-store
|
||||
#:invalid-sshfp
|
||||
#:missing-domain
|
||||
#:invalid-ip
|
||||
#:domain-name-missing
|
||||
#:error-msg)
|
||||
|
||||
(:export #:start-listener-with-env
|
||||
#:backplane-dns-listen
|
||||
#:parse-message
|
||||
#:handle-message
|
||||
#:unknown-dns-request
|
||||
#:request-change-ipv4
|
||||
#:request-change-ipv6
|
||||
#:request-change-sshfp
|
||||
#:*dns-store*))
|
||||
|
||||
(defpackage #:backplane-dns-store
|
||||
(:use #:cl)
|
||||
|
||||
(:import-from #:arrows #:->)
|
||||
(:import-from #:alexandria #:if-let)
|
||||
(:import-from #:ip-utils
|
||||
#:ipv4-p
|
||||
#:ipv6-p)
|
||||
(:import-from #:postmodern
|
||||
#:get-dao
|
||||
#:select-dao
|
||||
#:update-dao
|
||||
#:insert-dao
|
||||
#:delete-dao
|
||||
#:with-transaction)
|
||||
|
||||
(:export #:start-listener-with-env
|
||||
#:backplane-dns-listen
|
||||
#:parse-message))
|
||||
(:export #:set-ipv4
|
||||
#:set-ipv6
|
||||
#:set-sshfp
|
||||
#:postgres-dns-store
|
||||
#:invalid-ip
|
||||
#:invalid-sshfp
|
||||
#:domain-name-missing
|
||||
#:missing-domain
|
||||
#:dns-store
|
||||
#:sshfp-p
|
||||
#:error-msg))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,161 @@
|
|||
;;;; backplane-dns-test.lisp
|
||||
|
||||
(defpackage #:backplane-dns/test
|
||||
(:use #:cl
|
||||
#:backplane-dns
|
||||
#:prove)
|
||||
(:import-from #:arrows
|
||||
#:->)
|
||||
(:import-from #:ip-utils
|
||||
#:ipv4-p #:ipv6-p))
|
||||
|
||||
(in-package #:backplane-dns/test)
|
||||
|
||||
(plan 20)
|
||||
|
||||
(defun ipv4-body (ip &key (domain "test.org"))
|
||||
`((:REQUEST . "change_ipv4")
|
||||
(:DOMAIN . ,domain)
|
||||
(:IP . ,ip)))
|
||||
|
||||
(defun ipv6-body (ip &key (domain "test.org"))
|
||||
`((:REQUEST . "change_ipv6")
|
||||
(:DOMAIN . ,domain)
|
||||
(:IP . ,ip)))
|
||||
|
||||
(defun sshfp-body (sshfps &key (domain "test.org"))
|
||||
`((:REQUEST . "change_sshfp")
|
||||
(:DOMAIN . ,domain)
|
||||
(:SSHFP . ,sshfps)))
|
||||
|
||||
(defun parse-request (body &key
|
||||
(sender "host-tester@backplane.test")
|
||||
(api-version "1")
|
||||
(msg-id "1"))
|
||||
(backplane-server:parse-message sender :DNS api-version body msg-id))
|
||||
|
||||
(is-type (parse-request '())
|
||||
'backplane-dns:unknown-dns-request)
|
||||
|
||||
(is-type (parse-request '((:REQUEST . "oops")))
|
||||
'backplane-dns:unknown-dns-request)
|
||||
|
||||
(is-type (parse-request (ipv4-body "1.1.1.1"))
|
||||
'backplane-dns:request-change-ipv4)
|
||||
|
||||
(is-type (parse-request (ipv6-body "a::3"))
|
||||
'backplane-dns:request-change-ipv6)
|
||||
|
||||
(is-type (parse-request (sshfp-body (list "123")))
|
||||
'backplane-dns:request-change-sshfp)
|
||||
|
||||
(defclass simple-test-store (backplane-dns-store:dns-store)
|
||||
((ops :initform '() :reader ops)))
|
||||
|
||||
(defmethod backplane-dns-store:set-ipv4 ((store simple-test-store) domain name ip)
|
||||
(with-slots (ops) store
|
||||
(setf ops (cons (cons :set-ipv4 ip) ops))
|
||||
t))
|
||||
|
||||
(defmethod backplane-dns-store:set-ipv6 ((store simple-test-store) domain name ip)
|
||||
(with-slots (ops) store
|
||||
(setf ops (cons (cons :set-ipv6 ip) ops))
|
||||
t))
|
||||
|
||||
(defmethod backplane-dns-store:set-sshfp ((store simple-test-store) domain name sshfp)
|
||||
(with-slots (ops) store
|
||||
(setf ops (cons (cons :set-sshfp sshfp) ops))
|
||||
t))
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'simple-test-store)))
|
||||
(backplane-server:handle-message (parse-request (ipv4-body "1.1.1.1"))))
|
||||
'backplane-server:result/success)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'simple-test-store)))
|
||||
(backplane-server:handle-message (parse-request (ipv6-body "1:1::1"))))
|
||||
'backplane-server:result/success)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'simple-test-store)))
|
||||
(backplane-server:handle-message (parse-request (sshfp-body '("fake-key")))))
|
||||
'backplane-server:result/success)
|
||||
|
||||
(let ((backplane-dns:*dns-store* (make-instance 'simple-test-store))
|
||||
(ip "1.1.1.1"))
|
||||
(is (progn (backplane-server:handle-message (parse-request (ipv4-body ip)))
|
||||
(car (ops backplane-dns:*dns-store*)))
|
||||
(cons :set-ipv4 ip)))
|
||||
|
||||
(let ((backplane-dns:*dns-store* (make-instance 'simple-test-store))
|
||||
(ip "aa::1"))
|
||||
(is (progn (backplane-server:handle-message (parse-request (ipv6-body ip)))
|
||||
(car (ops backplane-dns:*dns-store*)))
|
||||
(cons :set-ipv6 ip)))
|
||||
|
||||
(let ((backplane-dns:*dns-store* (make-instance 'simple-test-store))
|
||||
(sshfp '("1 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))
|
||||
(is (progn (backplane-server:handle-message (parse-request (sshfp-body sshfp)))
|
||||
(car (ops backplane-dns:*dns-store*)))
|
||||
(cons :set-sshfp sshfp)))
|
||||
|
||||
(defclass verifying-test-store (backplane-dns-store:dns-store)
|
||||
((ops :initform '() :reader ops)))
|
||||
|
||||
(defmethod backplane-dns-store:set-ipv4 ((store verifying-test-store) domain name ip)
|
||||
(if (not (ipv4-p ip))
|
||||
(error 'backplane-dns-store:invalid-ip
|
||||
:msg "invalid ipv4")
|
||||
(with-slots (ops) store
|
||||
(setf ops (cons (cons :set-ipv4 ip) ops))
|
||||
t)))
|
||||
|
||||
(defmethod backplane-dns-store:set-ipv6 ((store verifying-test-store) domain name ip)
|
||||
(if (not (ipv6-p ip))
|
||||
(error 'backplane-dns-store:invalid-ip
|
||||
:msg "invalid ipv6")
|
||||
(with-slots (ops) store
|
||||
(setf ops (cons (cons :set-ipv6 ip) ops))
|
||||
t)))
|
||||
|
||||
(defmethod backplane-dns-store:set-sshfp ((store verifying-test-store) domain name sshfp)
|
||||
(let ((new-sshfp (mapcar #'backplane-dns-store:sshfp-p sshfp)))
|
||||
(with-slots (ops) store
|
||||
(setf ops (cons (cons :set-sshfp new-sshfp) ops))
|
||||
t)))
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (ipv4-body "1.1.1.1"))))
|
||||
'backplane-server:result/success)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (ipv6-body "1:1::1"))))
|
||||
'backplane-server:result/success)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (sshfp-body '("1 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
|
||||
'backplane-server:result/success)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (ipv4-body "1.1:1.1"))))
|
||||
'backplane-server:result/error)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (ipv6-body "1:1.:1"))))
|
||||
'backplane-server:result/error)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (sshfp-body '("oops")))))
|
||||
'backplane-server:result/error)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (sshfp-body '("1 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
|
||||
'backplane-server:result/error)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (sshfp-body '("10 2 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
|
||||
'backplane-server:result/error)
|
||||
|
||||
(is-type (let ((backplane-dns:*dns-store* (make-instance 'verifying-test-store)))
|
||||
(backplane-server:handle-message (parse-request (sshfp-body '("1 0 aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")))))
|
||||
'backplane-server:result/error)
|
||||
|
||||
(finalize)
|
||||
Loading…
Reference in New Issue