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 (defun dns-do-request (server packet)
 411   (declare (type address server)
 412            (type dns-packet packet))
 413   (with-connection (sk server)
 414     (socket-send sk (dns-encode packet))
 415     (loop
 416        (let ((resp (dns-decode (socket-recv sk))))
 417          (when (= (dns-packet-txid resp)
 418                 (dns-packet-txid packet))
 419            (return resp))))))
 420
 421 (defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
 422   (let ((qlist (map 'list #'(lambda (o)
 423                               (let ((name (first o))
 424                                     (type (second o)))
 425                                 (make-instance 'resource-query
 426                                                :name (etypecase name
 427                                                        (string (parse-domain-name name))
 428                                                        (list name))
 429                                                :type type)))
 430                     queries)))
 431     (make-dns-packet :txid txid
 432                      :recurse recurse
 433                      :queries qlist)))
 434
 435 ;;; RR caching
 436
 437 (defstruct domain-cache-entry
 438   (time (get-internal-real-time) :type unsigned-byte)
 439   (records '() :type list))
 440
 441 (defun domain-cache-get-entry (cache name type &optional create)
 442   (let* ((key (list name (etypecase type
 443                            (symbol type)
 444                            (resource-record (class-name (class-of type))))))
 445          (cur (gethash key cache)))
 446     (block no-expire
 447       (when (and cur (domain-cache-entry-records cur)
 448                  (> (get-internal-real-time)
 449                     (+ (domain-cache-entry-time cur)
 450                        (apply 'min (mapcar #'(lambda (o)
 451                                                (declare (type resource-record o))
 452                                                (with-slots (ttl) o
 453                                                  (unless ttl (return-from no-expire))
 454                                                  ttl))
 455                                            (domain-cache-entry-records cur))))))
 456         (remhash key cache)
 457         (setf cur nil)))
 458     (cond (cur cur)
 459           (create
 460            (setf (gethash key cache) (make-domain-cache-entry))))))
 461
 462 (defun domain-cache-put (cache record)
 463   (with-slots (name ttl) record
 464     (let ((entry (domain-cache-get-entry cache name record t)))
 465       (push record (domain-cache-entry-records entry)))))
 466
 467 (defun make-domain-cache ()
 468   (let ((table (make-hash-table :test 'equal)))
 469     (dolist (server (labels ((ipv4 (address)
 470                                (make-instance 'ipv4-host-address :host-string address)))
 471                       `(("a.root-servers.net" ,(ipv4 "198.41.0.4"))
 472                         ("b.root-servers.net" ,(ipv4 "192.228.79.201"))
 473                         ("c.root-servers.net" ,(ipv4 "192.33.4.12"))
 474                         ("d.root-servers.net" ,(ipv4 "128.8.10.90"))
 475                         ("e.root-servers.net" ,(ipv4 "192.203.230.10"))
 476                         ("f.root-servers.net" ,(ipv4 "192.5.5.241"))
 477                         ("g.root-servers.net" ,(ipv4 "192.112.36.4"))
 478                         ("h.root-servers.net" ,(ipv4 "128.63.2.53"))
 479                         ("i.root-servers.net" ,(ipv4 "192.36.148.17"))
 480                         ("j.root-servers.net" ,(ipv4 "192.58.128.30"))
 481                         ("k.root-servers.net" ,(ipv4 "193.0.14.129"))
 482                         ("l.root-servers.net" ,(ipv4 "199.7.83.42"))
 483                         ("m.root-servers.net" ,(ipv4 "202.12.27.33")))))
 484       (let ((parsed (parse-domain-name (first server))))
 485         (domain-cache-put table (make-instance 'ns-record :name '() :ttl nil :ns-name parsed))
 486         (dolist (address (cdr server))
 487           (domain-cache-put table (etypecase address
 488                                     (ipv4-host-address (make-instance 'a-record :name parsed :ttl nil :address address)))))))
 489     table))
 490
 491 ;;; Resolver
 492
 493 (defstruct resolver-config
 494   (cache (make-domain-cache))
 495   (default-domains '() :type list)
 496   (help-servers '() :type list))
 497
 498 (defun initialize-default-resolver ()
 499   #+unix (with-open-file (s #p"/etc/resolv.conf" :if-does-not-exist nil)
 500            (when s
 501              (let ((cfg (make-resolver-config)))
 502                (labels ((whitespace-p (char)
 503                           (declare (type character char))
 504                           (or (char= char #\space)
 505                               (char= char #\tab)))
 506                         (split-line (line)
 507                           (let ((l '())
 508                                 (p 0))
 509                             (loop (let* ((p1 (or (position-if-not #'whitespace-p line :start p)
 510                                                 (return l)))
 511                                          (p2 (position-if #'whitespace-p line :start p1)))
 512                                     (if p2
 513                                         (setf l (append l (list (subseq line p1 p2)))
 514                                               p p2)
 515                                         (progn (setf l (append l (list (subseq line p1 p2))))
 516                                                (return l))))))))
 517                  (let ((domain nil)
 518                        (search '()))
 519                    (loop (let ((line (read-line s nil nil)))
 520                            (unless line (return))
 521                            (let ((line (split-line line)))
 522                              (when line
 523                                (cond ((equal (car line) "nameserver")
 524                                       (push (make-instance 'ipv4-address :host-string (second line))
 525                                             (resolver-config-help-servers cfg)))
 526                                      ((equal (car line) "search")
 527                                       (setf search (append search (cdr line))))
 528                                      ((equal (car line) "domain")
 529                                       (setf domain (second line))))))))
 530                    (setf (resolver-config-default-domains cfg)
 531                          (or search (and domain (list domain)))))
 532                  cfg))))
 533   #-unix nil)
 534
 535 (defvar *resolver-config* (initialize-default-resolver))
 536
 537
 538
 539 ;;; Misc.
 540
 541 (defmethod print-object ((q resource-query) stream)
 542   (with-slots (name type) q
 543     (if *print-readably*
 544         (format stream "~A: ~A" type (unparse-domain-name name))
 545         (format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))
 546