sockets/dns/message.lisp

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