X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=dns.lisp;h=41032daecd400dabbfb012e74c9d5d1320d8d1bf;hp=4a5d7d100c9c223942d046621c3947770af6de1d;hb=HEAD;hpb=28d289c536e8f06866016dcbdd94ea7cea24244d diff --git a/dns.lisp b/dns.lisp index 4a5d7d1..41032da 100644 --- a/dns.lisp +++ b/dns.lisp @@ -39,7 +39,8 @@ `(progn (defclass ,name (resource-record) ,slot-desc) (setf *rr-coding-types* (cons '(,name (,class ,type) ,format) - (remove ',name *rr-coding-types* :key #'car)))))) + (remove ',name *rr-coding-types* :key #'car))) + (export '(,name))))) (define-rr-type a-record #x1 #x1 ((address ipv4-address))) @@ -69,6 +70,8 @@ (port uint-16) (host-name domain-name))) +(export '(resource-record)) + ;;; Packet decoding logic (defstruct dns-decode-state @@ -76,7 +79,7 @@ (pos 0 :type (mod 65536)) (prev-names '() :type list)) -(define-condition dns-error (error) ()) +(define-condition dns-error (network-error) ()) (define-condition dns-decode-error (dns-error) ((packet :initarg :packet))) (define-condition simple-dns-decode-error (dns-decode-error simple-error) ()) @@ -137,7 +140,7 @@ (decoded (append (list label) (decode-label)))) (push (cons orig-off decoded) (slot-value buf 'prev-names)) decoded)))) - ((3) (let* ((offset (+ (* 256 (ldb (byte 0 6) len)) + ((3) (let* ((offset (+ (* 256 (ldb (byte 6 0) len)) (decode-uint-8 buf))) (prev (assoc offset (dns-decode-state-prev-names buf)))) (unless prev @@ -289,7 +292,7 @@ (push (cons name (length packet-buf)) prev-names)) (let ((encoded (charcode:encode-string (car name) :ascii))) (unless (< (length encoded) 64) - (error "DNS labels cannot exceed 63 octets in length: ~S" (car name))) + (simple-dns-decode-error buf "DNS labels cannot exceed 63 octets in length: ~S" (car name))) (encode-uint-8 buf (length encoded)) (encode-bytes buf encoded)) (encode-label (cdr name))))))) @@ -325,7 +328,7 @@ (string (charcode:encode-string val :ascii)) ((array (unsigned-byte 8)) val)))) (unless (< (length data) 256) - (error "DNS text data length cannot exceed 255 octets.")) + (simple-dns-decode-error buf "DNS text data length cannot exceed 255 octets.")) (encode-uint-8 buf (length data)) (encode-bytes buf data))) ((ipv4-address) @@ -407,6 +410,9 @@ ;;; Basic communication +(define-condition name-server-timeout (dns-error) + ((server :initarg :server))) + (defun dns-do-request (server packet) (declare (type address server) (type dns-packet packet)) @@ -435,26 +441,28 @@ ;;; RR caching (defstruct domain-cache-entry - (time (get-internal-real-time) :type unsigned-byte) + (expire nil :type (or number null)) (records '() :type list)) +(defun domain-cache-key (name type) + (list name (etypecase type + (symbol type) + (resource-record (class-name (class-of type)))))) + +(defun domain-cache-key-rr (record) + (declare (type resource-record record)) + (list (slot-value record 'name) (class-name (class-of record)))) + (defun domain-cache-get-entry (cache name type &optional create) - (let* ((key (list name (etypecase type - (symbol type) - (resource-record (class-name (class-of type)))))) + (let* ((key (domain-cache-key name type)) (cur (gethash key cache))) - (block no-expire - (when (and cur (domain-cache-entry-records cur) - (> (get-internal-real-time) - (+ (domain-cache-entry-time cur) - (apply 'min (mapcar #'(lambda (o) - (declare (type resource-record o)) - (with-slots (ttl) o - (unless ttl (return-from no-expire)) - ttl)) - (domain-cache-entry-records cur)))))) - (remhash key cache) - (setf cur nil))) + (when (and cur (or (eq create :clear) + (let ((expire (domain-cache-entry-expire cur))) + (and expire + (> (/ (get-internal-real-time) internal-time-units-per-second) + expire))))) + (remhash key cache) + (setf cur nil)) (cond (cur cur) (create (setf (gethash key cache) (make-domain-cache-entry)))))) @@ -464,6 +472,45 @@ (let ((entry (domain-cache-get-entry cache name record t))) (push record (domain-cache-entry-records entry))))) +(defun dns-cache-records (cache records) + (loop (unless records (return)) + (let* ((key (domain-cache-key-rr (car records))) + (matching (remove key records :test-not 'equal :key #'domain-cache-key-rr)) + (ttl (block no-expire + (+ (/ (get-internal-real-time) internal-time-units-per-second) + (apply 'min (mapcar #'(lambda (rr) + (with-slots (ttl) rr + (if ttl ttl (return-from no-expire nil)))) + matching))))) + (entry (make-domain-cache-entry :expire ttl :records matching))) + (setf (gethash key cache) entry + records (set-difference records matching))))) + +(defun dns-cache-response (cache packet) + (let ((records (append (dns-packet-answers packet) + (dns-packet-authority packet) + (dns-packet-additional packet)))) + (flet ((on-root (rr) + (equal (slot-value rr 'name) '()))) + (when (some #'on-root records) + (warn "DNS packet purports to contain RRs on the root zone.") + (setf records (delete-if #'on-root records)))) + (when (dns-packet-authoritative packet) + (dolist (rq (dns-packet-queries packet)) + (with-slots (name type) rq + (unless (equal name '()) + (let ((key (domain-cache-key name type))) + (unless (find key records :test 'equal :key #'domain-cache-key-rr) + (let ((entry (domain-cache-get-entry cache name type :clear))) + (setf (domain-cache-entry-expire entry) + (+ (/ (get-internal-real-time) internal-time-units-per-second) + 60))))))))) ; XXX: Or something. It needs + ; to last for the query in + ; progress, at least. One + ; should probably look at an + ; SOA RR, if there is one. + (dns-cache-records cache records))) + (defun make-domain-cache () (let ((table (make-hash-table :test 'equal))) (dolist (server (labels ((ipv4 (address) @@ -483,6 +530,12 @@ ("m.root-servers.net" ,(ipv4 "202.12.27.33"))))) (let ((parsed (parse-domain-name (first server)))) (domain-cache-put table (make-instance 'ns-record :name '() :ttl nil :ns-name parsed)) + ;; Ensure that the cache is initialized at least with empty + ;; lists, so that the resolver doesn't try to resolve the root + ;; servers. + (domain-cache-get-entry table parsed 'a-record t) + (domain-cache-get-entry table parsed 'aaaa-record t) + (dolist (address (cdr server)) (domain-cache-put table (etypecase address (ipv4-host-address (make-instance 'a-record :name parsed :ttl nil :address address))))))) @@ -532,9 +585,138 @@ cfg)))) #-unix nil) -(defvar *resolver-config* (initialize-default-resolver)) - - +(defvar *dns-resolver-config* (initialize-default-resolver)) + +(defgeneric dns-server-address-for-record (record)) +(defmethod dns-server-address-for-record ((record a-record)) + (make-instance 'udp4-address + :host-address (slot-value record 'address) + :port 53)) +(defmethod dns-server-address-for-record ((record aaaa-record)) + (make-instance 'udp6-address + :host-address (slot-value record 'address) + :port 53)) + +(define-condition dns-resolver-condition (condition) + ((query-name :initarg :query-name) + (query-type :initarg :query-type) + (config :initarg :config))) + +(define-condition dns-resolver-error (dns-error dns-resolver-condition) ()) +(define-condition domain-not-found-error (dns-resolver-error) () + (:report (lambda (c s) + (with-slots (query-name) c + (format s "No name servers found for domain name ~A." query-name))))) +(define-condition dns-name-error (dns-error dns-resolver-condition) () + (:report (lambda (c s) + (with-slots (query-name) c + (format s "The domain name ~A does not exist." query-name))))) + +(define-condition dns-resolver-querying (dns-resolver-condition) + ((server :initarg :server))) + +(define-condition dns-resolver-got-resp (dns-resolver-condition) + ((server :initarg :server) + (response :initarg :response))) + +(define-condition dns-resolver-help (dns-resolver-condition) ()) +(define-condition dns-resolver-recursing (dns-resolver-condition) ()) + +(define-condition dns-resolver-following-cname (dns-resolver-condition) + ((cname-rr :initarg :cname-rr))) + +(defun dns-resolve-name (name types &key (require-all t) (config *dns-resolver-config*)) + (let ((name (etypecase name + (list name) + (string (parse-domain-name name)))) + (types (etypecase types + (list types) + (symbol (list types)))) + (cache (resolver-config-cache config))) + (flet ((check-cache () + (let ((cn-entry (domain-cache-get-entry cache name 'cname-record))) + (when (and cn-entry (domain-cache-entry-records cn-entry)) + (let ((record (car (domain-cache-entry-records cn-entry)))) + (signal 'dns-resolver-following-cname :cname-rr record + :query-name (unparse-domain-name name) :query-type types + :config config) + (return-from dns-resolve-name + (dns-resolve-name (slot-value record 'cname) types :config config))))) + (block skip + (let ((records '()) + (got-some nil)) + (dolist (type types) + (let ((entry (domain-cache-get-entry cache name type))) + (cond (entry + (setf records (append records (domain-cache-entry-records entry)) + got-some t)) + (require-all + (return-from skip))))) + (when got-some + (return-from dns-resolve-name (values records name)))))) + (nearest-known-servers (name) + (labels ((check1 (name) + (let ((entry (domain-cache-get-entry cache name 'ns-record))) + (cond ((and entry (domain-cache-entry-records entry)) + (values (domain-cache-entry-records entry) name)) + (name (check1 (cdr name))) + (t (values '() name)))))) + (check1 name))) + (do-request (server) + (signal 'dns-resolver-querying :server server + :query-name (unparse-domain-name name) :query-type types + :config config) + (handler-case + (let ((resp (dns-do-request (udp-address-for server 53) + (dns-std-request (mapcar #'(lambda (type) + `(,name ,type)) + types))))) + (signal 'dns-resolver-got-resp :server server :response resp + :query-name (unparse-domain-name name) :query-type types + :config config) + (dns-cache-response cache resp) + (with-slots (resp-code) resp + (when (eq (dns-packet-resp-code resp) :name-error) + (error 'dns-name-error :query-name (unparse-domain-name name) :query-type types + :config config)) + (eq resp-code :success))) + (network-error () nil)))) + (check-cache) + (signal 'dns-resolver-help :query-name (unparse-domain-name name) :query-type types + :config config) + (dolist (help-server (resolver-config-help-servers config)) + (do-request help-server) + (check-cache)) + (signal 'dns-resolver-recursing :query-name (unparse-domain-name name) :query-type types + :config config) + (let ((checked-domains '())) + (loop (multiple-value-bind (servers domain) + (nearest-known-servers name) + (unless servers + (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types + :config config)) + (if (find domain checked-domains :test 'equal) + (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types + :config config) + (push domain checked-domains)) + (macrolet ((dolist-random ((var list) &body body) + (let ((copy (gensym "COPY"))) + `(let ((,copy ,list)) + (loop (unless ,copy (return)) + (let ((,var (elt ,list (random (length ,list))))) + (setf ,copy (remove ,var ,copy)) + ,@body)))))) + (block found-server + (dolist-random (record servers) + (let* ((server (slot-value record 'ns-name))) + (dolist-random (record (handler-case + (dns-resolve-name server '(a-record aaaa-record) :require-all nil :config config) + (dns-resolver-error () '()))) + (when (do-request (dns-server-address-for-record record)) + (return-from found-server)))))) + (check-cache)))))))) + +(export '(*dns-resolver-config*)) ;;; Misc.