X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=dns.lisp;h=41032daecd400dabbfb012e74c9d5d1320d8d1bf;hp=48def25bcb66cf07fbf340d93cd6721da5232722;hb=HEAD;hpb=b466cd484e1cf6b7c7a0d2fdb791a3cf40560f46 diff --git a/dns.lisp b/dns.lisp index 48def25..41032da 100644 --- a/dns.lisp +++ b/dns.lisp @@ -33,11 +33,14 @@ (car slot)) (cdr slot))) slots)) - (slot-desc (mapcar #'car slots))) + (slot-desc (mapcar #'(lambda (slot) + (let ((name (car slot))) + `(,name :initarg ,(intern (symbol-name name) (find-package :keyword))))) slots))) `(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))) @@ -67,6 +70,8 @@ (port uint-16) (host-name domain-name))) +(export '(resource-record)) + ;;; Packet decoding logic (defstruct dns-decode-state @@ -74,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) ()) @@ -135,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 @@ -287,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))))))) @@ -323,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) @@ -403,6 +408,316 @@ (concatenate 'string buf "." label) label))))) +;;; 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)) + (with-connection (sk server) + (socket-send sk (dns-encode packet)) + (loop + (let ((resp (dns-decode (socket-recv sk)))) + (when (= (dns-packet-txid resp) + (dns-packet-txid packet)) + (return resp)))))) + +(defun dns-std-request (queries &key (txid (random 65536)) (recurse t)) + (let ((qlist (map 'list #'(lambda (o) + (let ((name (first o)) + (type (second o))) + (make-instance 'resource-query + :name (etypecase name + (string (parse-domain-name name)) + (list name)) + :type type))) + queries))) + (make-dns-packet :txid txid + :recurse recurse + :queries qlist))) + +;;; RR caching + +(defstruct domain-cache-entry + (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 (domain-cache-key name type)) + (cur (gethash key cache))) + (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)))))) + +(defun domain-cache-put (cache record) + (with-slots (name ttl) record + (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) + (make-instance 'ipv4-host-address :host-string address))) + `(("a.root-servers.net" ,(ipv4 "198.41.0.4")) + ("b.root-servers.net" ,(ipv4 "192.228.79.201")) + ("c.root-servers.net" ,(ipv4 "192.33.4.12")) + ("d.root-servers.net" ,(ipv4 "128.8.10.90")) + ("e.root-servers.net" ,(ipv4 "192.203.230.10")) + ("f.root-servers.net" ,(ipv4 "192.5.5.241")) + ("g.root-servers.net" ,(ipv4 "192.112.36.4")) + ("h.root-servers.net" ,(ipv4 "128.63.2.53")) + ("i.root-servers.net" ,(ipv4 "192.36.148.17")) + ("j.root-servers.net" ,(ipv4 "192.58.128.30")) + ("k.root-servers.net" ,(ipv4 "193.0.14.129")) + ("l.root-servers.net" ,(ipv4 "199.7.83.42")) + ("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))))))) + table)) + +;;; Resolver + +(defstruct resolver-config + (cache (make-domain-cache)) + (default-domains '() :type list) + (help-servers '() :type list)) + +(defun initialize-default-resolver () + #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil) + (when s + (let ((cfg (make-resolver-config))) + (labels ((whitespace-p (char) + (declare (type character char)) + (or (char= char #\space) + (char= char #\tab))) + (split-line (line) + (let ((l '()) + (p 0)) + (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p) + (return l))) + (p2 (position-if #'whitespace-p line :start p1))) + (if p2 + (setf l (append l (list (subseq line p1 p2))) + p p2) + (progn (setf l (append l (list (subseq line p1 p2)))) + (return l)))))))) + (let ((domain nil) + (search '())) + (loop (let ((line (read-line s nil nil))) + (unless line (return)) + (let ((line (split-line line))) + (when line + (cond ((equal (car line) "nameserver") + (push (make-instance 'ipv4-address :host-string (second line)) + (resolver-config-help-servers cfg))) + ((equal (car line) "search") + (setf search (append search (cdr line)))) + ((equal (car line) "domain") + (setf domain (second line)))))))) + (setf (resolver-config-default-domains cfg) + (or search (and domain (list domain))))) + cfg)))) + #-unix nil) + +(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. (defmethod print-object ((q resource-query) stream)