protocols/dns-client/dns-response.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 (defclass dns-rr (dns-record)
  25   ((ttl  :initarg :ttl  :accessor dns-rr-ttl)
  26    (data :initarg :data :accessor dns-rr-data)))
  27
  28 (defmethod initialize-instance :after ((rr dns-rr) &key)
  29   (with-slots (ttl) rr
  30     (check-type ttl (unsigned-byte 32) "a valid TTL")))
  31
  32 (defgeneric add-question (message question))
  33 (defmethod add-question ((message dns-message)
  34                          (question dns-question))
  35   (vector-push-extend question (dns-message-question message)))
  36
  37 (defgeneric add-answer-rr (message record))
  38 (defmethod add-answer-rr ((message dns-message)
  39                           (record dns-rr))
  40   (vector-push-extend record (dns-message-answer message)))
  41
  42 (defgeneric add-authority-rr (message record))
  43 (defmethod add-authority-rr ((message dns-message)
  44                              (record dns-rr))
  45   (vector-push-extend record (dns-message-authority message)))
  46
  47 (defgeneric add-additional-rr (message record))
  48 (defmethod add-additional-rr ((message dns-message)
  49                               (record dns-rr))
  50   (vector-push-extend record (dns-message-additional message)))
  51
  52
  53 (define-condition dns-message-error (error) ()
  54   (:documentation "Signaled when a format error is encountered while parsing a DNS message"))
  55
  56 (defgeneric read-dns-string (buffer))
  57 (defmethod read-dns-string ((buffer dynamic-input-buffer))
  58   (let ((length (read-unsigned-8 buffer)))
  59     (io.encodings:octets-to-string (read-vector buffer length))))
  60
  61 (defun read-dns-pointer-recursively (sequence position
  62                                      &optional (depth 5))
  63   (when (or (<= depth 0)                          ; too deep recursion
  64             (>= position (length sequence)))      ; invalid offset
  65     (error 'dns-message-error))
  66   (let* ((value (aref sequence position))
  67          (ms2bits (logand value #xC0)))
  68     (cond
  69       ;; it's not a pointer
  70       ((zerop ms2bits) (cons position (< depth 5)))
  71
  72       ;; it's a pointer
  73       ((eql ms2bits #xC0)
  74        ;; there must be at least two bytes to read
  75        (when (>= position (1+ (length sequence)))
  76          (error 'dns-message-error))
  77        (read-dns-pointer-recursively
  78         sequence
  79         (logand (read-ub16-from-vector sequence position)
  80                 (lognot #xC000))
  81         (1- depth)))
  82
  83       ;; the most significant 2 bits are either 01 or 10
  84       (t (error 'dns-message-error)))))
  85
  86 (defun join (connector strings)
  87   (concatenate 'string (car strings)
  88                (reduce #'(lambda (str1 str2)
  89                            (concatenate 'string str1 connector str2))
  90                        (cdr strings)
  91                        :initial-value "")))
  92
  93 (defgeneric dns-domain-name-to-string (buffer))
  94 (defmethod dns-domain-name-to-string ((buffer dynamic-input-buffer))
  95   (let (string offset pointer-seen)
  96     (values
  97      (join "." (loop
  98                   :for (pointer . rec) := (read-dns-pointer-recursively
  99                                            (buffer-sequence buffer)
 100                                            (buffer-position buffer))
 101                   :do (progn
 102                         (when (not pointer-seen)
 103                           (if rec
 104                               (progn
 105                                 (setf pointer-seen t)
 106                                 (setf offset (+ (buffer-position buffer) 2)))
 107                               (setf offset (+ (buffer-position buffer) 1))))
 108                         (buffer-seek buffer pointer)
 109                         (setf string (read-dns-string buffer)))
 110                   :collect string
 111                   :until (string= string "")))
 112      offset)))
 113
 114 (defgeneric read-domain-name (buffer))
 115 (defmethod read-domain-name ((buffer dynamic-input-buffer))
 116   (with-slots (sequence position) buffer
 117     (multiple-value-bind (string offset)
 118         (dns-domain-name-to-string buffer)
 119       (setf position offset)
 120       string)))
 121
 122 (defgeneric read-question (buffer))
 123 (defmethod read-question ((buffer dynamic-input-buffer))
 124   (let ((name (read-domain-name buffer))
 125         (type (query-type-id (read-unsigned-16 buffer)))
 126         (class (query-class-id (read-unsigned-16 buffer))))
 127     (make-question name type class)))
 128
 129 (defgeneric read-rr-data (buffer type class length))
 130
 131 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 132                          (type (eql :a)) (class (eql :in))
 133                          resource-length)
 134   (unless (= resource-length 4)
 135     (error 'dns-message-error))
 136   (let ((address (make-array 4 :element-type 'octet)))
 137     (loop
 138        :for i :below 4
 139        :do (setf (aref address i) (read-unsigned-8 buffer)))
 140     address))
 141
 142 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 143                          (type (eql :aaaa)) (class (eql :in))
 144                          resource-length)
 145   (unless (= resource-length 16)
 146     (error 'dns-message-error))
 147   (let ((address (make-array 8 :element-type '(unsigned-byte 16))))
 148     (loop
 149        :for i :below 8
 150        :do (setf (aref address i) (read-unsigned-16 buffer)))
 151     address))
 152
 153 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 154                          (type (eql :cname)) (class (eql :in))
 155                          resource-length)
 156   (read-domain-name buffer)) ; CNAME
 157
 158 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 159                          (type (eql :hinfo)) (class (eql :in))
 160                          resource-length)
 161   (list (read-dns-string buffer)   ; CPU
 162         (read-dns-string buffer))) ; OS
 163
 164 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 165                          (type (eql :mx)) (class (eql :in))
 166                          resource-length)
 167   (list (read-unsigned-16 buffer)   ; PREFERENCE
 168         (read-domain-name buffer))) ; EXCHANGE
 169
 170 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 171                          (type (eql :ns)) (class (eql :in))
 172                          resource-length)
 173   (read-domain-name buffer)) ; NSDNAME
 174
 175 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 176                          (type (eql :ptr)) (class (eql :in))
 177                          resource-length)
 178   (read-domain-name buffer)) ; PTRDNAME
 179
 180 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 181                          (type (eql :soa)) (class (eql :in))
 182                          resource-length)
 183   (list (read-domain-name buffer)   ; MNAME
 184         (read-domain-name buffer)   ; RNAME
 185         (read-unsigned-32 buffer)   ; SERIAL
 186         (read-unsigned-32 buffer)   ; REFRESH
 187         (read-unsigned-32 buffer)   ; RETRY
 188         (read-unsigned-32 buffer)   ; EXPIRE
 189         (read-unsigned-32 buffer))) ; MINIMUM
 190
 191 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 192                          (type (eql :txt)) (class (eql :in))
 193                          resource-length)
 194   (loop
 195      :for string := (read-dns-string buffer) ; TXT-DATA
 196      :for total-length := (1+ (length string)) :then (+ total-length 1
 197                                                         (length string))
 198      :collect string
 199      :until (>= total-length resource-length)
 200      :finally (when (> total-length resource-length)
 201                 (error 'dns-message-error))))
 202
 203 (defmethod read-rr-data ((buffer dynamic-input-buffer)
 204                          type class resource-length)
 205   (error 'dns-message-error))
 206
 207 (defgeneric read-dns-rr (buffer))
 208 (defmethod read-dns-rr ((buffer dynamic-input-buffer))
 209   (let* ((name (read-domain-name buffer))
 210          (type (query-type-id (read-unsigned-16 buffer)))
 211          (class (query-class-id (read-unsigned-16 buffer)))
 212          (ttl (read-unsigned-32 buffer))
 213          (rdlen (read-unsigned-16 buffer))
 214          (rdata (read-rr-data buffer type class rdlen)))
 215     (make-instance 'dns-rr
 216                    :name name
 217                    :type type
 218                    :class class
 219                    :ttl ttl
 220                    :data rdata)))
 221
 222 (defgeneric read-message-header (buffer))
 223 (defmethod read-message-header ((buffer dynamic-input-buffer))
 224   (let ((id (read-unsigned-16 buffer))
 225         (flags (read-unsigned-16 buffer))
 226         (qdcount (read-unsigned-16 buffer))
 227         (ancount (read-unsigned-16 buffer))
 228         (nscount (read-unsigned-16 buffer))
 229         (arcount (read-unsigned-16 buffer)))
 230     (make-instance 'dns-message
 231                    :id id :flags flags
 232                    :qdcount qdcount :ancount ancount
 233                    :nscount nscount :arcount arcount)))
 234
 235 (defgeneric read-dns-message (buffer))
 236 (defmethod read-dns-message ((buffer dynamic-input-buffer))
 237   (let ((msg (read-message-header buffer)))
 238     (with-slots (qdcount ancount nscount arcount) msg
 239       (loop
 240          :for i :below (dns-message-question-count msg)
 241          :for q := (read-question buffer)
 242          :do (add-question msg q))
 243       (loop
 244          :for i :below (dns-message-answer-count msg)
 245          :for rr := (read-dns-rr buffer)
 246          :do (add-answer-rr msg rr))
 247       (loop
 248          :for i :below (dns-message-authority-count msg)
 249          :for rr := (read-dns-rr buffer)
 250          :do (add-authority-rr msg rr))
 251       (loop
 252          :for i :below (dns-message-additional-count msg)
 253          :for rr := (read-dns-rr buffer)
 254          :do (add-additional-rr msg rr)))
 255     msg))