1 ;;;; DNS implementation for COMMON-NET
3 (in-package :common-net)
6 (txid (random 65536) :type (unsigned-byte 16))
8 (opcode :query :type (member :query :iquery :status))
13 (resp-code :success :type (member :success :format-error :server-failure :name-error :not-implemented :refused))
14 (queries '() :type list)
15 (answers '() :type list)
16 (authority '() :type list)
17 (additional '() :type list))
19 (defclass resource-query ()
20 ((name :initarg :name)
21 (type :initarg :type)))
23 (defclass resource-record ()
24 ((name :initarg :name)
27 (defvar *rr-coding-types* '())
29 (defmacro define-rr-type (name class type slots)
30 (let ((format (mapcar #'(lambda (slot)
31 (list* (if (listp (car slot))
36 (slot-desc (mapcar #'(lambda (slot)
37 (let ((name (car slot)))
38 `(,name :initarg ,(intern (symbol-name name) (find-package :keyword))))) slots)))
40 (defclass ,name (resource-record) ,slot-desc)
41 (setf *rr-coding-types* (cons '(,name (,class ,type) ,format)
42 (remove ',name *rr-coding-types* :key #'car)))
45 (define-rr-type a-record #x1 #x1
46 ((address ipv4-address)))
47 (define-rr-type ns-record #x1 #x2
48 ((ns-name domain-name)))
49 (define-rr-type cname-record #x1 #x5
50 ((cname domain-name)))
51 (define-rr-type soa-record #x1 #x6
58 (define-rr-type ptr-record #x1 #xc
59 ((pointed domain-name)))
60 (define-rr-type mx-record #x1 #xf
62 (mail-host domain-name)))
63 (define-rr-type txt-record #x1 #x10
65 (define-rr-type aaaa-record #x1 #x1c
66 ((address ipv6-address)))
67 (define-rr-type srv-record #x1 #x21
71 (host-name domain-name)))
73 (export '(resource-record))
75 ;;; Packet decoding logic
77 (defstruct dns-decode-state
78 (packet nil :type (array (unsigned-byte 8)))
79 (pos 0 :type (mod 65536))
80 (prev-names '() :type list))
82 (define-condition dns-error (network-error) ())
83 (define-condition dns-decode-error (dns-error)
84 ((packet :initarg :packet)))
85 (define-condition simple-dns-decode-error (dns-decode-error simple-error) ())
87 (defun simple-dns-decode-error (packet format &rest args)
88 (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))
90 (defun decode-uint-8 (buf)
91 (declare (type dns-decode-state buf))
92 (with-slots (packet pos) buf
93 (when (< (- (length packet) pos) 1)
94 (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number)."))
95 (prog1 (aref packet pos)
98 (defun decode-uint-16 (buf)
99 (declare (type dns-decode-state buf))
100 (with-slots (packet pos) buf
101 (when (< (- (length packet) pos) 2)
102 (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number)."))
104 (+ (* (aref packet pos) 256)
105 (aref packet (1+ pos)))
108 (defun decode-uint-32 (buf)
109 (declare (type dns-decode-state buf))
110 (with-slots (packet pos) buf
111 (when (< (- (length packet) pos) 4)
112 (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number)."))
114 (+ (* (aref packet pos) #x1000000)
115 (* (aref packet (+ pos 1)) #x10000)
116 (* (aref packet (+ pos 2)) #x100)
117 (aref packet (+ pos 3)))
120 (defun decode-domain-name (buf)
121 (declare (type dns-decode-state buf))
122 (labels ((decode-label ()
123 (let* ((orig-off (dns-decode-state-pos buf))
124 (len (decode-uint-8 buf)))
125 (case (ldb (byte 2 6) len)
129 (with-slots (packet pos) buf
132 ((charcode:coding-error
135 (simple-dns-decode-error buf "DNS label was not ASCII."))))
136 (charcode:decode-string (subseq packet
140 (decoded (append (list label) (decode-label))))
141 (push (cons orig-off decoded) (slot-value buf 'prev-names))
143 ((3) (let* ((offset (+ (* 256 (ldb (byte 6 0) len))
144 (decode-uint-8 buf)))
145 (prev (assoc offset (dns-decode-state-prev-names buf))))
147 (simple-dns-decode-error buf "Domain name label pointed to non-label position."))
149 (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
152 (defun decode-dns-query (buf)
153 (declare (type dns-decode-state buf))
154 (let* ((name (decode-domain-name buf))
155 (type (decode-uint-16 buf))
156 (class (decode-uint-16 buf))
157 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
159 (make-instance 'resource-query :name name :type (first desc))
160 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
163 (defun decode-dns-record (buf)
164 (declare (type dns-decode-state buf))
165 (let* ((name (decode-domain-name buf))
166 (type (decode-uint-16 buf))
167 (class (decode-uint-16 buf))
168 (ttl (decode-uint-32 buf))
169 (dlen (decode-uint-16 buf))
170 (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
171 (when (< (length (dns-decode-state-packet buf))
172 (+ (dns-decode-state-pos buf) dlen))
173 (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length."))
175 (let ((orig-off (dns-decode-state-pos buf))
176 (rr (make-instance (first desc)
179 (dolist (slot-desc (third desc))
180 (destructuring-bind (slot-name type) slot-desc
181 (setf (slot-value rr slot-name)
182 (with-slots (packet pos) buf
184 ((uint-16) (decode-uint-16 buf))
185 ((uint-32) (decode-uint-32 buf))
186 ((domain-name) (decode-domain-name buf))
188 (let ((len (decode-uint-8 buf)))
189 (prog1 (subseq packet pos (+ pos len))
192 (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
195 (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
197 (unless (= (dns-decode-state-pos buf) (+ orig-off dlen))
198 (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data."))
200 (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
201 (incf (dns-decode-state-pos buf) dlen)
204 (defun decode-dns-packet (buf)
205 (declare (type dns-decode-state buf))
206 (let* ((txid (decode-uint-16 buf))
207 (flags (decode-uint-16 buf))
208 (qnum (decode-uint-16 buf))
209 (ansnum (decode-uint-16 buf))
210 (autnum (decode-uint-16 buf))
211 (auxnum (decode-uint-16 buf))
212 (packet (make-dns-packet :txid txid
213 :is-response (ldb-test (byte 1 15) flags)
214 :opcode (case (ldb (byte 4 11) flags)
218 (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags))))
219 :authoritative (ldb-test (byte 1 10) flags)
220 :truncated (ldb-test (byte 1 9) flags)
221 :recurse (ldb-test (byte 1 8) flags)
222 :will-recurse (ldb-test (byte 1 7) flags)
223 :resp-code (case (ldb (byte 4 0) flags)
226 ((2) :server-failure)
228 ((4) :not-implemented)
230 (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags)))))))
231 (with-slots (queries answers authority additional) packet
233 (setf queries (append queries (list (decode-dns-query buf)))))
235 (setf answers (append answers (list (decode-dns-record buf)))))
237 (setf authority (append authority (list (decode-dns-record buf)))))
239 (setf additional (append additional (list (decode-dns-record buf))))))
242 (defun dns-decode (packet)
243 (decode-dns-packet (make-dns-decode-state :packet packet)))
245 ;;; Packet encoding logic
247 (defstruct dns-encode-state
248 (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8)))
249 (prev-names '() :type list))
251 (defun encode-uint-8 (buf num)
252 (declare (type dns-encode-state buf)
253 (type (unsigned-byte 8) num))
254 (with-slots (packet-buf) buf
255 (vector-push-extend num packet-buf)))
257 (defun encode-uint-16 (buf num)
258 (declare (type dns-encode-state buf)
259 (type (unsigned-byte 16) num))
260 (with-slots (packet-buf) buf
261 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
262 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
264 (defun encode-uint-32 (buf num)
265 (declare (type dns-encode-state buf)
266 (type (unsigned-byte 32) num))
267 (with-slots (packet-buf) buf
268 (vector-push-extend (ldb (byte 8 24) num) packet-buf)
269 (vector-push-extend (ldb (byte 8 16) num) packet-buf)
270 (vector-push-extend (ldb (byte 8 8) num) packet-buf)
271 (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
273 (defun encode-bytes (buf bytes)
274 (declare (type dns-encode-state buf)
275 (type (array (unsigned-byte 8)) bytes))
276 (with-slots (packet-buf) buf
277 (dotimes (i (length bytes) (values))
278 (vector-push-extend (elt bytes i) packet-buf))))
280 (defun encode-domain-name (buf name)
281 (declare (type dns-encode-state buf)
283 (with-slots (packet-buf prev-names) buf
284 (labels ((encode-label (name)
285 (let ((prev (find name prev-names :key 'first :test 'equal)))
287 (encode-uint-8 buf 0))
289 (encode-uint-16 buf (+ #xc000 (cdr prev))))
291 (when (< (length packet-buf) 16384)
292 (push (cons name (length packet-buf)) prev-names))
293 (let ((encoded (charcode:encode-string (car name) :ascii)))
294 (unless (< (length encoded) 64)
295 (simple-dns-decode-error buf "DNS labels cannot exceed 63 octets in length: ~S" (car name)))
296 (encode-uint-8 buf (length encoded))
297 (encode-bytes buf encoded))
298 (encode-label (cdr name)))))))
299 (encode-label name))))
301 (defun encode-dns-query (buf query)
302 (declare (type dns-encode-state buf)
303 (type resource-query query))
304 (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first)))
305 (encode-domain-name buf (slot-value query 'name))
306 (encode-uint-16 buf (second (second desc)))
307 (encode-uint-16 buf (first (second desc)))))
309 (defun encode-dns-record (buf record)
310 (declare (type dns-encode-state buf)
311 (type resource-record record))
312 (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first)))
313 (encode-domain-name buf (slot-value record 'name))
314 (encode-uint-16 buf (second (second desc)))
315 (encode-uint-16 buf (first (second desc)))
316 (encode-uint-32 buf (slot-value record 'ttl))
317 (with-slots (packet-buf) buf
318 (let ((orig-off (length packet-buf)))
319 (encode-uint-16 buf 0)
320 (dolist (slot-desc (third desc))
321 (destructuring-bind (slot-name type) slot-desc
322 (let ((val (slot-value record slot-name)))
324 ((uint-16) (encode-uint-16 buf val))
325 ((uint-32) (encode-uint-32 buf val))
326 ((domain-name) (encode-domain-name buf val))
327 ((text) (let ((data (etypecase val
328 (string (charcode:encode-string val :ascii))
329 ((array (unsigned-byte 8)) val))))
330 (unless (< (length data) 256)
331 (simple-dns-decode-error buf "DNS text data length cannot exceed 255 octets."))
332 (encode-uint-8 buf (length data))
333 (encode-bytes buf data)))
335 (check-type val ipv4-host-address)
336 (encode-bytes buf (slot-value val 'host-bytes)))
338 (check-type val ipv6-host-address)
339 (encode-bytes buf (slot-value val 'host-bytes)))))))
340 (let ((dlen (- (length packet-buf) orig-off)))
341 (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen)
342 (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen)))))))
344 (defun encode-dns-packet (buf packet)
345 (declare (type dns-encode-state buf)
346 (type dns-packet packet))
347 (with-slots (txid is-response opcode authoritative truncated
348 recurse will-recurse resp-code
349 queries answers authority additional) packet
350 (encode-uint-16 buf txid)
352 (setf (ldb (byte 1 15) flags) (if is-response 1 0)
353 (ldb (byte 4 11) flags) (ecase opcode
357 (ldb (byte 1 10) flags) (if authoritative 1 0)
358 (ldb (byte 1 9) flags) (if truncated 1 0)
359 (ldb (byte 1 8) flags) (if recurse 1 0)
360 (ldb (byte 1 7) flags) (if will-recurse 1 0)
361 (ldb (byte 4 0) flags) (ecase resp-code
364 ((:server-failure) 2)
366 ((:not-implemented) 4)
368 (encode-uint-16 buf flags))
369 (encode-uint-16 buf (length queries))
370 (encode-uint-16 buf (length answers))
371 (encode-uint-16 buf (length authority))
372 (encode-uint-16 buf (length additional))
373 (dolist (query queries)
374 (encode-dns-query buf query))
376 (encode-dns-record buf rr))
377 (dolist (rr authority)
378 (encode-dns-record buf rr))
379 (dolist (rr additional)
380 (encode-dns-record buf rr)))
383 (defun dns-encode (packet)
384 (check-type packet dns-packet)
385 (let ((buf (make-dns-encode-state)))
386 (encode-dns-packet buf packet)
387 (slot-value buf 'packet-buf)))
391 (defun parse-domain-name (name)
392 (declare (type string name))
395 (loop (let ((p2 (position #\. name :start p)))
397 (if (= p2 (1- (length name)))
398 (return (values l t))
399 (setf l (append l (list (subseq name p p2)))
401 (return (values (append l (list (subseq name p))) nil)))))))
403 (defun unparse-domain-name (name)
404 (declare (type list name))
406 (dolist (label name buf)
408 (concatenate 'string buf "." label)
411 ;;; Basic communication
413 (define-condition name-server-timeout (dns-error)
414 ((server :initarg :server)))
416 (defun dns-do-request (server packet)
417 (declare (type address server)
418 (type dns-packet packet))
419 (with-connection (sk server)
420 (socket-send sk (dns-encode packet))
422 (let ((resp (dns-decode (socket-recv sk))))
423 (when (= (dns-packet-txid resp)
424 (dns-packet-txid packet))
427 (defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
428 (let ((qlist (map 'list #'(lambda (o)
429 (let ((name (first o))
431 (make-instance 'resource-query
432 :name (etypecase name
433 (string (parse-domain-name name))
437 (make-dns-packet :txid txid
443 (defstruct domain-cache-entry
444 (expire nil :type (or number null))
445 (records '() :type list))
447 (defun domain-cache-key (name type)
448 (list name (etypecase type
450 (resource-record (class-name (class-of type))))))
452 (defun domain-cache-key-rr (record)
453 (declare (type resource-record record))
454 (list (slot-value record 'name) (class-name (class-of record))))
456 (defun domain-cache-get-entry (cache name type &optional create)
457 (let* ((key (domain-cache-key name type))
458 (cur (gethash key cache)))
459 (when (and cur (or (eq create :clear)
460 (let ((expire (domain-cache-entry-expire cur)))
462 (> (/ (get-internal-real-time) internal-time-units-per-second)
468 (setf (gethash key cache) (make-domain-cache-entry))))))
470 (defun domain-cache-put (cache record)
471 (with-slots (name ttl) record
472 (let ((entry (domain-cache-get-entry cache name record t)))
473 (push record (domain-cache-entry-records entry)))))
475 (defun dns-cache-records (cache records)
476 (loop (unless records (return))
477 (let* ((key (domain-cache-key-rr (car records)))
478 (matching (remove key records :test-not 'equal :key #'domain-cache-key-rr))
479 (ttl (block no-expire
480 (+ (/ (get-internal-real-time) internal-time-units-per-second)
481 (apply 'min (mapcar #'(lambda (rr)
483 (if ttl ttl (return-from no-expire nil))))
485 (entry (make-domain-cache-entry :expire ttl :records matching)))
486 (setf (gethash key cache) entry
487 records (set-difference records matching)))))
489 (defun dns-cache-response (cache packet)
490 (let ((records (append (dns-packet-answers packet)
491 (dns-packet-authority packet)
492 (dns-packet-additional packet))))
494 (equal (slot-value rr 'name) '())))
495 (when (some #'on-root records)
496 (warn "DNS packet purports to contain RRs on the root zone.")
497 (setf records (delete-if #'on-root records))))
498 (when (dns-packet-authoritative packet)
499 (dolist (rq (dns-packet-queries packet))
500 (with-slots (name type) rq
501 (unless (equal name '())
502 (let ((key (domain-cache-key name type)))
503 (unless (find key records :test 'equal :key #'domain-cache-key-rr)
504 (let ((entry (domain-cache-get-entry cache name type :clear)))
505 (setf (domain-cache-entry-expire entry)
506 (+ (/ (get-internal-real-time) internal-time-units-per-second)
507 60))))))))) ; XXX: Or something. It needs
508 ; to last for the query in
509 ; progress, at least. One
510 ; should probably look at an
511 ; SOA RR, if there is one.
512 (dns-cache-records cache records)))
514 (defun make-domain-cache ()
515 (let ((table (make-hash-table :test 'equal)))
516 (dolist (server (labels ((ipv4 (address)
517 (make-instance 'ipv4-host-address :host-string address)))
518 `(("a.root-servers.net" ,(ipv4 "198.41.0.4"))
519 ("b.root-servers.net" ,(ipv4 "192.228.79.201"))
520 ("c.root-servers.net" ,(ipv4 "192.33.4.12"))
521 ("d.root-servers.net" ,(ipv4 "128.8.10.90"))
522 ("e.root-servers.net" ,(ipv4 "192.203.230.10"))
523 ("f.root-servers.net" ,(ipv4 "192.5.5.241"))
524 ("g.root-servers.net" ,(ipv4 "192.112.36.4"))
525 ("h.root-servers.net" ,(ipv4 "128.63.2.53"))
526 ("i.root-servers.net" ,(ipv4 "192.36.148.17"))
527 ("j.root-servers.net" ,(ipv4 "192.58.128.30"))
528 ("k.root-servers.net" ,(ipv4 "193.0.14.129"))
529 ("l.root-servers.net" ,(ipv4 "199.7.83.42"))
530 ("m.root-servers.net" ,(ipv4 "202.12.27.33")))))
531 (let ((parsed (parse-domain-name (first server))))
532 (domain-cache-put table (make-instance 'ns-record :name '() :ttl nil :ns-name parsed))
533 ;; Ensure that the cache is initialized at least with empty
534 ;; lists, so that the resolver doesn't try to resolve the root
536 (domain-cache-get-entry table parsed 'a-record t)
537 (domain-cache-get-entry table parsed 'aaaa-record t)
539 (dolist (address (cdr server))
540 (domain-cache-put table (etypecase address
541 (ipv4-host-address (make-instance 'a-record :name parsed :ttl nil :address address)))))))
546 (defstruct resolver-config
547 (cache (make-domain-cache))
548 (default-domains '() :type list)
549 (help-servers '() :type list))
551 (defun initialize-default-resolver ()
552 #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil)
554 (let ((cfg (make-resolver-config)))
555 (labels ((whitespace-p (char)
556 (declare (type character char))
557 (or (char= char #\space)
562 (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p)
564 (p2 (position-if #'whitespace-p line :start p1)))
566 (setf l (append l (list (subseq line p1 p2)))
568 (progn (setf l (append l (list (subseq line p1 p2))))
572 (loop (let ((line (read-line s nil nil)))
573 (unless line (return))
574 (let ((line (split-line line)))
576 (cond ((equal (car line) "nameserver")
577 (push (make-instance 'ipv4-address :host-string (second line))
578 (resolver-config-help-servers cfg)))
579 ((equal (car line) "search")
580 (setf search (append search (cdr line))))
581 ((equal (car line) "domain")
582 (setf domain (second line))))))))
583 (setf (resolver-config-default-domains cfg)
584 (or search (and domain (list domain)))))
588 (defvar *dns-resolver-config* (initialize-default-resolver))
590 (defgeneric dns-server-address-for-record (record))
591 (defmethod dns-server-address-for-record ((record a-record))
592 (make-instance 'udp4-address
593 :host-address (slot-value record 'address)
595 (defmethod dns-server-address-for-record ((record aaaa-record))
596 (make-instance 'udp6-address
597 :host-address (slot-value record 'address)
600 (define-condition dns-resolver-condition (condition)
601 ((query-name :initarg :query-name)
602 (query-type :initarg :query-type)
603 (config :initarg :config)))
605 (define-condition dns-resolver-error (dns-error dns-resolver-condition) ())
606 (define-condition domain-not-found-error (dns-resolver-error) ()
607 (:report (lambda (c s)
608 (with-slots (query-name) c
609 (format s "No name servers found for domain name ~A." query-name)))))
610 (define-condition dns-name-error (dns-error dns-resolver-condition) ()
611 (:report (lambda (c s)
612 (with-slots (query-name) c
613 (format s "The domain name ~A does not exist." query-name)))))
615 (define-condition dns-resolver-querying (dns-resolver-condition)
616 ((server :initarg :server)))
618 (define-condition dns-resolver-got-resp (dns-resolver-condition)
619 ((server :initarg :server)
620 (response :initarg :response)))
622 (define-condition dns-resolver-help (dns-resolver-condition) ())
623 (define-condition dns-resolver-recursing (dns-resolver-condition) ())
625 (define-condition dns-resolver-following-cname (dns-resolver-condition)
626 ((cname-rr :initarg :cname-rr)))
628 (defun dns-resolve-name (name types &key (require-all t) (config *dns-resolver-config*))
629 (let ((name (etypecase name
631 (string (parse-domain-name name))))
632 (types (etypecase types
634 (symbol (list types))))
635 (cache (resolver-config-cache config)))
636 (flet ((check-cache ()
637 (let ((cn-entry (domain-cache-get-entry cache name 'cname-record)))
638 (when (and cn-entry (domain-cache-entry-records cn-entry))
639 (let ((record (car (domain-cache-entry-records cn-entry))))
640 (signal 'dns-resolver-following-cname :cname-rr record
641 :query-name (unparse-domain-name name) :query-type types
643 (return-from dns-resolve-name
644 (dns-resolve-name (slot-value record 'cname) types :config config)))))
649 (let ((entry (domain-cache-get-entry cache name type)))
651 (setf records (append records (domain-cache-entry-records entry))
654 (return-from skip)))))
656 (return-from dns-resolve-name (values records name))))))
657 (nearest-known-servers (name)
658 (labels ((check1 (name)
659 (let ((entry (domain-cache-get-entry cache name 'ns-record)))
660 (cond ((and entry (domain-cache-entry-records entry))
661 (values (domain-cache-entry-records entry) name))
662 (name (check1 (cdr name)))
663 (t (values '() name))))))
666 (signal 'dns-resolver-querying :server server
667 :query-name (unparse-domain-name name) :query-type types
670 (let ((resp (dns-do-request (udp-address-for server 53)
671 (dns-std-request (mapcar #'(lambda (type)
674 (signal 'dns-resolver-got-resp :server server :response resp
675 :query-name (unparse-domain-name name) :query-type types
677 (dns-cache-response cache resp)
678 (with-slots (resp-code) resp
679 (when (eq (dns-packet-resp-code resp) :name-error)
680 (error 'dns-name-error :query-name (unparse-domain-name name) :query-type types
682 (eq resp-code :success)))
683 (network-error () nil))))
685 (signal 'dns-resolver-help :query-name (unparse-domain-name name) :query-type types
687 (dolist (help-server (resolver-config-help-servers config))
688 (do-request help-server)
690 (signal 'dns-resolver-recursing :query-name (unparse-domain-name name) :query-type types
692 (let ((checked-domains '()))
693 (loop (multiple-value-bind (servers domain)
694 (nearest-known-servers name)
696 (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types
698 (if (find domain checked-domains :test 'equal)
699 (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types
701 (push domain checked-domains))
702 (macrolet ((dolist-random ((var list) &body body)
703 (let ((copy (gensym "COPY")))
704 `(let ((,copy ,list))
705 (loop (unless ,copy (return))
706 (let ((,var (elt ,list (random (length ,list)))))
707 (setf ,copy (remove ,var ,copy))
710 (dolist-random (record servers)
711 (let* ((server (slot-value record 'ns-name)))
712 (dolist-random (record (handler-case
713 (dns-resolve-name server '(a-record aaaa-record) :require-all nil :config config)
714 (dns-resolver-error () '())))
715 (when (do-request (dns-server-address-for-record record))
716 (return-from found-server))))))
719 (export '(*dns-resolver-config*))
723 (defmethod print-object ((q resource-query) stream)
724 (with-slots (name type) q
726 (format stream "~A: ~A" type (unparse-domain-name name))
727 (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))