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 #'car slots)))
  37     `(progn
  38        (defclass ,name (resource-record) ,slot-desc)
  39        (setf *rr-coding-types* (cons '(,name (,class ,type) ,format)
  40                                      (remove ',name *rr-coding-types* :key #'car))))))
  41
  42 (define-rr-type a-record #x1 #x1
  43                 ((address ipv4-address)))
  44 (define-rr-type ns-record #x1 #x2
  45                 ((ns-name domain-name)))
  46 (define-rr-type cname-record #x1 #x5
  47                 ((cname domain-name)))
  48 (define-rr-type soa-record #x1 #x6
  49                 ((mname domain-name)
  50                  (rname domain-name)
  51                  (serial uint-32)
  52                  (refresh uint-32)
  53                  (retry uint-32)
  54                  (expire uint-32)))
  55 (define-rr-type ptr-record #x1 #xc
  56                 ((pointed domain-name)))
  57 (define-rr-type mx-record #x1 #xf
  58                 ((prio uint-16)
  59                  (mail-host domain-name)))
  60 (define-rr-type txt-record #x1 #x10
  61                 ((text text)))
  62 (define-rr-type aaaa-record #x1 #x1c
  63                 ((address ipv6-address)))
  64 (define-rr-type srv-record #x1 #x21
  65                 ((prio uint-16)
  66                  (weigth uint-16)
  67                  (port uint-16)
  68                  (host-name domain-name)))
  69
  70 ;;; Packet decoding logic
  71
  72 (defstruct dns-decode-state
  73   (packet nil :type (array (unsigned-byte 8)))
  74   (pos 0 :type (mod 65536))
  75   (prev-names '() :type list))
  76
  77 (define-condition dns-error (error) ())
  78 (define-condition dns-decode-error (dns-error)
  79   ((packet :initarg :packet)))
  80 (define-condition simple-dns-decode-error (dns-decode-error simple-error) ())
  81
  82 (defun simple-dns-decode-error (packet format &rest args)
  83   (error 'simple-dns-decode-error :packet packet :format-control format :format-argument args))
  84
  85 (defun decode-uint-8 (buf)
  86  (declare (type dns-decode-state buf))
  87   (with-slots (packet pos) buf
  88     (when (< (- (length packet) pos) 1)
  89       (simple-dns-decode-error buf "DNS packet is too short (wanted a 8-bit number)."))
  90     (prog1 (aref packet pos)
  91       (incf pos))))
  92
  93 (defun decode-uint-16 (buf)
  94   (declare (type dns-decode-state buf))
  95   (with-slots (packet pos) buf
  96     (when (< (- (length packet) pos) 2)
  97       (simple-dns-decode-error buf "DNS packet is too short (wanted a 16-bit number)."))
  98     (prog1
  99         (+ (* (aref packet pos) 256)
 100            (aref packet (1+ pos)))
 101       (incf pos 2))))
 102
 103 (defun decode-uint-32 (buf)
 104   (declare (type dns-decode-state buf))
 105   (with-slots (packet pos) buf
 106     (when (< (- (length packet) pos) 4)
 107       (simple-dns-decode-error buf "DNS packet is too short (wanted a 32-bit number)."))
 108     (prog1
 109         (+ (* (aref packet pos) #x1000000)
 110            (* (aref packet (+ pos 1)) #x10000)
 111            (* (aref packet (+ pos 2)) #x100)
 112            (aref packet (+ pos 3)))
 113       (incf pos 2))))
 114
 115 (defun decode-domain-name (buf)
 116   (declare (type dns-decode-state buf))
 117   (let* ((orig-off (dns-decode-state-pos buf))
 118          (decoded (block decoded
 119                     (let ((l '()))
 120                       (loop (let ((len (decode-uint-8 buf)))
 121                               (case (ldb (byte 2 6) len)
 122                                 ((0)
 123                                  (when (zerop len)
 124                                    (return-from decoded l))
 125                                  (with-slots (packet pos) buf
 126                                    (setf l (append l (list (handler-bind
 127                                                                ((charcode:coding-error
 128                                                                  (lambda (c)
 129                                                                    (declare (ignore c))
 130                                                                    (simple-dns-decode-error buf "DNS label was not ASCII."))))
 131                                                              (charcode:decode-string (subseq packet
 132                                                                                              pos (+ pos len))
 133                                                                                      :ascii)))))
 134                                    (incf pos len)))
 135                                 ((3) (return-from decoded
 136                                        (let* ((offset (+ (* 256 (ldb (byte 0 6) len))
 137                                                          (decode-uint-8 buf)))
 138                                               (prev (assoc offset (dns-decode-state-prev-names buf))))
 139                                          (unless prev
 140                                            (simple-dns-decode-error buf "Domain name label pointed to non-label position"))
 141                                          (append l (cdr prev)))))
 142                                 (t (simple-dns-decode-error buf "Illegal DNS label flags: ~D" (ldb (byte 2 6) len))))))))))
 143     (push (cons orig-off decoded)
 144           (slot-value buf 'prev-names))))
 145
 146 (defun decode-dns-query (buf)
 147   (declare (type dns-decode-state buf))
 148   (let* ((name (decode-domain-name buf))
 149          (type (decode-uint-16 buf))
 150          (class (decode-uint-16 buf))
 151          (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
 152     (if desc
 153         (make-instance 'resource-query :name name :type (first desc))
 154         (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
 155                nil))))
 156
 157 (defun decode-dns-record (buf)
 158   (declare (type dns-decode-state buf))
 159   (let* ((name (decode-domain-name buf))
 160          (type (decode-uint-16 buf))
 161          (class (decode-uint-16 buf))
 162          (ttl (decode-uint-32 buf))
 163          (dlen (decode-uint-16 buf))
 164          (desc (find (list class type) *rr-coding-types* :key 'second :test 'equal)))
 165     (when (< (length (dns-decode-state-packet buf))
 166              (+ (dns-decode-state-pos buf) dlen))
 167       (simple-dns-decode-error buf "Not enough data left in DNS packet to decode indicated RR data length."))
 168     (if desc
 169         (let ((orig-off (dns-decode-state-pos buf))
 170               (rr (make-instance (first desc)
 171                                  :name name
 172                                  :ttl ttl)))
 173           (dolist (slot-desc (third desc))
 174             (destructuring-bind (slot-name type) slot-desc
 175               (setf (slot-value rr slot-name)
 176                     (with-slots (packet pos) buf
 177                       (ecase type
 178                         ((uint-16) (decode-uint-16 buf))
 179                         ((uint-32) (decode-uint-32 buf))
 180                         ((domain-name) (decode-domain-name buf))
 181                         ((text)
 182                          (let ((len (decode-uint-8 buf)))
 183                            (prog1 (subseq packet pos (+ pos len))
 184                              (incf pos len))))
 185                         ((ipv4-address)
 186                          (prog1 (make-instance 'ipv4-host-address :host-bytes (subseq packet pos (+ pos 4)))
 187                            (incf pos 4)))
 188                         ((ipv6-address)
 189                          (prog1 (make-instance 'ipv6-host-address :host-bytes (subseq packet pos (+ pos 16)))
 190                            (incf pos 16))))))))
 191           (unless (= (dns-decode-state-pos buf) (+ orig-off dlen))
 192             (simple-dns-decode-error buf "DNS RR data length did not match up with actual decoded data."))
 193           rr)
 194         (progn (warn "Unknown DNS RR type: ~D, ~D" class type)
 195                (incf (dns-decode-state-pos buf) dlen)
 196                nil))))
 197
 198 (defun decode-dns-packet (buf)
 199   (declare (type dns-decode-state buf))
 200   (let* ((txid (decode-uint-16 buf))
 201          (flags (decode-uint-16 buf))
 202          (qnum (decode-uint-16 buf))
 203          (ansnum (decode-uint-16 buf))
 204          (autnum (decode-uint-16 buf))
 205          (auxnum (decode-uint-16 buf))
 206          (packet (make-dns-packet :txid txid
 207                                   :is-response (ldb-test (byte 1 15) flags)
 208                                   :opcode (case (ldb (byte 4 11) flags)
 209                                             ((0) :query)
 210                                             ((1) :iquery)
 211                                             ((2) :status)
 212                                             (t (simple-dns-decode-error buf "Unknown DNS opcode: ~D" (ldb (byte 4 11) flags))))
 213                                   :authoritative (ldb-test (byte 1 10) flags)
 214                                   :truncated (ldb-test (byte 1 9) flags)
 215                                   :recurse (ldb-test (byte 1 8) flags)
 216                                   :will-recurse (ldb-test (byte 1 7) flags)
 217                                   :resp-code (case (ldb (byte 4 0) flags)
 218                                                ((0) :success)
 219                                                ((1) :format-error)
 220                                                ((2) :server-failure)
 221                                                ((3) :name-error)
 222                                                ((4) :not-implemented)
 223                                                ((5) :refused)
 224                                                (t (simple-dns-decode-error buf "Unknown DNS response code: ~D" (ldb (byte 4 0) flags)))))))
 225     (with-slots (queries answers authority additional) packet
 226         (dotimes (i qnum)
 227           (setf queries (append queries (list (decode-dns-query buf)))))
 228         (dotimes (i ansnum)
 229           (setf answers (append answers (list (decode-dns-record buf)))))
 230         (dotimes (i autnum)
 231           (setf authority (append authority (list (decode-dns-record buf)))))
 232         (dotimes (i auxnum)
 233           (setf additional (append additional (list (decode-dns-record buf))))))
 234     packet))
 235
 236 (defun dns-decode (packet)
 237   (decode-dns-packet (make-dns-decode-state :packet packet)))
 238
 239 ;;; Packet encoding logic
 240
 241 (defstruct dns-encode-state
 242   (packet-buf (make-array '(512) :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0) :type (array (unsigned-byte 8)))
 243   (prev-names '() :type list))
 244
 245 (defun encode-uint-8 (buf num)
 246   (declare (type dns-encode-state buf)
 247            (type (unsigned-byte 8) num))
 248   (with-slots (packet-buf) buf
 249     (vector-push-extend num packet-buf)))
 250
 251 (defun encode-uint-16 (buf num)
 252   (declare (type dns-encode-state buf)
 253            (type (unsigned-byte 16) num))
 254   (with-slots (packet-buf) buf
 255     (vector-push-extend (ldb (byte 8 8) num) packet-buf)
 256     (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
 257
 258 (defun encode-uint-32 (buf num)
 259   (declare (type dns-encode-state buf)
 260            (type (unsigned-byte 32) num))
 261   (with-slots (packet-buf) buf
 262     (vector-push-extend (ldb (byte 8 24) num) packet-buf)
 263     (vector-push-extend (ldb (byte 8 16) num) packet-buf)
 264     (vector-push-extend (ldb (byte 8 8) num) packet-buf)
 265     (vector-push-extend (ldb (byte 8 0) num) packet-buf)))
 266
 267 (defun encode-bytes (buf bytes)
 268   (declare (type dns-encode-state buf)
 269            (type (array (unsigned-byte 8)) bytes))
 270   (with-slots (packet-buf) buf
 271     (dotimes (i (length bytes) (values))
 272       (vector-push-extend (elt bytes i) packet-buf))))
 273
 274 (defun encode-domain-name (buf name)
 275   (declare (type dns-encode-state buf)
 276            (type list name))
 277   (with-slots (packet-buf prev-names) buf
 278     (labels ((encode-label (name)
 279                (let ((prev (find name prev-names :key 'first :test 'equal)))
 280                  (cond ((null name)
 281                         (encode-uint-8 buf 0))
 282                        (prev
 283                         (encode-uint-16 buf (+ #xc000 (cdr prev))))
 284                        (t
 285                         (when (< (length packet-buf) 16384)
 286                           (push (cons name (length packet-buf)) prev-names))
 287                         (let ((encoded (charcode:encode-string (car name) :ascii)))
 288                           (unless (< (length encoded) 64)
 289                             (error "DNS labels cannot exceed 63 octets in length: ~S" (car name)))
 290                           (encode-uint-8 buf (length encoded))
 291                           (encode-bytes buf encoded))
 292                         (encode-label (cdr name)))))))
 293       (encode-label name))))
 294
 295 (defun encode-dns-query (buf query)
 296   (declare (type dns-encode-state buf)
 297            (type resource-query query))
 298   (let ((desc (find (slot-value query 'type) *rr-coding-types* :key 'first)))
 299     (encode-domain-name buf (slot-value query 'name))
 300     (encode-uint-16 buf (second (second desc)))
 301     (encode-uint-16 buf (first (second desc)))))
 302
 303 (defun encode-dns-record (buf record)
 304   (declare (type dns-encode-state buf)
 305            (type resource-record record))
 306   (let ((desc (find (class-name (class-of record)) *rr-coding-types* :key 'first)))
 307     (encode-domain-name buf (slot-value record 'name))
 308     (encode-uint-16 buf (second (second desc)))
 309     (encode-uint-16 buf (first (second desc)))
 310     (encode-uint-32 buf (slot-value record 'ttl))
 311     (with-slots (packet-buf) buf
 312       (let ((orig-off (length packet-buf)))
 313         (encode-uint-16 buf 0)
 314         (dolist (slot-desc (third desc))
 315           (destructuring-bind (slot-name type) slot-desc
 316             (let ((val (slot-value record slot-name)))
 317               (ecase type
 318                 ((uint-16) (encode-uint-16 buf val))
 319                 ((uint-32) (encode-uint-32 buf val))
 320                 ((domain-name) (encode-domain-name buf val))
 321                 ((text) (let ((data (etypecase val
 322                                       (string (charcode:encode-string val :ascii))
 323                                       ((array (unsigned-byte 8)) val))))
 324                           (unless (< (length data) 256)
 325                             (error "DNS text data length cannot exceed 255 octets."))
 326                           (encode-uint-8 buf (length data))
 327                           (encode-bytes buf data)))
 328                 ((ipv4-address)
 329                  (check-type val ipv4-host-address)
 330                  (encode-bytes buf (slot-value val 'host-bytes)))
 331                 ((ipv6-address)
 332                  (check-type val ipv6-host-address)
 333                  (encode-bytes buf (slot-value val 'host-bytes)))))))
 334         (let ((dlen (- (length packet-buf) orig-off)))
 335           (setf (aref packet-buf orig-off) (ldb (byte 8 8) dlen)
 336                 (aref packet-buf (1+ orig-off)) (ldb (byte 8 0) dlen)))))))
 337
 338 (defun encode-dns-packet (buf packet)
 339   (declare (type dns-encode-state buf)
 340            (type dns-packet packet))
 341   (with-slots (txid is-response opcode authoritative truncated
 342                     recurse will-recurse resp-code
 343                     queries answers authority additional) packet
 344     (encode-uint-16 buf txid)
 345     (let ((flags 0))
 346       (setf (ldb (byte 1 15) flags) (if is-response 1 0)
 347             (ldb (byte 4 11) flags) (ecase opcode
 348                                       ((:query) 0)
 349                                       ((:iquery) 1)
 350                                       ((:status) 2))
 351             (ldb (byte 1 10) flags) (if authoritative 1 0)
 352             (ldb (byte 1 9) flags) (if truncated 1 0)
 353             (ldb (byte 1 8) flags) (if recurse 1 0)
 354             (ldb (byte 1 7) flags) (if will-recurse 1 0)
 355             (ldb (byte 4 0) flags) (ecase resp-code
 356                                      ((:success) 0)
 357                                      ((:format-error) 1)
 358                                      ((:server-failure) 2)
 359                                      ((:name-error) 3)
 360                                      ((:not-implemented) 4)
 361                                      ((:refused) 5)))
 362       (encode-uint-16 buf flags))
 363     (encode-uint-16 buf (length queries))
 364     (encode-uint-16 buf (length answers))
 365     (encode-uint-16 buf (length authority))
 366     (encode-uint-16 buf (length additional))
 367     (dolist (query queries)
 368       (encode-dns-query buf query))
 369     (dolist (rr answers)
 370       (encode-dns-record buf rr))
 371     (dolist (rr authority)
 372       (encode-dns-record buf rr))
 373     (dolist (rr additional)
 374       (encode-dns-record buf rr)))
 375   (values))
 376
 377 (defun dns-encode (packet)
 378   (check-type packet dns-packet)
 379   (let ((buf (make-dns-encode-state)))
 380     (encode-dns-packet buf packet)
 381     (slot-value buf 'packet-buf)))