net.sockets/dns/query.lisp

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