net.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-2008, 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* 3
  30   "The number of times a failed query will be retried.")
  31
  32 (defvar *dns-timeout* 10
  33   "Timeout for DNS queries in seconds.")
  34
  35 (define-constant +max-16-bits+ (1- (expt 2 16)))
  36
  37 (defun prepare-query (name type)
  38   (let* ((question (make-question name type :in))
  39          (query (make-query (random +max-16-bits+)
  40                             question *dns-recursion-desired*)))
  41     (write-dns-message query)))
  42
  43 (defun reverse-vector (vector)
  44   (let* ((vector-length (length vector))
  45          (reverse-vector
  46           (make-array vector-length
  47                       :element-type (array-element-type vector))))
  48     (loop :for target-index :below vector-length
  49           :for source-index := (- vector-length target-index 1)
  50           :do (setf (aref reverse-vector target-index)
  51                     (aref vector source-index)))
  52     (values reverse-vector)))
  53
  54 (defun ipv4-dns-ptr-name (address)
  55   (declare (type ipv4-array address))
  56   (concatenate 'string (vector-to-dotted (reverse-vector address))
  57                ".in-addr.arpa."))
  58
  59 (defun ipv6-vector-to-dotted (vector)
  60   (declare (type ipv6-array vector))
  61   (with-standard-io-syntax
  62     (let ((*print-base* 16))
  63       (with-output-to-string (dotted-address)
  64         (loop :for index :below (length vector)
  65               :for element := (aref vector index) :do
  66               (when (plusp index)
  67                 (princ #\. dotted-address))
  68               (princ (ldb (byte 4  0) element) dotted-address)
  69               (princ #\. dotted-address)
  70               (princ (ldb (byte 4  4) element) dotted-address)
  71               (princ #\. dotted-address)
  72               (princ (ldb (byte 4  8) element) dotted-address)
  73               (princ #\. dotted-address)
  74               (princ (ldb (byte 4 12) element) dotted-address))))))
  75
  76 (defun ipv6-dns-ptr-name (address)
  77   (declare (type (simple-array ub16 (8)) address))
  78   (concatenate 'string (ipv6-vector-to-dotted (reverse-vector address))
  79                ".ip6.arpa."))
  80
  81 (defun dns-ptr-name (address)
  82   (multiple-value-bind (vector address-type)
  83       (address-to-vector address)
  84     (when (null address)
  85       (error "The argument is not a valid IP address"))
  86     (ecase address-type
  87       (:ipv4 (ipv4-dns-ptr-name vector))
  88       (:ipv6 (ipv6-dns-ptr-name vector)))))
  89
  90 ;;;; Resource Record Decoding
  91
  92 (defgeneric %decode-rr (rr type class))
  93
  94 (defmethod %decode-rr ((rr dns-rr) type class)
  95   (declare (ignore type class))
  96   (cons (dns-rr-ttl rr) (dns-rr-data rr)))
  97
  98 (defmethod %decode-rr ((rr dns-rr) (type (eql :cname)) class)
  99   (declare (ignore class))
 100   (let ((cname (dns-rr-data rr)))
 101     (cons (dns-rr-ttl rr)
 102           (subseq cname 0 (1- (length cname))))))
 103
 104 (defmethod %decode-rr ((rr dns-rr) (type (eql :a)) (class (eql :in)))
 105   (let ((address (dns-rr-data rr)))
 106     (cons (dns-rr-ttl rr)
 107           (make-address address))))
 108
 109 (defmethod %decode-rr ((rr dns-rr) (type (eql :aaaa)) (class (eql :in)))
 110   (let ((address (dns-rr-data rr)))
 111     (cons (dns-rr-ttl rr)
 112           (make-address address))))
 113
 114 (defmethod %decode-rr ((rr dns-rr) (type (eql :ptr)) class)
 115   (declare (ignore class))
 116   (let ((name (dns-rr-data rr)))
 117     (cons (dns-rr-ttl rr)
 118           (subseq name 0 (1- (length name))))))
 119
 120 (defmethod %decode-rr ((rr dns-rr) (type (eql :mx)) class)
 121   (declare (ignore class))
 122   (destructuring-bind (preference name) (dns-rr-data rr)
 123     (cons (dns-rr-ttl rr)
 124           (cons preference
 125                 (subseq name 0 (1- (length name)))))))
 126
 127 (defun decode-rr (rr)
 128   (%decode-rr rr (dns-record-type rr) (dns-record-class rr)))
 129
 130 ;;;; Response Decoding
 131
 132 (defgeneric %decode-response (dns-message question-type))
 133
 134 (defmethod %decode-response :around ((msg dns-message) question-type)
 135   (declare (ignore question-type))
 136   (let ((return-code (rcode-field msg)))
 137     (if (eq :no-error return-code) ; no error
 138         (call-next-method)
 139         (values return-code))))
 140
 141 (defun remove-trailing-dot (string)
 142   (assert (>= (length string) 2) (string)
 143           "String length must be at least 2: ~S" string)
 144   (assert (char= #\. (char string (1- (length string)))) (string)
 145           "Must end with a dot: ~S" string)
 146   (subseq string 0 (1- (length string))))
 147
 148 (defun find-cname (msg)
 149   (let ((answer (dns-message-answer msg))
 150         (answer-count (dns-message-answer-count msg))
 151         (cnames (make-hash-table :test 'equal :size 3))
 152         (consumed 0))
 153     (loop :for i :below answer-count
 154           :for ans := (aref answer i) :do
 155           (if (eq :cname (dns-record-type ans))
 156               (setf (gethash (dns-record-name ans) cnames)
 157                     (dns-rr-data ans))
 158               (loop-finish))
 159           :finally (setf consumed i))
 160     (do ((cname (dns-record-name (aref (dns-message-question msg) 0)))
 161          (exit nil))
 162         (exit (values (remove-trailing-dot cname) consumed))
 163       (let ((name (gethash cname cnames)))
 164         (cond (name
 165                (remhash cname cnames)
 166                (setf cname name))
 167               (t (setf exit t)))))))
 168
 169 (defun decode-a-or-aaaa-response (msg)
 170   (declare (type dns-message msg))
 171   (let ((answer (dns-message-answer msg))
 172         (answer-count (dns-message-answer-count msg))
 173         (cname nil)
 174         (first-address-place 0)
 175         (first-address nil)
 176         (other-addresses nil))
 177     ;; when the address is valid(we have at least one answer)
 178     (when (plusp answer-count)
 179       (setf (values cname first-address-place) (find-cname msg))
 180       ;; this means the message actually contains addresses
 181       (when (> (dns-message-answer-count msg) first-address-place)
 182         (setf first-address (decode-rr (aref answer first-address-place))))
 183       (setf other-addresses
 184             (loop :for i :from (1+ first-address-place)
 185                   :below (dns-message-answer-count msg)
 186                   :collect (decode-rr (aref answer i)))))
 187     (values cname first-address other-addresses)))
 188
 189 (defmethod %decode-response ((msg dns-message) (question-type (eql :a)))
 190   (declare (ignore question-type))
 191   (decode-a-or-aaaa-response msg))
 192
 193 (defmethod %decode-response ((msg dns-message) (question-type (eql :aaaa)))
 194   (declare (ignore question-type))
 195   (decode-a-or-aaaa-response msg))
 196
 197 (defmethod %decode-response ((msg dns-message) (question-type (eql :ptr)))
 198   (declare (ignore question-type))
 199   (decode-rr (aref (dns-message-answer msg) 0)))
 200
 201 ;; TODO: got a lot to do here
 202 (defmethod %decode-response ((msg dns-message) (question-type (eql :mx)))
 203   (declare (ignore question-type))
 204   (let ((rr (aref (dns-message-answer msg) 0)))
 205     (decode-rr rr)))
 206
 207 (defmethod %decode-response ((msg dns-message) (question-type (eql :txt)))
 208   (declare (ignore question-type))
 209   (decode-rr (aref (dns-message-answer msg) 0)))
 210
 211 (defmethod %decode-response ((msg dns-message) question-type)
 212   (declare (ignore question-type))
 213   (values msg))
 214
 215 (defun decode-response (message)
 216   (%decode-response message
 217                     (dns-record-type
 218                      (aref (dns-message-question message) 0))))
 219 \f
 220 ;;;; DNS-QUERY
 221
 222 (defconstant +dns-port+ 53)
 223
 224 (defun do-udp-dns-query (buffer length nameserver timeout)
 225   (with-open-stream
 226       (socket (make-socket :connect :active :type :datagram
 227                            :remote-host nameserver :remote-port +dns-port+
 228                            :ipv6 (ipv6-address-p nameserver)))
 229     (send-to socket buffer :end length)
 230     (iomux:wait-until-fd-ready (fd-of socket) :read timeout t)
 231     (multiple-value-bind (buf len)
 232         (receive-from socket :size +dns-max-datagram-size+)
 233       (values buf len))))
 234
 235 (defun wait-until-socket-connected (socket timeout)
 236   (if (nth-value 1 (iomux:wait-until-fd-ready (fd-of socket) :write timeout))
 237       (let ((errcode (socket-option socket :error)))
 238         (when (minusp errcode) (signal-socket-error)))
 239       (error 'socket-connection-timeout-error)))
 240
 241 (defun send-tcp-dns-query (socket buffer length)
 242   (let ((minibuf (make-array (+ length 2) :element-type 'ub8)))
 243     ;; two-octet length prefix
 244     (replace minibuf (ub16-to-vector length))
 245     (replace minibuf buffer :start1 2 :end2 length)
 246     (send-to socket minibuf :end (+ length 2))))
 247
 248 (defun get-tcp-query-length (socket timeout)
 249   (iomux:wait-until-fd-ready (fd-of socket) :read timeout t)
 250   (multiple-value-bind (minibuf)
 251       (receive-from socket :size 2)
 252     (+ (ash (aref minibuf 0) 8)
 253        (aref minibuf 1))))
 254
 255 (defun receive-tcp-dns-message (socket time-fn)
 256   (with-accessors ((fd fd-of)) socket
 257     (let* ((message-length (get-tcp-query-length socket (funcall time-fn)))
 258            (input-buffer (make-array message-length :element-type 'ub8)))
 259       (loop :with off := 0 :do
 260          (iomux:wait-until-fd-ready fd :read (funcall time-fn) t)
 261          (let ((inbytes (nth-value 1 (receive-from socket :buffer input-buffer :start off))))
 262            (incf off inbytes)
 263            (when (= off message-length)
 264              (return (values input-buffer off))))))))
 265
 266 (defun do-tcp-dns-query (buffer length nameserver timeout)
 267   (let* ((t0 (osicat-sys:get-monotonic-time))
 268          (tend (+ t0 timeout)))
 269     (flet ((remtime ()
 270              (let ((rem (- tend (osicat-sys:get-monotonic-time))))
 271                (if (not (minusp rem)) rem
 272                    (error 'socket-connection-timeout-error)))))
 273       (with-open-stream
 274           (socket (make-socket :connect :active :type :stream
 275                                :ipv6 (ipv6-address-p nameserver)))
 276         (setf (fd-non-blocking socket) t)
 277         (handler-case
 278             (connect socket nameserver :port +dns-port+)
 279           (socket-connection-in-progress-error ()
 280             (wait-until-socket-connected socket (remtime))))
 281         (send-tcp-dns-query socket buffer length)
 282         (receive-tcp-dns-message socket #'remtime)))))
 283
 284 (defun do-one-dns-query (name type search ns repeat timeout)
 285   (declare (optimize (debug 3)))
 286   ;; TODO: implement search
 287   (declare (ignore search))
 288   (let* ((query (prepare-query name type))
 289          (buffer (sequence-of query))
 290          (bufflen (write-cursor-of query))
 291          (tries-left repeat))
 292     (labels
 293         ((start (protocol)
 294            ;; if the query size fits into a datagram(512 bytes max) do a
 295            ;; UDP query, otherwise use TCP
 296            (if (eq :udp protocol)
 297                (do-udp-query)
 298                (do-tcp-query)))
 299          (do-udp-query ()
 300            ;; do a UDP query; in case of a socket error, try again
 301            (handler-case
 302                (do-udp-dns-query buffer bufflen ns timeout)
 303              (socket-error () (%error "UDP socket error"))
 304              (iomux:poll-timeout () (try-again :udp))
 305              (:no-error (buf bytes) (parse-response buf bytes))))
 306          (do-tcp-query ()
 307            ;; do a TCP query; in case of a socket error, try again
 308            (handler-case
 309                (do-tcp-dns-query buffer bufflen ns timeout)
 310              (socket-connection-timeout-error () (try-again :tcp))
 311              (socket-error () (%error "TCP socket error"))
 312              (iomux:poll-timeout () (try-again :tcp))
 313              (:no-error (buf bytes) (parse-response buf bytes t))))
 314          (parse-response (buf bytes &optional on-tcp)
 315            ;; try to parse the response; in case of a parse error, try again
 316            (handler-case
 317                (read-dns-message (make-instance 'dynamic-buffer :sequence buf :size bytes))
 318              (dynamic-buffer-input-error () (try-again :tcp))
 319              (dns-message-error () (try-again :tcp))
 320              (:no-error (response)
 321                ;; if a truncated response was received by UDP, try TCP
 322                ;; if it was received by TCP, err
 323                (if (truncated-field response)
 324                    (if on-tcp (%error "TCP truncated messae") (try-again :tcp))
 325                    (return-response response)))))
 326          (try-again (protocol)
 327            ;; if no response received and there are tries left, try again
 328            (if (plusp (decf tries-left)) (start protocol) (%error "No more retries left")))
 329          (return-response (response) response)
 330          (%error (&optional cause) (declare (ignore cause))))
 331       (start :udp))))
 332
 333 (defun preprocess-dns-name (name type)
 334   (if (eq :ptr type)
 335       (dns-ptr-name name)
 336       name))
 337
 338 (defun dns-query (name &key (type :a) (search *dns-search-domain*)
 339                   (nameservers *dns-nameservers*) decode
 340                   (repeat *dns-repeat*) (timeout *dns-timeout*))
 341   (setf nameservers (ensure-list nameservers))
 342   (assert nameservers (nameservers) "Must supply a nameserver")
 343   (let ((pname (preprocess-dns-name name type)))
 344     (dolist (ns (mapcar #'ensure-address nameservers))
 345       (when-let ((response (do-one-dns-query pname type search
 346                                              ns repeat timeout)))
 347         (return-from dns-query
 348           (if decode (decode-response response) response))))))