dns.lisp

   1 ;;;; DNS implementation for COMMON-NET
   2
   3 (in-package :common-net)
   4
   5 (defstruct dns-packet
   6   (txid (random 65536) :type (unsigned-byte 16))
   7   (is-response nil)
   8   (opcode :query :type (member :query :iquery :status))
   9   (authoritative nil)
  10   (truncated nil)
  11   (recurse nil)
  12   (will-recurse nil)
  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))
  18
  19 (defclass resource-query ()
  20   ((name :initarg :name)
  21    (type :initarg :type)))
  22
  23 (defclass resource-record ()
  24   ((name :initarg :name)
  25    (ttl :initarg :ttl)))
  26
  27 (defvar *rr-coding-types* '())
  28
  29 (defmacro define-rr-type (name class type slots)
  30   (let ((format (mapcar #'(lambda (slot)
  31                             (list* (if (listp (car slot))
  32                                       (caar slot)
  33                                       (car slot))
  34                                    (cdr slot)))
  35                         slots))
  36         (slot-desc (mapcar #'(lambda (slot)
  37                                (let ((name (car slot)))
  38                                  `(,name :initarg ,(intern (symbol-name name) (find-package :keyword))))) slots)))
  39     `(progn
  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))))))
  43
  44 (define-rr-type a-record #x1 #x1
  45                 ((address ipv4-address)))
  46 (define-rr-type ns-record #x1 #x2
  47                 ((ns-name domain-name)))
  48 (define-rr-type cname-record #x1 #x5
  49                 ((cname domain-name)))
  50 (define-rr-type soa-record #x1 #x6
  51                 ((mname domain-name)
  52                  (rname domain-name)
  53                  (serial uint-32)
  54                  (refresh uint-32)
  55                  (retry uint-32)
  56                  (expire uint-32)))
  57 (define-rr-type ptr-record #x1 #xc
  58                 ((pointed domain-name)))
  59 (define-rr-type mx-record #x1 #xf
  60                 ((prio uint-16)
  61                  (mail-host domain-name)))
  62 (define-rr-type txt-record #x1 #x10
  63                 ((text text)))
  64 (define-rr-type aaaa-record #x1 #x1c
  65                 ((address ipv6-address)))
  66 (define-rr-type srv-record #x1 #x21
  67                 ((prio uint-16)
  68                  (weigth uint-16)
  69                  (port uint-16)
  70                  (host-name domain-name)))
  71
  72 ;;; Packet decoding logic
  73
  74 (defstruct dns-decode-state
  75   (packet nil :type (array (unsigned-byte 8)))
  76   (pos 0 :type (mod 65536))
  77   (prev-names '() :type list))
  78
  79 (define-condition dns-error (error) ())
  80 (define-condition dns-decode-error (dns-error)
  81   ((packet :initarg :packet)))
  82 (define-condition simple-dns-decode-error (dns-decode-error simple-error) ())
  83
  84 (defun simple-dns-decode-error (packet format &rest args)
  85   (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))
  86
  87 (defun decode-uint-8 (buf)
  88  (declare (type dns-decode-state buf))
  89   (with-slots (packet pos) buf
  90     (when (< (- (length packet) pos) 1)
  91       (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number)."))
  92     (prog1 (aref packet pos)
  93       (incf pos))))
  94
  95 (defun decode-uint-16 (buf)
  96   (declare (type dns-decode-state buf))
  97   (with-slots (packet pos) buf
  98     (when (< (- (length packet) pos) 2)
  99       (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number)."))
 100     (prog1
 101         (+ (* (aref packet pos) 256)
 102            (aref packet (1+ pos)))
 103       (incf pos 2))))
 104
 105 (defun decode-uint-32 (buf)
 106   (declare (type dns-decode-state buf))
 107   (with-slots (packet pos) buf
 108     (when (< (- (length packet) pos) 4)
 109       (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number)."))
 110     (prog1
 111         (+ (* (aref packet pos) #x1000000)
 112            (* (aref packet (+ pos 1)) #x10000)
 113            (* (aref packet (+ pos 2)) #x100)
 114            (aref packet (+ pos 3)))
 115       (incf pos 4))))
 116
 117 (defun decode-domain-name (buf)
 118   (declare (type dns-decode-state buf))
 119   (labels ((decode-label ()
 120              (let* ((orig-off (dns-decode-state-pos buf))
 121                     (len (decode-uint-8 buf)))
 122                (case (ldb (byte 2 6) len)
 123                  ((0)
 124                   (if (zerop len)
 125                       '()
 126                       (with-slots (packet pos) buf
 127                         (let* ((label (prog1
 128                                           (handler-bind
 129                                               ((charcode:coding-error
 130                                                 (lambda (c)
 131                                                   (declare (ignore c))
 132                                                   (simple-dns-decode-error buf "DNS label was not ASCII."))))
 133                                             (charcode:decode-string (subseq packet
 134                                                                             pos (+ pos len))
 135                                                                     :ascii))
 136                                         (incf pos len)))
 137                                (decoded (append (list label) (decode-label))))
 138                           (push (cons orig-off decoded) (slot-value buf 'prev-names))
 139                           decoded))))
 140                  ((3) (let* ((offset (+ (* 256 (ldb (byte 6 0) len))
 141                                         (decode-uint-8 buf)))
 142                              (prev (assoc offset (dns-decode-state-prev-names buf))))
 143                         (unless prev
 144                           (simple-dns-decode-error buf "Domain name label pointed to non-label position."))
 145                         (cdr prev)))
 146                  (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
 147     (decode-label)))
 148
 149 (defun decode-dns-query (buf)
 150   (declare (type dns-decode-state buf))
 151   (let* ((name (decode-domain-name buf))
 152          (type (decode-uint-16 buf))
 153          (class (decode-uint-16 buf))
 154          (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
 155     (if desc
 156         (make-instance 'resource-query :name name :type (first desc))
 157         (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
 158                nil))))
 159
 160 (defun decode-dns-record (buf)
 161   (declare (type dns-decode-state buf))
 162   (let* ((name (decode-domain-name buf))
 163          (type (decode-uint-16 buf))
 164          (class (decode-uint-16 buf))
 165          (ttl (decode-uint-32 buf))
 166          (dlen (decode-uint-16 buf))
 167          (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
 168     (when (< (length (dns-decode-state-packet buf))
 169              (+ (dns-decode-state-pos buf) dlen))
 170       (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length."))
 171     (if desc
 172         (let ((orig-off (dns-decode-state-pos buf))
 173               (rr (make-instance (first desc)
 174                                  :name name
 175                                  :ttl ttl)))
 176           (dolist (slot-desc (third desc))
 177             (destructuring-bind (slot-name type) slot-desc
 178               (setf (slot-value rr slot-name)
 179                     (with-slots (packet pos) buf
 180                       (ecase type
 181                         ((uint-16) (decode-uint-16 buf))
 182                         ((uint-32) (decode-uint-32 buf))
 183                         ((domain-name) (decode-domain-name buf))
 184                         ((text)
 185                          (let ((len (decode-uint-8 buf)))
 186                            (prog1 (subseq packet pos (+ pos len))
 187                              (incf pos len))))
 188                         ((ipv4-address)
 189                          (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
 190                            (incf pos 4)))
 191                         ((ipv6-address)
 192                          (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
 193                            (incf pos 16))))))))
 194           (unless (= (dns-decode-state-pos buf) (+ orig-off dlen))
 195             (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data."))
 196           rr)
 197         (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
 198                (incf (dns-decode-state-pos buf) dlen)
 199                nil))))
 200
 201 (defun decode-dns-packet (buf)
 202   (declare (type dns-decode-state buf))
 203   (let* ((txid (decode-uint-16 buf))
 204          (flags (decode-uint-16 buf))
 205          (qnum (decode-uint-16 buf))
 206          (ansnum (decode-uint-16 buf))
 207          (autnum (decode-uint-16 buf))
 208          (auxnum (decode-uint-16 buf))
 209          (packet (make-dns-packet :txid txid
 210                                   :is-response (ldb-test (byte 1 15) flags)
 211                                   :opcode (case (ldb (byte 4 11) flags)
 212                                             ((0) :query)
 213                                             ((1) :iquery)
 214                                             ((2) :status)
 215                                             (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags))))
 216                                   :authoritative (ldb-test (byte 1 10) flags)
 217                                   :truncated (ldb-test (byte 1 9) flags)
 218                                   :recurse (ldb-test (byte 1 8) flags)
 219                                   :will-recurse (ldb-test (byte 1 7) flags)
 220                                   :resp-code (case (ldb (byte 4 0) flags)
 221                                                ((0) :success)
 222                                                ((1) :format-error)
 223                                                ((2) :server-failure)
 224                                                ((3) :name-error)
 225                                                ((4) :not-implemented)
 226                                                ((5) :refused)
 227                                                (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags)))))))
 228     (with-slots (queries answers authority additional) packet
 229         (dotimes (i qnum)
 230           (setf queries (append queries (list (decode-dns-query buf)))))
 231         (dotimes (i ansnum)
 232           (setf answers (append answers (list (decode-dns-record buf)))))
 233         (dotimes (i autnum)
 234           (setf authority (append authority (list (decode-dns-record buf)))))
 235         (dotimes (i auxnum)
 236           (setf additional (append additional (list (decode-dns-record buf))))))
 237     packet))
 238
 239 (defun dns-decode (packet)
 240   (decode-dns-packet (make-dns-decode-state :packet packet)))
 241
 242 ;;; Packet encoding logic
 243
 244 (defstruct dns-encode-state
 245   (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8)))
 246   (prev-names '() :type list))
 247
 248 (defun encode-uint-8 (buf num)
 249   (declare (type dns-encode-state buf)
 250            (type (unsigned-byte 8) num))
 251   (with-slots (packet-buf) buf
 252     (vector-push-extend num packet-buf)))
 253
 254 (defun encode-uint-16 (buf num)
 255   (declare (type dns-encode-state buf)
 256            (type (unsigned-byte 16) num))
 257   (with-slots (packet-buf) buf
 258     (vector-push-extend (ldb (byte 8 8) num) packet-buf)
 259     (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
 260
 261 (defun encode-uint-32 (buf num)
 262   (declare (type dns-encode-state buf)
 263            (type (unsigned-byte 32) num))
 264   (with-slots (packet-buf) buf
 265     (vector-push-extend (ldb (byte 8 24) num) packet-buf)
 266     (vector-push-extend (ldb (byte 8 16) num) packet-buf)
 267     (vector-push-extend (ldb (byte 8 8) num) packet-buf)
 268     (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
 269
 270 (defun encode-bytes (buf bytes)
 271   (declare (type dns-encode-state buf)
 272            (type (array (unsigned-byte 8)) bytes))
 273   (with-slots (packet-buf) buf
 274     (dotimes (i (length bytes) (values))
 275       (vector-push-extend (elt bytes i) packet-buf))))
 276
 277 (defun encode-domain-name (buf name)
 278   (declare (type dns-encode-state buf)
 279            (type list name))
 280   (with-slots (packet-buf prev-names) buf
 281     (labels ((encode-label (name)
 282                (let ((prev (find name prev-names :key 'first :test 'equal)))
 283                  (cond ((null name)
 284                         (encode-uint-8 buf 0))
 285                        (prev
 286                         (encode-uint-16 buf (+ #xc000 (cdr prev))))
 287                        (t
 288                         (when (< (length packet-buf) 16384)
 289                           (push (cons name (length packet-buf)) prev-names))
 290                         (let ((encoded (charcode:encode-string (car name) :ascii)))
 291                           (unless (< (length encoded) 64)
 292                             (error "DNS labels cannot exceed 63 octets in length: ~S" (car name)))
 293                           (encode-uint-8 buf (length encoded))
 294                           (encode-bytes buf encoded))
 295                         (encode-label (cdr name)))))))
 296       (encode-label name))))
 297
 298 (defun encode-dns-query (buf query)
 299   (declare (type dns-encode-state buf)
 300            (type resource-query query))
 301   (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first)))
 302     (encode-domain-name buf (slot-value query 'name))
 303     (encode-uint-16 buf (second (second desc)))
 304     (encode-uint-16 buf (first (second desc)))))
 305
 306 (defun encode-dns-record (buf record)
 307   (declare (type dns-encode-state buf)
 308            (type resource-record record))
 309   (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first)))
 310     (encode-domain-name buf (slot-value record 'name))
 311     (encode-uint-16 buf (second (second desc)))
 312     (encode-uint-16 buf (first (second desc)))
 313     (encode-uint-32 buf (slot-value record 'ttl))
 314     (with-slots (packet-buf) buf
 315       (let ((orig-off (length packet-buf)))
 316         (encode-uint-16 buf 0)
 317         (dolist (slot-desc (third desc))
 318           (destructuring-bind (slot-name type) slot-desc
 319             (let ((val (slot-value record slot-name)))
 320               (ecase type
 321                 ((uint-16) (encode-uint-16 buf val))
 322                 ((uint-32) (encode-uint-32 buf val))
 323                 ((domain-name) (encode-domain-name buf val))
 324                 ((text) (let ((data (etypecase val
 325                                       (string (charcode:encode-string val :ascii))
 326                                       ((array (unsigned-byte 8)) val))))
 327                           (unless (< (length data) 256)
 328                             (error "DNS text data length cannot exceed 255 octets."))
 329                           (encode-uint-8 buf (length data))
 330                           (encode-bytes buf data)))
 331                 ((ipv4-address)
 332                  (check-type val ipv4-host-address)
 333                  (encode-bytes buf (slot-value val 'host-bytes)))
 334                 ((ipv6-address)
 335                  (check-type val ipv6-host-address)
 336                  (encode-bytes buf (slot-value val 'host-bytes)))))))
 337         (let ((dlen (- (length packet-buf) orig-off)))
 338           (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen)
 339                 (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen)))))))
 340
 341 (defun encode-dns-packet (buf packet)
 342   (declare (type dns-encode-state buf)
 343            (type dns-packet packet))
 344   (with-slots (txid is-response opcode authoritative truncated
 345                     recurse will-recurse resp-code
 346                     queries answers authority additional) packet
 347     (encode-uint-16 buf txid)
 348     (let ((flags 0))
 349       (setf (ldb (byte 1 15) flags) (if is-response 1 0)
 350             (ldb (byte 4 11) flags) (ecase opcode
 351                                       ((:query) 0)
 352                                       ((:iquery) 1)
 353                                       ((:status) 2))
 354             (ldb (byte 1 10) flags) (if authoritative 1 0)
 355             (ldb (byte 1 9) flags) (if truncated 1 0)
 356             (ldb (byte 1 8) flags) (if recurse 1 0)
 357             (ldb (byte 1 7) flags) (if will-recurse 1 0)
 358             (ldb (byte 4 0) flags) (ecase resp-code
 359                                      ((:success) 0)
 360                                      ((:format-error) 1)
 361                                      ((:server-failure) 2)
 362                                      ((:name-error) 3)
 363                                      ((:not-implemented) 4)
 364                                      ((:refused) 5)))
 365       (encode-uint-16 buf flags))
 366     (encode-uint-16 buf (length queries))
 367     (encode-uint-16 buf (length answers))
 368     (encode-uint-16 buf (length authority))
 369     (encode-uint-16 buf (length additional))
 370     (dolist (query queries)
 371       (encode-dns-query buf query))
 372     (dolist (rr answers)
 373       (encode-dns-record buf rr))
 374     (dolist (rr authority)
 375       (encode-dns-record buf rr))
 376     (dolist (rr additional)
 377       (encode-dns-record buf rr)))
 378   (values))
 379
 380 (defun dns-encode (packet)
 381   (check-type packet dns-packet)
 382   (let ((buf (make-dns-encode-state)))
 383     (encode-dns-packet buf packet)
 384     (slot-value buf 'packet-buf)))
 385
 386 ;;; DN format
 387
 388 (defun parse-domain-name (name)
 389   (declare (type string name))
 390   (let ((l '())
 391         (p 0))
 392     (loop (let ((p2 (position #\. name :start p)))
 393             (if p2
 394                 (if (= p2 (1- (length name)))
 395                     (return (values l t))
 396                     (setf l (append l (list (subseq name p p2)))
 397                           p (1+ p2)))
 398                 (return (values (append l (list (subseq name p))) nil)))))))
 399
 400 (defun unparse-domain-name (name)
 401   (declare (type list name))
 402   (let ((buf nil))
 403     (dolist (label name buf)
 404       (setf buf (if buf
 405                     (concatenate 'string buf "." label)
 406                     label)))))
 407
 408 ;;; Basic communication
 409
 410 (define-condition name-server-timeout (dns-error)
 411   ((server :initarg :server)))
 412
 413 (defun dns-do-request (server packet)
 414   (declare (type address server)
 415            (type dns-packet packet))
 416   (with-connection (sk server)
 417     (socket-send sk (dns-encode packet))
 418     (loop
 419        (let ((resp (dns-decode (socket-recv sk))))
 420          (when (= (dns-packet-txid resp)
 421                 (dns-packet-txid packet))
 422            (return resp))))))
 423
 424 (defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
 425   (let ((qlist (map 'list #'(lambda (o)
 426                               (let ((name (first o))
 427                                     (type (second o)))
 428                                 (make-instance 'resource-query
 429                                                :name (etypecase name
 430                                                        (string (parse-domain-name name))
 431                                                        (list name))
 432                                                :type type)))
 433                     queries)))
 434     (make-dns-packet :txid txid
 435                      :recurse recurse
 436                      :queries qlist)))
 437
 438 ;;; RR caching
 439
 440 (defstruct domain-cache-entry
 441   (expire nil :type (or number null))
 442   (records '() :type list))
 443
 444 (defun domain-cache-key (name type)
 445   (list name (etypecase type
 446                (symbol type)
 447                (resource-record (class-name (class-of type))))))
 448
 449 (defun domain-cache-key-rr (record)
 450   (declare (type resource-record record))
 451   (list (slot-value record 'name) (class-name (class-of record))))
 452
 453 (defun domain-cache-get-entry (cache name type &optional create)
 454   (let* ((key (domain-cache-key name type))
 455          (cur (gethash key cache)))
 456     (when (and cur (or (eq create :clear)
 457                        (let ((expire (domain-cache-entry-expire cur)))
 458                          (and expire
 459                               (> (/ (get-internal-real-time) internal-time-units-per-second)
 460                                  expire)))))
 461       (remhash key cache)
 462       (setf cur nil))
 463     (cond (cur cur)
 464           (create
 465            (setf (gethash key cache) (make-domain-cache-entry))))))
 466
 467 (defun domain-cache-put (cache record)
 468   (with-slots (name ttl) record
 469     (let ((entry (domain-cache-get-entry cache name record t)))
 470       (push record (domain-cache-entry-records entry)))))
 471
 472 (defun dns-cache-records (cache records)
 473   (loop (unless records (return))
 474      (let* ((key (domain-cache-key-rr (car records)))
 475             (matching (remove key records :test-not 'equal :key #'domain-cache-key-rr))
 476             (ttl (block no-expire
 477                    (+ (/ (get-internal-real-time) internal-time-units-per-second)
 478                       (apply 'min (mapcar #'(lambda (rr)
 479                                               (with-slots (ttl) rr
 480                                                 (if ttl ttl (return-from no-expire nil))))
 481                                           matching)))))
 482             (entry (make-domain-cache-entry :expire ttl :records matching)))
 483        (setf (gethash key cache) entry
 484              records (set-difference records matching)))))
 485
 486 (defun dns-cache-response (cache packet)
 487   (let ((records (append (dns-packet-answers packet)
 488                          (dns-packet-authority packet)
 489                          (dns-packet-additional packet))))
 490     (flet ((on-root (rr)
 491              (equal (slot-value rr 'name) '())))
 492       (when (some #'on-root records)
 493         (warn "DNS packet purports to contain RRs on the root zone.")
 494         (setf records (delete-if #'on-root records))))
 495     (when (dns-packet-authoritative packet)
 496       (dolist (rq (dns-packet-queries packet))
 497         (with-slots (name type) rq
 498           (unless (equal name '())
 499             (let ((key (domain-cache-key name type)))
 500               (unless (find key records :test 'equal :key #'domain-cache-key-rr)
 501                 (let ((entry (domain-cache-get-entry cache name type :clear)))
 502                   (setf (domain-cache-entry-expire entry)
 503                         (+ (/ (get-internal-real-time) internal-time-units-per-second)
 504                            60)))))))))  ; XXX: Or something. It needs
 505                                         ; to last for the query in
 506                                         ; progress, at least. One
 507                                         ; should probably look at an
 508                                         ; SOA RR, if there is one.
 509     (dns-cache-records cache records)))
 510
 511 (defun make-domain-cache ()
 512   (let ((table (make-hash-table :test 'equal)))
 513     (dolist (server (labels ((ipv4 (address)
 514                                (make-instance 'ipv4-host-address :host-string address)))
 515                       `(("a.root-servers.net" ,(ipv4 "198.41.0.4"))
 516                         ("b.root-servers.net" ,(ipv4 "192.228.79.201"))
 517                         ("c.root-servers.net" ,(ipv4 "192.33.4.12"))
 518                         ("d.root-servers.net" ,(ipv4 "128.8.10.90"))
 519                         ("e.root-servers.net" ,(ipv4 "192.203.230.10"))
 520                         ("f.root-servers.net" ,(ipv4 "192.5.5.241"))
 521                         ("g.root-servers.net" ,(ipv4 "192.112.36.4"))
 522                         ("h.root-servers.net" ,(ipv4 "128.63.2.53"))
 523                         ("i.root-servers.net" ,(ipv4 "192.36.148.17"))
 524                         ("j.root-servers.net" ,(ipv4 "192.58.128.30"))
 525                         ("k.root-servers.net" ,(ipv4 "193.0.14.129"))
 526                         ("l.root-servers.net" ,(ipv4 "199.7.83.42"))
 527                         ("m.root-servers.net" ,(ipv4 "202.12.27.33")))))
 528       (let ((parsed (parse-domain-name (first server))))
 529         (domain-cache-put table (make-instance 'ns-record :name '() :ttl nil :ns-name parsed))
 530         ;; Ensure that the cache is initialized at least with empty
 531         ;; lists, so that the resolver doesn't try to resolve the root
 532         ;; servers.
 533         (domain-cache-get-entry table parsed 'a-record t)
 534         (domain-cache-get-entry table parsed 'aaaa-record t)
 535
 536         (dolist (address (cdr server))
 537           (domain-cache-put table (etypecase address
 538                                     (ipv4-host-address (make-instance 'a-record :name parsed :ttl nil :address address)))))))
 539     table))
 540
 541 ;;; Resolver
 542
 543 (defstruct resolver-config
 544   (cache (make-domain-cache))
 545   (default-domains '() :type list)
 546   (help-servers '() :type list))
 547
 548 (defun initialize-default-resolver ()
 549   #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil)
 550            (when s
 551              (let ((cfg (make-resolver-config)))
 552                (labels ((whitespace-p (char)
 553                           (declare (type character char))
 554                           (or (char= char #\space)
 555                               (char= char #\tab)))
 556                         (split-line (line)
 557                           (let ((l '())
 558                                 (p 0))
 559                             (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p)
 560                                                 (return l)))
 561                                          (p2 (position-if #'whitespace-p line :start p1)))
 562                                     (if p2
 563                                         (setf l (append l (list (subseq line p1 p2)))
 564                                               p p2)
 565                                         (progn (setf l (append l (list (subseq line p1 p2))))
 566                                                (return l))))))))
 567                  (let ((domain nil)
 568                        (search '()))
 569                    (loop (let ((line (read-line s nil nil)))
 570                            (unless line (return))
 571                            (let ((line (split-line line)))
 572                              (when line
 573                                (cond ((equal (car line) "nameserver")
 574                                       (push (make-instance 'ipv4-address :host-string (second line))
 575                                             (resolver-config-help-servers cfg)))
 576                                      ((equal (car line) "search")
 577                                       (setf search (append search (cdr line))))
 578                                      ((equal (car line) "domain")
 579                                       (setf domain (second line))))))))
 580                    (setf (resolver-config-default-domains cfg)
 581                          (or search (and domain (list domain)))))
 582                  cfg))))
 583   #-unix nil)
 584
 585 (defvar *dns-resolver-config* (initialize-default-resolver))
 586
 587 (defgeneric dns-server-address-for-record (record))
 588
 589 ;;; Misc.
 590
 591 (defmethod print-object ((q resource-query) stream)
 592   (with-slots (name type) q
 593     (if *print-readably*
 594         (format stream "~A: ~A" type (unparse-domain-name name))
 595         (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))
 596