src/sockets/dns/message.lisp

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