Added support for sshfp
This commit is contained in:
parent
f843cb6a90
commit
c571c20cb4
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue