net.sockets/dns/message.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- DNS message creation.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 (defclass dns-message ()
   9   ((id    :initform 0 :initarg :id    :accessor dns-message-id)
  10    (flags :initform 0 :initarg :flags :accessor dns-message-flags)
  11    (decoded-flags :initform nil :accessor dns-message-decoded-flags)
  12    (qdcount :initarg :qdcount :accessor dns-message-question-count)
  13    (ancount :initarg :ancount :accessor dns-message-answer-count)
  14    (nscount :initarg :nscount :accessor dns-message-authority-count)
  15    (arcount :initarg :arcount :accessor dns-message-additional-count)
  16    (question   :accessor dns-message-question)
  17    (answer     :accessor dns-message-answer)
  18    (authority  :accessor dns-message-authority)
  19    (additional :accessor dns-message-additional))
  20   (:default-initargs :qdcount 1 :ancount 0 :nscount 0 :arcount 0))
  21
  22 (defmacro define-flags-bitfield (name offset length &optional (type :integer))
  23   (let ((method-name (format-symbol t "~A-FIELD" name)))
  24     `(progn
  25        (defgeneric ,method-name (message)
  26          (:method ((message dns-message))
  27            ,(ecase type
  28                    (:integer `(ldb (byte ,length ,offset)
  29                                    (dns-message-flags message)))
  30                    (:boolean `(logbitp ,offset (dns-message-flags message)))
  31                    (:rcode `(rcode-id
  32                              (ldb (byte ,length ,offset)
  33                                   (dns-message-flags message)))))))
  34        (defgeneric (setf ,method-name) (value message)
  35          (:method (value (message dns-message))
  36            ,(ecase type
  37                    (:integer `(setf (ldb (byte ,length ,offset)
  38                                          (dns-message-flags message))
  39                                     value))
  40                    (:boolean `(setf (ldb (byte ,length ,offset)
  41                                          (dns-message-flags message))
  42                                     (lisp->c-bool value)))
  43                    (:rcode `(setf (ldb (byte ,length ,offset)
  44                                        (dns-message-flags message))
  45                                   (rcode-number value)))))))))
  46
  47 (define-flags-bitfield response 15 1 :boolean)
  48 (define-flags-bitfield opcode 11 4 :integer)
  49 (define-flags-bitfield authoritative 10 1 :boolean)
  50 (define-flags-bitfield truncated 9 1 :boolean)
  51 (define-flags-bitfield recursion-desired 8 1 :boolean)
  52 (define-flags-bitfield recursion-available 7 1 :boolean)
  53 (define-flags-bitfield rcode 0 4 :rcode)
  54
  55 (defgeneric decode-flags (message)
  56   (:method ((msg dns-message))
  57     (let (flags)
  58       (push (if (= (opcode-field msg) +opcode-standard+)
  59                 :op/s :op/u)
  60             flags)
  61       (when (authoritative-field msg) (push :auth flags))
  62       (when (truncated-field msg) (push :trunc flags))
  63       (when (recursion-desired-field msg) (push :rd flags))
  64       (when (recursion-available-field msg) (push :ra flags))
  65       (push (or (rcode-field msg) :rc/u) flags)
  66       (nreverse flags))))
  67
  68 (defgeneric dns-flag-p (message flag)
  69   (:method ((msg dns-message) flag)
  70     (member flag (dns-message-decoded-flags msg) :test #'eq)))
  71
  72 (defmethod initialize-instance :after ((msg dns-message) &key
  73                                        (qdcount 0) (ancount 0)
  74                                        (nscount 0) (arcount 0))
  75   (with-accessors ((id dns-message-id) (flags dns-message-flags)
  76                    (decoded-flags dns-message-decoded-flags)
  77                    (question dns-message-question) (answer dns-message-answer)
  78                    (authority dns-message-authority) (additional dns-message-additional))
  79       msg
  80     (setf decoded-flags (decode-flags msg)
  81           question      (make-array qdcount :adjustable t :fill-pointer 0)
  82           answer        (make-array ancount :adjustable t :fill-pointer 0)
  83           authority     (make-array nscount :adjustable t :fill-pointer 0)
  84           additional    (make-array arcount :adjustable t :fill-pointer 0))))
  85
  86 (defmethod print-object ((msg dns-message) stream)
  87   (print-unreadable-object (msg stream :type nil :identity nil)
  88     (with-accessors ((id dns-message-id) (decoded-flags dns-message-decoded-flags)
  89                      (question dns-message-question)
  90                      (qdcount dns-message-question-count) (ancount dns-message-answer-count)
  91                      (nscount dns-message-authority-count) (arcount dns-message-additional-count))
  92         msg
  93       (format stream "DNS ~A Id: ~A, Question: ~A Flags: ~S, Sections: QD(~A) AN(~A) NS(~A) AD(~A)"
  94               (if (response-field msg) :response :query)
  95               id question decoded-flags
  96               qdcount ancount nscount arcount))))
  97
  98 (defclass dns-record ()
  99   ((name  :initarg :name  :accessor dns-record-name)
 100    (type  :initarg :type  :accessor dns-record-type)
 101    (class :initarg :class :accessor dns-record-class)))
 102
 103 (defmethod initialize-instance :after ((record dns-record) &key)
 104   (with-accessors ((name dns-record-name)
 105                    (type dns-record-type)
 106                    (class dns-record-class))
 107       record
 108     (check-type name string "a string")
 109     (check-type type (satisfies dns-record-type-p) "a valid record type")
 110     (check-type class (member :in) ":IN")))
 111
 112 (defclass dns-question (dns-record) ())
 113
 114 (defmethod print-object ((question dns-question) stream)
 115   (print-unreadable-object (question stream :type nil :identity nil)
 116     (with-accessors ((name dns-record-name)
 117                      (type dns-record-type)
 118                      (class dns-record-class))
 119         question
 120       (format stream "~S ~A ~A" name type class))))
 121
 122 (defmethod initialize-instance :after ((record dns-question) &key)
 123   (with-accessors ((name dns-record-name)) record
 124     (let ((name-length (length name)))
 125       (when (char/= #\. (aref name (1- name-length)))
 126         (setf name (concatenate 'string name "."))))))
 127 \f
 128 ;;;; Constructors
 129
 130 (defun make-question (qname qtype qclass)
 131   (make-instance 'dns-question
 132                  :name qname
 133                  :type qtype
 134                  :class qclass))
 135
 136 (defun make-query (id question &optional recursion-desired)
 137   (let ((msg (make-instance 'dns-message :id id)))
 138     (setf (opcode-field msg) +opcode-standard+)
 139     (setf (recursion-desired-field msg) recursion-desired)
 140     (vector-push-extend question (dns-message-question msg))
 141     (values msg)))
 142 \f
 143 ;;;; DNS types
 144
 145 (defgeneric write-dns-string (buffer string)
 146   (:method ((buffer dynamic-buffer) (string string))
 147     (write-ub8 buffer (length string))
 148     ;; Probably want to use punnycode here.
 149     (write-vector buffer (babel:string-to-octets string :encoding :ascii))))
 150
 151 (defun domain-name-to-dns-format (domain-name)
 152   (let* ((octets (babel:string-to-octets domain-name :encoding :ascii))
 153          (tmp-vec (make-array (1+ (length octets)) :element-type 'ub8)))
 154     (replace tmp-vec octets :start1 1)
 155     (let ((vector-length (length tmp-vec)))
 156       (loop :for start-off := 1 :then (1+ end-off)
 157             :for end-off := (or (position (char-code #\.) tmp-vec
 158                                           :start start-off)
 159                                 vector-length)
 160             :do (setf (aref tmp-vec (1- start-off)) (- end-off start-off))
 161             :when (>= end-off vector-length) do (loop-finish)))
 162     (values tmp-vec)))
 163
 164 (defgeneric write-domain-name (buffer name)
 165   (:method ((buffer dynamic-buffer)
 166             (domain-name string))
 167     (write-vector buffer (domain-name-to-dns-format domain-name))))
 168
 169 (defgeneric write-record (buffer record)
 170   (:method ((buffer dynamic-buffer)
 171             (record dns-question))
 172     (with-accessors ((name dns-record-name)
 173                      (type dns-record-type)
 174                      (class dns-record-class))
 175         record
 176       (write-domain-name buffer name)
 177       (write-ub16 buffer (query-type-number type))
 178       (write-ub16 buffer (query-class-number class)))))
 179
 180 (defgeneric write-message-header (buffer message)
 181   (:method ((buffer dynamic-buffer)
 182             (message dns-message))
 183     (with-accessors ((id dns-message-id) (flags dns-message-flags)
 184                      (question dns-message-question) (answer dns-message-answer)
 185                      (authority dns-message-authority) (additional dns-message-additional))
 186         message
 187       (write-ub16 buffer id)
 188       (write-ub16 buffer flags)
 189       (write-ub16 buffer (length question))
 190       (write-ub16 buffer (length answer))
 191       (write-ub16 buffer (length authority))
 192       (write-ub16 buffer (length additional)))))
 193
 194 (defgeneric write-dns-message (message)
 195   (:method ((message dns-message))
 196     (with-accessors ((question dns-message-question)) message
 197       (with-dynamic-buffer (buffer)
 198         (write-message-header buffer message)
 199         (write-record buffer (aref question 0))))))
 200 \f
 201 ;;;; Resource Record Encoding
 202
 203 (defclass dns-rr (dns-record)
 204   ((ttl  :initarg :ttl  :accessor dns-rr-ttl)
 205    (data :initarg :data :accessor dns-rr-data)))
 206
 207 (defmethod print-object ((rr dns-rr) stream)
 208   (print-unreadable-object (rr stream :type nil :identity nil)
 209     (with-accessors ((name dns-record-name) (type dns-record-type)
 210                      (class dns-record-class) (ttl dns-rr-ttl)
 211                      (data dns-rr-data))
 212         rr
 213       (format stream "~S ~A ~A: ~A" name type class
 214               (decode-rr rr)))))
 215
 216 (defmethod initialize-instance :after ((rr dns-rr) &key)
 217   (with-accessors ((ttl dns-rr-ttl)) rr
 218     (check-type ttl (unsigned-byte 32) "a valid TTL")))
 219
 220 (defgeneric add-question (message question)
 221   (:method ((message dns-message)
 222             (question dns-question))
 223     (vector-push-extend question (dns-message-question message))))
 224
 225 (defgeneric add-answer-rr (message record)
 226   (:method ((message dns-message)
 227             (record dns-rr))
 228     (vector-push-extend record (dns-message-answer message))))
 229
 230 (defgeneric add-authority-rr (message record)
 231   (:method ((message dns-message)
 232             (record dns-rr))
 233     (vector-push-extend record (dns-message-authority message))))
 234
 235 (defgeneric add-additional-rr (message record)
 236   (:method ((message dns-message)
 237             (record dns-rr))
 238     (vector-push-extend record (dns-message-additional message))))
 239
 240
 241 (define-condition dns-message-error (error) ()
 242   (:documentation
 243    "Signaled when a format error is encountered while parsing a DNS message"))
 244
 245 (defgeneric read-dns-string (buffer)
 246   (:method ((buffer dynamic-buffer))
 247     (let ((length (read-ub8 buffer)))
 248       (babel:octets-to-string (read-vector buffer length) :encoding :ascii))))
 249
 250 (defun read-dns-pointer-recursively (sequence position
 251                                      &optional (depth 5))
 252   (when (or (<= depth 0)                          ; too deep recursion
 253             (>= position (length sequence)))      ; invalid offset
 254     (error 'dns-message-error))
 255   (let* ((value (aref sequence position))
 256          (ms2bits (logand value #xC0)))
 257     (cond
 258       ;; it's not a pointer
 259       ((zerop ms2bits) (cons position (< depth 5)))
 260       ;; it's a pointer
 261       ((= ms2bits #xC0)
 262        ;; there must be at least two bytes to read
 263        (when (>= position (1+ (length sequence)))
 264          (error 'dns-message-error))
 265        (read-dns-pointer-recursively
 266         sequence
 267         (logand (read-ub16-from-vector sequence position)
 268                 (lognot #xC000))
 269         (1- depth)))
 270       ;; the most significant 2 bits are either 01 or 10
 271       (t (error 'dns-message-error)))))
 272
 273 (defun join (delimiter strings)
 274   (collect-append 'string (spread (catenate #Z(0) (series 1))
 275                                   (scan strings)
 276                                   (string delimiter))))
 277
 278 (defgeneric dns-domain-name-to-string (buffer)
 279   (:method ((buffer dynamic-buffer))
 280     (let (string offset pointer-seen)
 281       (labels ((%deref-dns-string (pointer rec)
 282                  (when (not pointer-seen)
 283                    (cond (rec
 284                           (setf pointer-seen t)
 285                           (setf offset (+ (read-cursor-of buffer) 2)))
 286                          (t
 287                           (setf offset (+ (read-cursor-of buffer) 1)))))
 288                  (dynamic-buffer-seek-read-cursor buffer :offset pointer)
 289                  (setf string (read-dns-string buffer)))
 290                (%read-tags ()
 291                  (loop :for (pointer . rec) := (read-dns-pointer-recursively
 292                                                 (sequence-of buffer)
 293                                                 (read-cursor-of buffer))
 294                        :do (%deref-dns-string pointer rec)
 295                        :collect string
 296                        :until (string= string ""))))
 297         (values (join "." (%read-tags)) offset)))))
 298
 299 (defgeneric read-domain-name (buffer)
 300   (:method ((buffer dynamic-buffer))
 301     (multiple-value-bind (string offset)
 302         (dns-domain-name-to-string buffer)
 303       (dynamic-buffer-seek-read-cursor buffer :offset offset)
 304       (values string))))
 305
 306 (defgeneric read-question (buffer)
 307   (:method ((buffer dynamic-buffer))
 308     (let ((name (read-domain-name buffer))
 309           (type (query-type-id (read-ub16 buffer)))
 310           (class (query-class-id (read-ub16 buffer))))
 311       (make-question name type class))))
 312
 313 (defgeneric read-rr-data (buffer type class length))
 314
 315 (defmethod read-rr-data ((buffer dynamic-buffer)
 316                          (type (eql :a)) (class (eql :in))
 317                          resource-length)
 318   (unless (= resource-length 4)
 319     (error 'dns-message-error))
 320   (let ((address (make-array 4 :element-type 'ub8)))
 321     (dotimes (i 4)
 322       (setf (aref address i) (read-ub8 buffer)))
 323     address))
 324
 325 (defmethod read-rr-data ((buffer dynamic-buffer)
 326                          (type (eql :aaaa)) (class (eql :in))
 327                          resource-length)
 328   (unless (= resource-length 16)
 329     (error 'dns-message-error))
 330   (let ((address (make-array 8 :element-type '(unsigned-byte 16))))
 331     (dotimes (i 8)
 332       (setf (aref address i) (read-ub16 buffer)))
 333     address))
 334
 335 (defmethod read-rr-data ((buffer dynamic-buffer)
 336                          (type (eql :cname)) (class (eql :in))
 337                          resource-length)
 338   (declare (ignore resource-length))
 339   (read-domain-name buffer))            ; CNAME
 340
 341 (defmethod read-rr-data ((buffer dynamic-buffer)
 342                          (type (eql :hinfo)) (class (eql :in))
 343                          resource-length)
 344   (declare (ignore resource-length))
 345   (list (read-dns-string buffer)        ; CPU
 346         (read-dns-string buffer)))      ; OS
 347
 348 (defmethod read-rr-data ((buffer dynamic-buffer)
 349                          (type (eql :mx)) (class (eql :in))
 350                          resource-length)
 351   (declare (ignore resource-length))
 352   (list (read-ub16 buffer)              ; PREFERENCE
 353         (read-domain-name buffer)))     ; EXCHANGE
 354
 355 (defmethod read-rr-data ((buffer dynamic-buffer)
 356                          (type (eql :ns)) (class (eql :in))
 357                          resource-length)
 358   (declare (ignore resource-length))
 359   (read-domain-name buffer))            ; NSDNAME
 360
 361 (defmethod read-rr-data ((buffer dynamic-buffer)
 362                          (type (eql :ptr)) (class (eql :in))
 363                          resource-length)
 364   (declare (ignore resource-length))
 365   (read-domain-name buffer))            ; PTRDNAME
 366
 367 (defmethod read-rr-data ((buffer dynamic-buffer)
 368                          (type (eql :soa)) (class (eql :in))
 369                          resource-length)
 370   (declare (ignore type class resource-length))
 371   (list (read-domain-name buffer)       ; MNAME
 372         (read-domain-name buffer)       ; RNAME
 373         (read-ub32 buffer)              ; SERIAL
 374         (read-ub32 buffer)              ; REFRESH
 375         (read-ub32 buffer)              ; RETRY
 376         (read-ub32 buffer)              ; EXPIRE
 377         (read-ub32 buffer)))            ; MINIMUM
 378
 379 (defmethod read-rr-data ((buffer dynamic-buffer)
 380                          (type (eql :txt)) (class (eql :in))
 381                          resource-length)
 382   (declare (ignore type class))
 383   (loop :for string := (read-dns-string buffer) ; TXT-DATA
 384         :for total-length := (1+ (length string))
 385         :then (+ total-length 1 (length string))
 386         :collect string
 387         :until (>= total-length resource-length)
 388         :finally (when (> total-length resource-length)
 389                    (error 'dns-message-error))))
 390
 391 (defmethod read-rr-data ((buffer dynamic-buffer)
 392                          type class resource-length)
 393   (declare (ignore buffer type class resource-length))
 394   (error 'dns-message-error))
 395
 396 (defgeneric read-dns-rr (buffer)
 397   (:method ((buffer dynamic-buffer))
 398     (let* ((name (read-domain-name buffer))
 399            (type (query-type-id (read-ub16 buffer)))
 400            (class (query-class-id (read-ub16 buffer)))
 401            (ttl (read-ub32 buffer))
 402            (rdlen (read-ub16 buffer))
 403            (rdata (read-rr-data buffer type class rdlen)))
 404       (make-instance 'dns-rr
 405                      :name name
 406                      :type type
 407                      :class class
 408                      :ttl ttl
 409                      :data rdata))))
 410
 411 (defgeneric read-message-header (buffer)
 412   (:method ((buffer dynamic-buffer))
 413     (let ((id (read-ub16 buffer))
 414           (flags (read-ub16 buffer))
 415           (qdcount (read-ub16 buffer))
 416           (ancount (read-ub16 buffer))
 417           (nscount (read-ub16 buffer))
 418           (arcount (read-ub16 buffer)))
 419       (make-instance 'dns-message
 420                      :id id :flags flags
 421                      :qdcount qdcount :ancount ancount
 422                      :nscount nscount :arcount arcount))))
 423
 424 (defgeneric read-dns-message (buffer)
 425   (:method ((buffer dynamic-buffer))
 426     (let ((msg (read-message-header buffer)))
 427       (with-accessors ((qdcount dns-message-question-count)
 428                        (ancount dns-message-answer-count)
 429                        (nscount dns-message-authority-count)
 430                        (arcount dns-message-additional-count))
 431           msg
 432         (loop :for i :below (dns-message-question-count msg)
 433               :for q := (read-question buffer)
 434               :do (add-question msg q))
 435         (loop :for i :below (dns-message-answer-count msg)
 436               :for rr := (read-dns-rr buffer)
 437               :do (add-answer-rr msg rr))
 438         (loop :for i :below (dns-message-authority-count msg)
 439               :for rr := (read-dns-rr buffer)
 440               :do (add-authority-rr msg rr))
 441         (loop :for i :below (dns-message-additional-count msg)
 442               :for rr := (read-dns-rr buffer)
 443               :do (add-additional-rr msg rr)))
 444       (values msg))))