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        (export '(,name)))))
  44
  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
  52                 ((mname domain-name)
  53                  (rname domain-name)
  54                  (serial uint-32)
  55                  (refresh uint-32)
  56                  (retry uint-32)
  57                  (expire uint-32)))
  58 (define-rr-type ptr-record #x1 #xc
  59                 ((pointed domain-name)))
  60 (define-rr-type mx-record #x1 #xf
  61                 ((prio uint-16)
  62                  (mail-host domain-name)))
  63 (define-rr-type txt-record #x1 #x10
  64                 ((text text)))
  65 (define-rr-type aaaa-record #x1 #x1c
  66                 ((address ipv6-address)))
  67 (define-rr-type srv-record #x1 #x21
  68                 ((prio uint-16)
  69                  (weigth uint-16)
  70                  (port uint-16)
  71                  (host-name domain-name)))
  72
  73 (export '(resource-record))
  74
  75 ;;; Packet decoding logic
  76
  77 (defstruct dns-decode-state
  78   (packet nil :type (array (unsigned-byte 8)))
  79   (pos 0 :type (mod 65536))
  80   (prev-names '() :type list))
  81
  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) ())
  86
  87 (defun simple-dns-decode-error (packet format &rest args)
  88   (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))
  89
  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)
  96       (incf pos))))
  97
  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)."))
 103     (prog1
 104         (+ (* (aref packet pos) 256)
 105            (aref packet (1+ pos)))
 106       (incf pos 2))))
 107
 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)."))
 113     (prog1
 114         (+ (* (aref packet pos) #x1000000)
 115            (* (aref packet (+ pos 1)) #x10000)
 116            (* (aref packet (+ pos 2)) #x100)
 117            (aref packet (+ pos 3)))
 118       (incf pos 4))))
 119
 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)
 126                  ((0)
 127                   (if (zerop len)
 128                       '()
 129                       (with-slots (packet pos) buf
 130                         (let* ((label (prog1
 131                                           (handler-bind
 132                                               ((charcode:coding-error
 133                                                 (lambda (c)
 134                                                   (declare (ignore c))
 135                                                   (simple-dns-decode-error buf "DNS label was not ASCII."))))
 136                                             (charcode:decode-string (subseq packet
 137                                                                             pos (+ pos len))
 138                                                                     :ascii))
 139                                         (incf pos len)))
 140                                (decoded (append (list label) (decode-label))))
 141                           (push (cons orig-off decoded) (slot-value buf 'prev-names))
 142                           decoded))))
 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))))
 146                         (unless prev
 147                           (simple-dns-decode-error buf "Domain name label pointed to non-label position."))
 148                         (cdr prev)))
 149                  (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len)))))))
 150     (decode-label)))
 151
 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)))
 158     (if desc
 159         (make-instance 'resource-query :name name :type (first desc))
 160         (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
 161                nil))))
 162
 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."))
 174     (if desc
 175         (let ((orig-off (dns-decode-state-pos buf))
 176               (rr (make-instance (first desc)
 177                                  :name name
 178                                  :ttl ttl)))
 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
 183                       (ecase type
 184                         ((uint-16) (decode-uint-16 buf))
 185                         ((uint-32) (decode-uint-32 buf))
 186                         ((domain-name) (decode-domain-name buf))
 187                         ((text)
 188                          (let ((len (decode-uint-8 buf)))
 189                            (prog1 (subseq packet pos (+ pos len))
 190                              (incf pos len))))
 191                         ((ipv4-address)
 192                          (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
 193                            (incf pos 4)))
 194                         ((ipv6-address)
 195                          (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
 196                            (incf 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."))
 199           rr)
 200         (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
 201                (incf (dns-decode-state-pos buf) dlen)
 202                nil))))
 203
 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)
 215                                             ((0) :query)
 216                                             ((1) :iquery)
 217                                             ((2) :status)
 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)
 224                                                ((0) :success)
 225                                                ((1) :format-error)
 226                                                ((2) :server-failure)
 227                                                ((3) :name-error)
 228                                                ((4) :not-implemented)
 229                                                ((5) :refused)
 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
 232         (dotimes (i qnum)
 233           (setf queries (append queries (list (decode-dns-query buf)))))
 234         (dotimes (i ansnum)
 235           (setf answers (append answers (list (decode-dns-record buf)))))
 236         (dotimes (i autnum)
 237           (setf authority (append authority (list (decode-dns-record buf)))))
 238         (dotimes (i auxnum)
 239           (setf additional (append additional (list (decode-dns-record buf))))))
 240     packet))
 241
 242 (defun dns-decode (packet)
 243   (decode-dns-packet (make-dns-decode-state :packet packet)))
 244
 245 ;;; Packet encoding logic
 246
 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))
 250
 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)))
 256
 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)))
 263
 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)))
 272
 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))))
 279
 280 (defun encode-domain-name (buf name)
 281   (declare (type dns-encode-state buf)
 282            (type list name))
 283   (with-slots (packet-buf prev-names) buf
 284     (labels ((encode-label (name)
 285                (let ((prev (find name prev-names :key 'first :test 'equal)))
 286                  (cond ((null name)
 287                         (encode-uint-8 buf 0))
 288                        (prev
 289                         (encode-uint-16 buf (+ #xc000 (cdr prev))))
 290                        (t
 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))))
 300
 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)))))
 308
 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)))
 323               (ecase type
 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)))
 334                 ((ipv4-address)
 335                  (check-type val ipv4-host-address)
 336                  (encode-bytes buf (slot-value val 'host-bytes)))
 337                 ((ipv6-address)
 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)))))))
 343
 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)
 351     (let ((flags 0))
 352       (setf (ldb (byte 1 15) flags) (if is-response 1 0)
 353             (ldb (byte 4 11) flags) (ecase opcode
 354                                       ((:query) 0)
 355                                       ((:iquery) 1)
 356                                       ((:status) 2))
 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
 362                                      ((:success) 0)
 363                                      ((:format-error) 1)
 364                                      ((:server-failure) 2)
 365                                      ((:name-error) 3)
 366                                      ((:not-implemented) 4)
 367                                      ((:refused) 5)))
 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))
 375     (dolist (rr answers)
 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)))
 381   (values))
 382
 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)))
 388
 389 ;;; DN format
 390
 391 (defun parse-domain-name (name)
 392   (declare (type string name))
 393   (let ((l '())
 394         (p 0))
 395     (loop (let ((p2 (position #\. name :start p)))
 396             (if p2
 397                 (if (= p2 (1- (length name)))
 398                     (return (values l t))
 399                     (setf l (append l (list (subseq name p p2)))
 400                           p (1+ p2)))
 401                 (return (values (append l (list (subseq name p))) nil)))))))
 402
 403 (defun unparse-domain-name (name)
 404   (declare (type list name))
 405   (let ((buf nil))
 406     (dolist (label name buf)
 407       (setf buf (if buf
 408                     (concatenate 'string buf "." label)
 409                     label)))))
 410
 411 ;;; Basic communication
 412
 413 (define-condition name-server-timeout (dns-error)
 414   ((server :initarg :server)))
 415
 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))
 421     (loop
 422        (let ((resp (dns-decode (socket-recv sk))))
 423          (when (= (dns-packet-txid resp)
 424                 (dns-packet-txid packet))
 425            (return resp))))))
 426
 427 (defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
 428   (let ((qlist (map 'list #'(lambda (o)
 429                               (let ((name (first o))
 430                                     (type (second o)))
 431                                 (make-instance 'resource-query
 432                                                :name (etypecase name
 433                                                        (string (parse-domain-name name))
 434                                                        (list name))
 435                                                :type type)))
 436                     queries)))
 437     (make-dns-packet :txid txid
 438                      :recurse recurse
 439                      :queries qlist)))
 440
 441 ;;; RR caching
 442
 443 (defstruct domain-cache-entry
 444   (expire nil :type (or number null))
 445   (records '() :type list))
 446
 447 (defun domain-cache-key (name type)
 448   (list name (etypecase type
 449                (symbol type)
 450                (resource-record (class-name (class-of type))))))
 451
 452 (defun domain-cache-key-rr (record)
 453   (declare (type resource-record record))
 454   (list (slot-value record 'name) (class-name (class-of record))))
 455
 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)))
 461                          (and expire
 462                               (> (/ (get-internal-real-time) internal-time-units-per-second)
 463                                  expire)))))
 464       (remhash key cache)
 465       (setf cur nil))
 466     (cond (cur cur)
 467           (create
 468            (setf (gethash key cache) (make-domain-cache-entry))))))
 469
 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)))))
 474
 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)
 482                                               (with-slots (ttl) rr
 483                                                 (if ttl ttl (return-from no-expire nil))))
 484                                           matching)))))
 485             (entry (make-domain-cache-entry :expire ttl :records matching)))
 486        (setf (gethash key cache) entry
 487              records (set-difference records matching)))))
 488
 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))))
 493     (flet ((on-root (rr)
 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)))
 513
 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
 535         ;; servers.
 536         (domain-cache-get-entry table parsed 'a-record t)
 537         (domain-cache-get-entry table parsed 'aaaa-record t)
 538
 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)))))))
 542     table))
 543
 544 ;;; Resolver
 545
 546 (defstruct resolver-config
 547   (cache (make-domain-cache))
 548   (default-domains '() :type list)
 549   (help-servers '() :type list))
 550
 551 (defun initialize-default-resolver ()
 552   #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil)
 553            (when s
 554              (let ((cfg (make-resolver-config)))
 555                (labels ((whitespace-p (char)
 556                           (declare (type character char))
 557                           (or (char= char #\space)
 558                               (char= char #\tab)))
 559                         (split-line (line)
 560                           (let ((l '())
 561                                 (p 0))
 562                             (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p)
 563                                                 (return l)))
 564                                          (p2 (position-if #'whitespace-p line :start p1)))
 565                                     (if p2
 566                                         (setf l (append l (list (subseq line p1 p2)))
 567                                               p p2)
 568                                         (progn (setf l (append l (list (subseq line p1 p2))))
 569                                                (return l))))))))
 570                  (let ((domain nil)
 571                        (search '()))
 572                    (loop (let ((line (read-line s nil nil)))
 573                            (unless line (return))
 574                            (let ((line (split-line line)))
 575                              (when 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)))))
 585                  cfg))))
 586   #-unix nil)
 587
 588 (defvar *dns-resolver-config* (initialize-default-resolver))
 589
 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)
 594                  :port 53))
 595 (defmethod dns-server-address-for-record ((record aaaa-record))
 596   (make-instance 'udp6-address
 597                  :host-address (slot-value record 'address)
 598                  :port 53))
 599
 600 (define-condition dns-resolver-condition (condition)
 601   ((query-name :initarg :query-name)
 602    (query-type :initarg :query-type)
 603    (config :initarg :config)))
 604
 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)))))
 614
 615 (define-condition dns-resolver-querying (dns-resolver-condition)
 616   ((server :initarg :server)))
 617
 618 (define-condition dns-resolver-got-resp (dns-resolver-condition)
 619   ((server :initarg :server)
 620    (response :initarg :response)))
 621
 622 (define-condition dns-resolver-help (dns-resolver-condition) ())
 623 (define-condition dns-resolver-recursing (dns-resolver-condition) ())
 624
 625 (define-condition dns-resolver-following-cname (dns-resolver-condition)
 626   ((cname-rr :initarg :cname-rr)))
 627
 628 (defun dns-resolve-name (name types &key (require-all t) (config *dns-resolver-config*))
 629   (let ((name (etypecase name
 630                 (list name)
 631                 (string (parse-domain-name name))))
 632         (types (etypecase types
 633                  (list 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
 642                            :config config)
 643                    (return-from dns-resolve-name
 644                      (dns-resolve-name (slot-value record 'cname) types :config config)))))
 645              (block skip
 646                (let ((records '())
 647                      (got-some nil))
 648                  (dolist (type types)
 649                    (let ((entry (domain-cache-get-entry cache name type)))
 650                      (cond (entry
 651                             (setf records (append records (domain-cache-entry-records entry))
 652                                   got-some t))
 653                            (require-all
 654                             (return-from skip)))))
 655                  (when got-some
 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))))))
 664                (check1 name)))
 665            (do-request (server)
 666              (signal 'dns-resolver-querying :server server
 667                      :query-name (unparse-domain-name name) :query-type types
 668                      :config config)
 669              (handler-case
 670                  (let ((resp (dns-do-request (udp-address-for server 53)
 671                                              (dns-std-request (mapcar #'(lambda (type)
 672                                                                           `(,name ,type))
 673                                                                       types)))))
 674                    (signal 'dns-resolver-got-resp :server server :response resp
 675                            :query-name (unparse-domain-name name) :query-type types
 676                            :config config)
 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
 681                               :config config))
 682                      (eq resp-code :success)))
 683                (network-error () nil))))
 684       (check-cache)
 685       (signal 'dns-resolver-help :query-name (unparse-domain-name name) :query-type types
 686               :config config)
 687       (dolist (help-server (resolver-config-help-servers config))
 688         (do-request help-server)
 689         (check-cache))
 690       (signal 'dns-resolver-recursing :query-name (unparse-domain-name name) :query-type types
 691               :config config)
 692       (let ((checked-domains '()))
 693         (loop (multiple-value-bind (servers domain)
 694                   (nearest-known-servers name)
 695                 (unless servers
 696                   (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types
 697                          :config config))
 698                 (if (find domain checked-domains :test 'equal)
 699                     (error 'domain-not-found-error :query-name (unparse-domain-name name) :query-type types
 700                            :config config)
 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))
 708                                        ,@body))))))
 709                   (block found-server
 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))))))
 717                   (check-cache))))))))
 718
 719 (export '(*dns-resolver-config*))
 720
 721 ;;; Misc.
 722
 723 (defmethod print-object ((q resource-query) stream)
 724   (with-slots (name type) q
 725     (if *print-readably*
 726         (format stream "~A: ~A" type (unparse-domain-name name))
 727         (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))
 728