Added support for sshfp

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

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)