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 (eql return-code :no-error) ; no error
 138         (call-next-method)
 139         (values return-code))))
 140
 141 (defun decode-a-or-aaaa-response (msg)
 142   (declare (type dns-message msg))
 143   (let ((answer (dns-message-answer msg))
 144         (answer-count (dns-message-answer-count msg))
 145         (cname nil)
 146         (first-address-place 0)
 147         (first-address nil)
 148         (other-addresses nil))
 149     ;; when the address is valid(we have at least one answer)
 150     (when (plusp answer-count)
 151       ;; we have a CNAME
 152       (when (eql (dns-record-type (aref answer 0))
 153                  :cname)
 154         (setf cname (decode-rr (aref answer 0)))
 155         (incf first-address-place))
 156       ;; this means the message actually contains addresses
 157       (when (> (dns-message-answer-count msg) first-address-place)
 158         (setf first-address (decode-rr (aref answer first-address-place))))
 159       (setf other-addresses
 160             (loop :for i :from (1+ first-address-place)
 161                   :below (dns-message-answer-count msg)
 162                   :collect (decode-rr (aref answer i)))))
 163     (values cname first-address other-addresses)))
 164
 165 (defmethod %decode-response ((msg dns-message) (question-type (eql :a)))
 166   (declare (ignore question-type))
 167   (decode-a-or-aaaa-response msg))
 168
 169 (defmethod %decode-response ((msg dns-message) (question-type (eql :aaaa)))
 170   (declare (ignore question-type))
 171   (decode-a-or-aaaa-response msg))
 172
 173 (defmethod %decode-response ((msg dns-message) (question-type (eql :ptr)))
 174   (declare (ignore question-type))
 175   (decode-rr (aref (dns-message-answer msg) 0)))
 176
 177 ;; TODO: got a lot to do here
 178 (defmethod %decode-response ((msg dns-message) (question-type (eql :mx)))
 179   (declare (ignore question-type))
 180   (let ((rr (aref (dns-message-answer msg) 0)))
 181     (decode-rr rr)))
 182
 183 (defmethod %decode-response ((msg dns-message) (question-type (eql :txt)))
 184   (declare (ignore question-type))
 185   (decode-rr (aref (dns-message-answer msg) 0)))
 186
 187 (defmethod %decode-response ((msg dns-message) question-type)
 188   (declare (ignore question-type))
 189   (values msg))
 190
 191 (defun decode-response (message)
 192   (%decode-response message
 193                     (dns-record-type
 194                      (aref (dns-message-question message) 0))))
 195 \f
 196 ;;;; DNS-QUERY
 197
 198 (defconstant +dns-port+ 53)
 199
 200 (defun do-udp-dns-query (buffer length nameserver timeout)
 201   (let ((input-buffer (make-array +dns-datagram-size+
 202                                   :element-type 'ub8)))
 203     (with-open-stream
 204         (socket (make-socket :connect :active :type :datagram
 205                              :remote-host nameserver :remote-port +dns-port+
 206                              :ipv6 (ipv6-address-p nameserver)))
 207       (socket-send buffer socket :end length)
 208       (iomux:wait-until-fd-ready (fd-of socket) :read timeout t)
 209       (socket-receive input-buffer socket))))
 210
 211 (defun wait-until-socket-connected (socket timeout)
 212   (if (nth-value 1 (iomux:wait-until-fd-ready (fd-of socket) :write timeout))
 213       (let ((errcode (get-socket-option socket :error)))
 214         (when (minusp errcode) (signal-socket-error)))
 215       (error 'socket-connection-timeout-error)))
 216
 217 (defun send-tcp-dns-query (socket buffer length)
 218   (let ((minibuf (make-array (+ length 2) :element-type 'ub8)))
 219     ;; two-octet length prefix
 220     (replace minibuf (ub16-to-vector length))
 221     (replace minibuf buffer :start1 2 :end2 length)
 222     (socket-send minibuf socket :end (+ length 2))))
 223
 224 (defun get-tcp-query-length (socket timeout)
 225   (let ((minibuf (make-array 2 :element-type 'ub8)))
 226     (iomux:wait-until-fd-ready (fd-of socket) :read timeout t)
 227     (socket-receive minibuf socket)
 228     (+ (ash (aref minibuf 0) 8)
 229        (aref minibuf 1))))
 230
 231 (defun receive-tcp-dns-message (socket time-fn)
 232   (with-accessors ((fd fd-of)) socket
 233     (let* ((message-length (get-tcp-query-length socket (funcall time-fn)))
 234            (input-buffer (make-array message-length :element-type 'ub8)))
 235       (loop :with off := 0 :do
 236          (iomux:wait-until-fd-ready fd :read (funcall time-fn) t)
 237          (let ((inbytes (nth-value 1 (socket-receive input-buffer socket :start off))))
 238            (incf off inbytes)
 239            (when (= off message-length)
 240              (return (values input-buffer off))))))))
 241
 242 (defun do-tcp-dns-query (buffer length nameserver timeout)
 243   (let* ((t0 (osicat-sys:get-monotonic-time))
 244          (tend (+ t0 timeout)))
 245     (flet ((remtime ()
 246              (let ((rem (- tend (osicat-sys:get-monotonic-time))))
 247                (if (not (minusp rem)) rem
 248                    (error 'socket-connection-timeout-error)))))
 249       (with-open-stream
 250           (socket (make-socket :connect :active :type :stream
 251                                :ipv6 (ipv6-address-p nameserver)))
 252         (setf (fd-non-blocking socket) t)
 253         (handler-case
 254             (connect socket nameserver :port +dns-port+)
 255           (socket-connection-in-progress-error ()
 256             (wait-until-socket-connected socket (remtime))))
 257         (send-tcp-dns-query socket buffer length)
 258         (receive-tcp-dns-message socket #'remtime)))))
 259
 260 (defun do-one-dns-query (name type search decode ns repeat timeout)
 261   ;; TODO: implement search
 262   (declare (ignore search))
 263   (let* ((query (prepare-query name type))
 264          (buffer (sequence-of query))
 265          (bufflen (write-cursor-of query))
 266          (tries-left repeat))
 267     (labels
 268         ((start ()
 269            ;; if the query size fits into a datagram(512 bytes max) do a
 270            ;; UDP query, otherwise use TCP
 271            (if (<= +dns-datagram-size+ bufflen)
 272                (do-udp-query)
 273                (do-tcp-query)))
 274          (do-udp-query ()
 275            ;; do a UDP query; in case of a socket error, try again
 276            (handler-case
 277                (do-udp-dns-query buffer bufflen ns timeout)
 278              (socket-error () (%error))
 279              (iomux:poll-timeout () (try-again))
 280              (:no-error (buf bytes) (parse-response buf bytes))))
 281          (do-tcp-query ()
 282            ;; do a TCP query; in case of a socket error, try again
 283            (handler-case
 284                (do-tcp-dns-query buffer bufflen ns timeout)
 285              (socket-connection-timeout-error () (try-again))
 286              (socket-error () (%error))
 287              (iomux:poll-timeout () (try-again))
 288              (:no-error (buf bytes) (parse-response buf bytes t))))
 289          (parse-response (buf bytes &optional on-tcp)
 290            ;; try to parse the response; in case of a parse error, try again
 291            (handler-case
 292                (read-dns-message (make-instance 'dynamic-buffer :sequence buf :size bytes))
 293              (dynamic-buffer-input-error () (try-again))
 294              (dns-message-error () (try-again))
 295              (:no-error (response)
 296                ;; if a truncated response was received by UDP, try TCP
 297                ;; if it was received by TCP, err
 298                (if (truncated-field response)
 299                    (if on-tcp (%error) (do-tcp-query))
 300                    (return-response response)))))
 301          (try-again ()
 302            ;; if no response received and there are tries left, try again
 303            (if (plusp (decf tries-left)) (start) (%error)))
 304          (return-response (response)
 305            (if decode (decode-response response) response))
 306          (%error () nil))
 307       (start))))
 308
 309 (defun preprocess-dns-name (name type)
 310   (if (eq type :ptr)
 311       (dns-ptr-name name)
 312       name))
 313
 314 (defun dns-query (name &key (type :a) (search *dns-search-domain*)
 315                   (nameservers *dns-nameservers*) decode
 316                   (repeat *dns-repeat*) (timeout *dns-timeout*))
 317   (setf nameservers (ensure-list nameservers))
 318   (assert nameservers (nameservers) "Must supply a nameserver")
 319   (let ((pname (preprocess-dns-name name type)))
 320     (dolist (ns (mapcar #'ensure-address nameservers))
 321       (when-let ((response (do-one-dns-query pname type search decode
 322                                              ns repeat timeout)))
 323         (return-from dns-query response)))))