protocols/dns-client/dns-response.lisp

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