diff --git a/backplane-dns.lisp b/backplane-dns.lisp index 85109be..e579c8b 100644 --- a/backplane-dns.lisp +++ b/backplane-dns.lisp @@ -7,7 +7,7 @@ (if (null value) (if default default - (uiop:die 1 "unable to find required env var: ~a" env-var)) + (uiop:die 1 "unable to find required env var: ~A" env-var)) value))) (defclass dns-record () @@ -66,12 +66,76 @@ (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 ipv4-elements (str) + (handler-case + (mapcar #'parse-integer (split-string str #\.)) + (sb-int:simple-parse-error (_) + (declare (ignorable _)) nil))) + +(defun ipv4-p (str) + (let ((iplst (ipv4-elements str))) + (and (= (length iplst) 4) + (every (lambda (n) (<= 0 n 255)) + iplst)))) + +(defun ipv4 (str) + (if (not (ipv4-p str)) + nil + (let ((els (ipv4-elements str))) + (loop for el in (reverse els) + for i from 0 to (length els) + sum (ash el (* i 8)) into total + finally (return total))))) + +(defun ipv6-elements (str) + (flet ((split-bytes (str) (split-string str #\:)) + (parse-hex (str) (if (equal str "") 0 (parse-integer str :radix 16)))) + (let ((parts (mapcar #'split-bytes (cl-ppcre:split "::" + (cl-ppcre:regex-replace "::$" + str + "::0"))))) + (trivia:match parts + ((list only) (mapcar #'parse-hex only)) + ((list first last) (let ((middle (make-list + (- 8 (length first) + (length last)) + :initial-element "0"))) + (mapcar #'parse-hex (append first middle last)))) + (_ nil))))) + +(defun ipv6 (str) + (let ((els (ipv6-elements str))) + (if (/= 8 (length els)) + nil + (loop for el in (reverse els) + for i from 0 to (length els) + sum (ash el (* i 16)) into total + finally (return total))))) + +(defun ipv6-p (str) + (handler-case + (ipv6 str) + (sb-int:simple-parse-error (e) + (declare (ignorable e)) + nil))) + (defun get-domain (name) (car (select-dao 'dns-domain (:= 'name name)))) (define-condition domain-name-missing (error) ((missing-domain :initarg :domain :reader missing-domain))) +(define-condition invalid-ip (error) + ((ip :initarg :ip))) + +(define-condition invalid-ipv4 (invalid-ip) ()) + +(define-condition invalid-ipv6 (invalid-ip) ()) + +(define-condition invalid-sshfp (error) + ((sshfp :initarg :sshfp + :reader sshfp))) + (defun find-host-records-by-type (host domain type) (if-let ((domain-id (some-> domain (get-domain) @@ -100,10 +164,49 @@ :content content)))))) (defun set-host-v4ip (host domain v4ip) - (update-host-record-by-type host domain "A" 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) - (update-host-record-by-type host domain "AAAA" 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 'record + (:and (:= 'name full-hostname) + (:= 'domain-id domain-id) + (:= 'type "SSHFP")))) + (existing-sshfps (mapcar #'record-content sshfp-records))) + (if (not (set-difference existing-sshfps new-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)) @@ -119,13 +222,40 @@ (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" + (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)) @@ -139,9 +269,13 @@ (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" + (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)) @@ -170,6 +304,14 @@ :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)) + :sshfps (cdr (assoc :SSHFP message)))) + (defmethod parse-dns-message (sender request message msg-id) (make-instance 'unknown-request :msg-id msg-id diff --git a/package.lisp b/package.lisp index d18ac26..3897d86 100644 --- a/package.lisp +++ b/package.lisp @@ -11,7 +11,9 @@ #:get-dao #:select-dao #:update-dao - #:insert-dao) + #:insert-dao + #:delete-dao + #:with-transaction) (:import-from #:cl-json #:decode-json-from-string #:encode-json)