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 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   (let ((input-buffer (make-array +dns-max-datagram-size+ :element-type 'ub8)))
 226     (with-open-stream
 227         (socket (make-socket :connect :active :type :datagram
 228                              :remote-host nameserver :remote-port +dns-port+
 229                              :ipv6 (ipv6-address-p nameserver)))
 230       (socket-send buffer socket :end length)
 231       (iomux:wait-until-fd-ready (fd-of socket) :read timeout t)
 232       (multiple-value-bind (buf len)
 233           (socket-receive input-buffer socket)
 234         (values buf len)))))
 235
 236 (defun wait-until-socket-connected (socket timeout)
 237   (if (nth-value 1 (iomux:wait-until-fd-ready (fd-of socket) :write timeout))
 238       (let ((errcode (get-socket-option socket :error)))
 239         (when (minusp errcode) (signal-socket-error)))
 240       (error 'socket-connection-timeout-error)))
 241
 242 (defun send-tcp-dns-query (socket buffer length)
 243   (let ((minibuf (make-array (+ length 2) :element-type 'ub8)))
 244     ;; two-octet length prefix
 245     (replace minibuf (ub16-to-vector length))
 246     (replace minibuf buffer :start1 2 :end2 length)
 247     (socket-send minibuf socket :end (+ length 2))))
 248
 249 (defun get-tcp-query-length (socket timeout)
 250   (let ((minibuf (make-array 2 :element-type 'ub8)))
 251     (iomux:wait-until-fd-ready (fd-of socket) :read timeout t)
 252     (socket-receive minibuf socket)
 253     (+ (ash (aref minibuf 0) 8)
 254        (aref minibuf 1))))
 255
 256 (defun receive-tcp-dns-message (socket time-fn)
 257   (with-accessors ((fd fd-of)) socket
 258     (let* ((message-length (get-tcp-query-length socket (funcall time-fn)))
 259            (input-buffer (make-array message-length :element-type 'ub8)))
 260       (loop :with off := 0 :do
 261          (iomux:wait-until-fd-ready fd :read (funcall time-fn) t)
 262          (let ((inbytes (nth-value 1 (socket-receive input-buffer socket :start off))))
 263            (incf off inbytes)
 264            (when (= off message-length)
 265              (return (values input-buffer off))))))))
 266
 267 (defun do-tcp-dns-query (buffer length nameserver timeout)
 268   (let* ((t0 (osicat-sys:get-monotonic-time))
 269          (tend (+ t0 timeout)))
 270     (flet ((remtime ()
 271              (let ((rem (- tend (osicat-sys:get-monotonic-time))))
 272                (if (not (minusp rem)) rem
 273                    (error 'socket-connection-timeout-error)))))
 274       (with-open-stream
 275           (socket (make-socket :connect :active :type :stream
 276                                :ipv6 (ipv6-address-p nameserver)))
 277         (setf (fd-non-blocking socket) t)
 278         (handler-case
 279             (connect socket nameserver :port +dns-port+)
 280           (socket-connection-in-progress-error ()
 281             (wait-until-socket-connected socket (remtime))))
 282         (send-tcp-dns-query socket buffer length)
 283         (receive-tcp-dns-message socket #'remtime)))))
 284
 285 (defun do-one-dns-query (name type search ns repeat timeout)
 286   (declare (optimize (debug 3)))
 287   ;; TODO: implement search
 288   (declare (ignore search))
 289   (let* ((query (prepare-query name type))
 290          (buffer (sequence-of query))
 291          (bufflen (write-cursor-of query))
 292          (tries-left repeat))
 293     (labels
 294         ((start (protocol)
 295            ;; if the query size fits into a datagram(512 bytes max) do a
 296            ;; UDP query, otherwise use TCP
 297            (if (eq protocol :udp)
 298                (do-udp-query)
 299                (do-tcp-query)))
 300          (do-udp-query ()
 301            ;; do a UDP query; in case of a socket error, try again
 302            (handler-case
 303                (do-udp-dns-query buffer bufflen ns timeout)
 304              (socket-error () (%error "UDP socket error"))
 305              (iomux:poll-timeout () (try-again :udp))
 306              (:no-error (buf bytes) (parse-response buf bytes))))
 307          (do-tcp-query ()
 308            ;; do a TCP query; in case of a socket error, try again
 309            (handler-case
 310                (do-tcp-dns-query buffer bufflen ns timeout)
 311              (socket-connection-timeout-error () (try-again :tcp))
 312              (socket-error () (%error "TCP socket error"))
 313              (iomux:poll-timeout () (try-again :tcp))
 314              (:no-error (buf bytes) (parse-response buf bytes t))))
 315          (parse-response (buf bytes &optional on-tcp)
 316            ;; try to parse the response; in case of a parse error, try again
 317            (handler-case
 318                (read-dns-message (make-instance 'dynamic-buffer :sequence buf :size bytes))
 319              (dynamic-buffer-input-error () (try-again :tcp))
 320              (dns-message-error () (try-again :tcp))
 321              (:no-error (response)
 322                ;; if a truncated response was received by UDP, try TCP
 323                ;; if it was received by TCP, err
 324                (if (truncated-field response)
 325                    (if on-tcp (%error "TCP truncated messae") (try-again :tcp))
 326                    (return-response response)))))
 327          (try-again (protocol)
 328            ;; if no response received and there are tries left, try again
 329            (if (plusp (decf tries-left)) (start protocol) (%error "No more retries left")))
 330          (return-response (response) response)
 331          (%error (&optional cause) (declare (ignore cause))))
 332       (start :udp))))
 333
 334 (defun preprocess-dns-name (name type)
 335   (if (eq type :ptr)
 336       (dns-ptr-name name)
 337       name))
 338
 339 (defun dns-query (name &key (type :a) (search *dns-search-domain*)
 340                   (nameservers *dns-nameservers*) decode
 341                   (repeat *dns-repeat*) (timeout *dns-timeout*))
 342   (setf nameservers (ensure-list nameservers))
 343   (assert nameservers (nameservers) "Must supply a nameserver")
 344   (let ((pname (preprocess-dns-name name type)))
 345     (dolist (ns (mapcar #'ensure-address nameservers))
 346       (when-let ((response (do-one-dns-query pname type search
 347                                              ns repeat timeout)))
 348         (return-from dns-query
 349           (if decode (decode-response response) response))))))