sockets/dns/query.lisp

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