From c571c20cb42641c9117886f4f6dc690ee4ab29ef Mon Sep 17 00:00:00 2001
From: Niten <niten@fudo.org>
Date: Tue, 17 Nov 2020 14:27:19 -0800
Subject: [PATCH] Added support for sshfp
---
backplane-dns.lisp | 152 +++++++++++++++++++++++++++++++++++++++++++--
package.lisp | 4 +-
2 files changed, 150 insertions(+), 6 deletions(-)
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)