X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=dns.lisp;h=a9afc67b99c44d4f7b26f72d3941cee2fc57e57c;hp=f768d2ccbee668df78cf564c530684d252be7c2a;hb=d62b232616491f6fbd16c139892ecd45c3ee001c;hpb=426521e71071782c77c495dee36c853c08babad4 diff --git a/dns.lisp b/dns.lisp index f768d2c..a9afc67 100644 --- a/dns.lisp +++ b/dns.lisp @@ -33,7 +33,9 @@ (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) @@ -135,7 +137,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 @@ -380,3 +382,215 @@ (let ((buf (make-dns-encode-state))) (encode-dns-packet buf packet) (slot-value buf 'packet-buf))) + +;;; DN format + +(defun parse-domain-name (name) + (declare (type string name)) + (let ((l '()) + (p 0)) + (loop (let ((p2 (position #\. name :start p))) + (if p2 + (if (= p2 (1- (length name))) + (return (values l t)) + (setf l (append l (list (subseq name p p2))) + p (1+ p2))) + (return (values (append l (list (subseq name p))) nil))))))) + +(defun unparse-domain-name (name) + (declare (type list name)) + (let ((buf nil)) + (dolist (label name buf) + (setf buf (if buf + (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)) + +;;; Misc. + +(defmethod print-object ((q resource-query) stream) + (with-slots (name type) q + (if *print-readably* + (format stream "~A: ~A" type (unparse-domain-name name)) + (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name))))) +