protocols/dns-client/dns-do-query.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 (defvar *dns-nameservers* nil
  25   "List of the DNS nameservers to use.")
  26 (defvar *dns-recursion-desired* t
  27   "Whether the \"RECURSION-DESIRED\" field should be set ot not.")
  28 (defvar *dns-repeat* 5
  29   "The number of times a failed query will be retried.")
  30 (defvar *dns-timeout* 5
  31   "Timeout for DNS queries in seconds.")
  32 (defvar *dns-domain* nil
  33   "The current machine's domain.")
  34 (defvar *dns-search-domain* nil
  35   "A domain name to be appended to the name to be searched when the latter does not contain dots.")
  36
  37 (defun send-query (socket-type buffer nameserver timeout)
  38   (let ((socket (make-socket :type socket-type
  39                              :ipv6 (ipv6-address-p nameserver)))
  40         (input-buffer (make-array +dns-datagram-size+
  41                                   :element-type 'octet)))
  42     (unwind-protect
  43          (progn
  44            (connect socket nameserver :port 53)
  45            (socket-send buffer socket)
  46            (set-socket-option socket :receive-timeout :sec timeout :usec 0)
  47            (socket-receive input-buffer socket))
  48       (close socket))))
  49
  50 (define-constant +max-16-bits+ (1- (expt 2 16)))
  51
  52 (defun prepare-query (name type)
  53   (let* ((question (make-question name type :in))
  54          (query (make-query (random +max-16-bits+)
  55                             question *dns-recursion-desired*)))
  56     (write-dns-message query)))
  57
  58 (defun reverse-vector (vector)
  59   (let* ((vector-length (length vector))
  60          (reverse-vector
  61           (make-array vector-length
  62                       :element-type (array-element-type vector))))
  63     (loop
  64        :for target-index :below vector-length
  65        :for source-index := (1- vector-length) :then (1- source-index)
  66        :do (setf (aref reverse-vector target-index) (aref vector source-index)))
  67     reverse-vector))
  68
  69 (defun ipv4-dns-ptr-name (address)
  70   (declare (type (simple-array octet (4)) address))
  71   (concatenate 'string (vector-to-dotted (reverse-vector address))
  72                ".in-addr.arpa."))
  73
  74 (defun ipv6-vector-to-dotted (vector)
  75   (declare (type (simple-array ub16 (8)) vector))
  76   (with-standard-io-syntax
  77     (let ((*print-base* 16))
  78       (with-output-to-string (dotted-address)
  79         (loop
  80            :for index :below (length vector)
  81            :for element := (aref vector index)
  82            :do
  83            (when (plusp index)
  84              (princ #\. dotted-address))
  85            (princ (ldb (byte 4  0) element) dotted-address)
  86            (princ #\. dotted-address)
  87            (princ (ldb (byte 4  4) element) dotted-address)
  88            (princ #\. dotted-address)
  89            (princ (ldb (byte 4  8) element) dotted-address)
  90            (princ #\. dotted-address)
  91            (princ (ldb (byte 4 12) element) dotted-address))))))
  92
  93 (defun ipv6-dns-ptr-name (address)
  94   (declare (type (simple-array ub16 (8)) address))
  95   (concatenate 'string (ipv6-vector-to-dotted (reverse-vector address))
  96                ".ip6.arpa."))
  97
  98 (defun dns-ptr-name (address)
  99   (multiple-value-bind (vector address-type)
 100       (address-to-vector address)
 101     (when (null address)
 102       (error "The argument is not a valid IP address"))
 103     (ecase address-type
 104       (:ipv4 (ipv4-dns-ptr-name vector))
 105       (:ipv6 (ipv6-dns-ptr-name vector)))))
 106
 107
 108 ;;
 109 ;; RESOURCE RECORD decoding
 110 ;;
 111 (defgeneric do-decode-rr (rr type class))
 112
 113 (defmethod do-decode-rr ((rr dns-rr) (type (eql :cname)) class)
 114   (declare (ignore class))
 115   (let ((cname (dns-rr-data rr)))
 116     (cons (dns-rr-ttl rr)
 117           (subseq cname 0 (1- (length cname))))))
 118
 119 (defmethod do-decode-rr ((rr dns-rr) (type (eql :a)) (class (eql :in)))
 120   (let ((address (dns-rr-data rr)))
 121     (cons (dns-rr-ttl rr)
 122           (make-address address))))
 123
 124 (defmethod do-decode-rr ((rr dns-rr) (type (eql :aaaa)) (class (eql :in)))
 125   (let ((address (dns-rr-data rr)))
 126     (cons (dns-rr-ttl rr)
 127           (make-address address))))
 128
 129 (defmethod do-decode-rr ((rr dns-rr) (type (eql :ptr)) class)
 130   (declare (ignore class))
 131   (let ((name (dns-rr-data rr)))
 132     (cons (dns-rr-ttl rr)
 133           (subseq name 0 (1- (length name))))))
 134
 135 (defmethod do-decode-rr ((rr dns-rr) (type (eql :mx)) class)
 136   (declare (ignore class))
 137   (destructuring-bind (preference name) (dns-rr-data rr)
 138     (cons (dns-rr-ttl rr)
 139           (cons preference
 140                 (subseq name 0 (1- (length name)))))))
 141
 142 (defmethod do-decode-rr ((rr dns-rr) (type (eql :txt)) class)
 143   (declare (ignore class))
 144   (cons (dns-rr-ttl rr) (dns-rr-data rr)))
 145
 146 (defun decode-rr (rr)
 147   (do-decode-rr rr (dns-record-type rr) (dns-record-class rr)))
 148
 149 ;;
 150 ;; RESPONSE decoding
 151 ;;
 152 (defgeneric do-decode-response (dns-message question-type))
 153
 154 (defmethod do-decode-response :around ((msg dns-message) question-type)
 155   (let ((return-code (rcode-field msg)))
 156     (if (eql return-code :no-error) ; no error
 157         (call-next-method)
 158         (values return-code))))
 159
 160 (defun decode-a-or-aaaa-response (msg)
 161   (declare (type dns-message msg))
 162   (let ((answer (dns-message-answer msg))
 163         (answer-count (dns-message-answer-count msg))
 164         (cname nil)
 165         (first-address-place 0)
 166         (first-address nil)
 167         (other-addresses nil))
 168     ;; when the address is valid(we have at least one answer)
 169     (when (plusp answer-count)
 170       ;; we have a CNAME
 171       (when (eql (dns-record-type (aref answer 0))
 172                  :cname)
 173         (setf cname (decode-rr (aref answer 0)))
 174         (incf first-address-place))
 175       ;; this means the message actually contains addresses
 176       (when (> (dns-message-answer-count msg) first-address-place)
 177         (setf first-address (decode-rr (aref answer first-address-place))))
 178       (setf other-addresses
 179             (loop
 180                :for i :from (1+ first-address-place) :below (dns-message-answer-count msg)
 181                :collect (decode-rr (aref answer i)))))
 182     (values cname first-address other-addresses)))
 183
 184 (defmethod do-decode-response ((msg dns-message) (question-type (eql :a)))
 185   (decode-a-or-aaaa-response msg))
 186
 187 (defmethod do-decode-response ((msg dns-message) (question-type (eql :aaaa)))
 188   (decode-a-or-aaaa-response msg))
 189
 190 (defmethod do-decode-response ((msg dns-message) (question-type (eql :ptr)))
 191   (decode-rr (aref (dns-message-answer msg) 0)))
 192
 193 ;; TODO: got a lot to do here
 194 (defmethod do-decode-response ((msg dns-message) (question-type (eql :mx)))
 195   (let ((rr (aref (dns-message-answer msg) 0)))
 196     (decode-rr rr)))
 197
 198 (defmethod do-decode-response ((msg dns-message) (question-type (eql :txt)))
 199   (decode-rr (aref (dns-message-answer msg) 0)))
 200
 201 (defmethod do-decode-response ((msg dns-message) question-type)
 202   msg)
 203
 204 (defun decode-response (message)
 205   (do-decode-response message (dns-record-type (aref (dns-message-question message) 0))))
 206
 207 ;;
 208 ;; DNS-QUERY
 209 ;;
 210 (defun dns-query (name &key (type :a) (nameserver *dns-nameservers*)
 211                   (repeat *dns-repeat*) (timeout *dns-timeout*)
 212                   (decode nil) (search nil))
 213   ;; TODO: implement search
 214   (declare (ignore search))
 215
 216   (when (eq type :ptr)
 217     (setf name (dns-ptr-name name)))
 218   (let* ((query (prepare-query name type))
 219          (buffer (buffer-sequence query))
 220          (bufflen (length buffer))
 221          (tries-left repeat)
 222          in-buff bytes-received response tcp-done)
 223
 224     ;; at the moment only one nameserver is used
 225     (when (listp nameserver)
 226       (setf nameserver (car nameserver)))
 227     (assert nameserver)
 228
 229     (tagbody
 230      :start
 231        (setf tcp-done nil
 232              response nil)
 233
 234      :do-any-query
 235        ;; if the query size fits into a datagram(512 bytes max) do a
 236        ;; UDP query, otherwise use TCP
 237        ;; in case of a socket error, try again
 238        (setf (values in-buff bytes-received)
 239              (if (> bufflen +dns-datagram-size+)
 240                  (go :do-tcp-query)
 241                  (handler-case
 242                      (send-query :datagram buffer nameserver timeout)
 243                    (socket-error ()
 244                      (go :try-again-if-possible)))))
 245        ;; if no socket error, go parse the response
 246        (go :parse-response)
 247
 248      :do-tcp-query
 249        ;; do a TCP query; in case of a socket error, try again
 250        (setf (values in-buff bytes-received)
 251              (handler-case
 252                  (send-query :stream buffer nameserver timeout)
 253                (socket-error ()
 254                  (go :try-again-if-possible))))
 255        (setf tcp-done t)
 256
 257      :parse-response
 258        ;; try to parse the response; in case of a parse error, try again
 259        (setf response
 260              (handler-case
 261                  (read-dns-message
 262                   (make-instance 'dynamic-input-buffer
 263                                  :sequence in-buff
 264                                  :size bytes-received))
 265                (input-buffer-error ()
 266                  (go :try-again-if-possible))
 267                (dns-message-error ()
 268                  (go :try-again-if-possible))))
 269        ;; if a truncated response was received by UDP, try TCP
 270        (when (and (not tcp-done)
 271                   (truncated-field response))
 272          (go :do-tcp-query))
 273
 274      :try-again-if-possible
 275        (decf tries-left)
 276        ;; if no response received and there are tries left, try again
 277        (when (and (not response)
 278                   (plusp tries-left))
 279          (go :start))
 280
 281      :return-response
 282        (when response
 283          (return-from dns-query (if decode
 284                                     (decode-response response)
 285                                     response)))
 286
 287      :raise-error
 288        (error "Could not query nameserver !!"))))