(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)))
(port uint-16)
(host-name domain-name)))
+(export '(resource-record))
+
;;; Packet decoding logic
(defstruct dns-decode-state
(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) ())
(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
(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)))))))
(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)
;;; 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))
: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)
Dolda2000 GitWeb / lisp-utils.git / blobdiff