src/sockets/dns/query.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Make DNS queries.
   4 ;;;
   5
   6 (in-package :iolib/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 (defconstant +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 (defmethod %decode-rr ((rr dns-rr) (type (eql :srv)) class)
 110   (declare (ignore class))
 111   (destructuring-bind (priority weight port target) (dns-rr-data rr)
 112     (list* (dns-rr-ttl rr)
 113            priority
 114            weight
 115            port
 116            (subseq target 0 (1- (length target))))))
 117
 118 (defun decode-rr (rr)
 119   (%decode-rr rr (dns-record-type rr) (dns-record-class rr)))
 120
 121 ;;;; Response Decoding
 122
 123 (defgeneric %decode-response (dns-message question-type))
 124
 125 (defmethod %decode-response :around ((msg dns-message) question-type)
 126   (declare (ignore question-type))
 127   (let ((return-code (rcode-field msg)))
 128     (if (eql :no-error return-code) ; no error
 129         (call-next-method)
 130         (values return-code))))
 131
 132 (defun remove-trailing-dot (string)
 133   (assert (>= (length string) 2) (string)
 134           "String length must be at least 2: ~S" string)
 135   (assert (char= #\. (char string (1- (length string)))) (string)
 136           "Must end with a dot: ~S" string)
 137   (subseq string 0 (1- (length string))))
 138
 139 (defun find-cname (msg)
 140   (let ((answer (dns-message-answer msg))
 141         (answer-count (dns-message-answer-count msg))
 142         (cnames (make-hash-table :test 'equal :size 3))
 143         (consumed 0))
 144     (loop :for i :below answer-count
 145           :for ans := (aref answer i) :do
 146           (if (eql :cname (dns-record-type ans))
 147               (setf (gethash (dns-record-name ans) cnames)
 148                     (dns-rr-data ans))
 149               (loop-finish))
 150           :finally (setf consumed i))
 151     (do ((cname (dns-record-name (aref (dns-message-question msg) 0)))
 152          (exit nil))
 153         (exit (values (remove-trailing-dot cname) consumed))
 154       (let ((name (gethash cname cnames)))
 155         (cond (name
 156                (remhash cname cnames)
 157                (setf cname name))
 158               (t (setf exit t)))))))
 159
 160 (defun decode-a-or-aaaa-response (msg)
 161   (declare (type dns-message msg))
 162   (let ((answer (dns-message-answer msg))
 163         (answer-count (dns-message-answer-count msg))
 164         (cname nil)
 165         (first-address-place 0)
 166         (first-address nil)
 167         (other-addresses nil))
 168     ;; when the address is valid(we have at least one answer)
 169     (when (plusp answer-count)
 170       (setf (values cname first-address-place) (find-cname msg))
 171       ;; this means the message actually contains addresses
 172       (when (> (dns-message-answer-count msg) first-address-place)
 173         (setf first-address (decode-rr (aref answer first-address-place))))
 174       (setf other-addresses
 175             (loop :for i :from (1+ first-address-place)
 176                   :below (dns-message-answer-count msg)
 177                   :collect (decode-rr (aref answer i)))))
 178     (values cname first-address other-addresses)))
 179
 180 (defmethod %decode-response ((msg dns-message) (question-type (eql :a)))
 181   (declare (ignore question-type))
 182   (decode-a-or-aaaa-response msg))
 183
 184 (defmethod %decode-response ((msg dns-message) (question-type (eql :aaaa)))
 185   (declare (ignore question-type))
 186   (decode-a-or-aaaa-response msg))
 187
 188 (defmethod %decode-response ((msg dns-message) (question-type (eql :ptr)))
 189   (declare (ignore question-type))
 190   (decode-rr (aref (dns-message-answer msg) 0)))
 191
 192 ;; TODO: got a lot to do here
 193 (defmethod %decode-response ((msg dns-message) (question-type (eql :mx)))
 194   (declare (ignore question-type))
 195   (let ((rr (aref (dns-message-answer msg) 0)))
 196     (decode-rr rr)))
 197
 198 ;; TODO: randomly choose between same priority by weight
 199 (defmethod %decode-response ((msg dns-message) (question-type (eql :srv)))
 200   (declare (ignore question-type))
 201   (let* ((decoded-rrs (map 'vector #'decode-rr (dns-message-answer msg))))
 202     (aref (sort decoded-rrs #'< :key #'second) 0)))
 203
 204 (defmethod %decode-response ((msg dns-message) (question-type (eql :txt)))
 205   (declare (ignore question-type))
 206   (decode-rr (aref (dns-message-answer msg) 0)))
 207
 208 (defmethod %decode-response ((msg dns-message) question-type)
 209   (declare (ignore question-type))
 210   (values msg))
 211
 212 (defun decode-response (message)
 213   (%decode-response message
 214                     (dns-record-type
 215                      (aref (dns-message-question message) 0))))
 216 \f
 217 ;;;; DNS-QUERY
 218
 219 (defconstant +dns-port+ 53)
 220
 221 (defun dns-query/udp (buffer length nameserver timeout)
 222   (with-open-socket
 223       (socket :type :datagram :ipv6 (ipv6-address-p nameserver)
 224               :remote-host nameserver :remote-port +dns-port+)
 225     (send-to socket buffer :end length)
 226     (iomux:wait-until-fd-ready (fd-of socket) :input timeout t)
 227     (multiple-value-bind (buf len)
 228         (receive-from socket :size +dns-max-datagram-size+)
 229       (values buf len))))
 230
 231 (defun wait-until-socket-connected (socket timeout)
 232   (if (nth-value 1 (iomux:wait-until-fd-ready (fd-of socket) :output timeout))
 233       (let ((errcode (socket-option socket :error)))
 234         (when (minusp errcode) (signal-socket-error errcode (fd-of socket))))
 235       (error 'socket-connection-timeout-error)))
 236
 237 (defun send-tcp-dns-query (socket buffer length)
 238   (let ((minibuf (make-array (+ length 2) :element-type 'ub8)))
 239     ;; two-octet length prefix
 240     (replace minibuf (ub16-to-vector length))
 241     (replace minibuf buffer :start1 2 :end2 length)
 242     (send-to socket minibuf :end (+ length 2))))
 243
 244 (defun get-tcp-query-length (socket timeout)
 245   (iomux:wait-until-fd-ready (fd-of socket) :input timeout t)
 246   (multiple-value-bind (minibuf)
 247       (receive-from socket :size 2)
 248     (+ (ash (aref minibuf 0) 8)
 249        (aref minibuf 1))))
 250
 251 (defun receive-tcp-dns-message (socket time-fn)
 252   (with-accessors ((fd fd-of)) socket
 253     (let* ((message-length (get-tcp-query-length socket (funcall time-fn)))
 254            (input-buffer (make-array message-length :element-type 'ub8)))
 255       (loop :with off := 0 :do
 256          (iomux:wait-until-fd-ready fd :input (funcall time-fn) t)
 257          (let ((inbytes (nth-value 1 (receive-from socket :buffer input-buffer :start off))))
 258            (incf off inbytes)
 259            (when (= off message-length)
 260              (return (values input-buffer off))))))))
 261
 262 (defun dns-query/tcp (buffer length nameserver timeout)
 263   (let* ((t0 (isys:get-monotonic-time))
 264          (tend (+ t0 timeout)))
 265     (flet ((remtime ()
 266              (let ((rem (- tend (isys:get-monotonic-time))))
 267                (if (not (minusp rem))
 268                    rem
 269                    (error 'socket-connection-timeout-error)))))
 270       (with-open-socket
 271           (socket :connect :active :type :stream
 272                   :ipv6 (ipv6-address-p nameserver))
 273         (handler-case
 274             (connect socket nameserver :port +dns-port+)
 275           (socket-connection-in-progress-error ()
 276             (wait-until-socket-connected socket (remtime))))
 277         (send-tcp-dns-query socket buffer length)
 278         (receive-tcp-dns-message socket #'remtime)))))
 279
 280 (defun do-one-dns-query (name type search ns repeat timeout)
 281   ;; TODO: implement search
 282   (declare (ignore search))
 283   (let* ((query (prepare-query name type))
 284          (buffer (sequence-of query))
 285          (bufflen (write-cursor-of query))
 286          (tries-left repeat))
 287     (labels
 288         ((start (protocol)
 289            ;; if the query size fits into a datagram(512 bytes max) do a
 290            ;; UDP query, otherwise use TCP
 291            (ecase protocol
 292              (:udp (query/udp))
 293              (:tcp (query/tcp))))
 294          (query/udp ()
 295            ;; do a UDP query; in case of a socket error, try again
 296            (handler-case
 297                (dns-query/udp buffer bufflen ns timeout)
 298              (socket-error () (%error "UDP socket error"))
 299              (iomux:poll-timeout () (try-again :udp))
 300              (:no-error (buf bytes) (parse-response buf bytes))))
 301          (query/tcp ()
 302            ;; do a TCP query; in case of a socket error, try again
 303            (handler-case
 304                (dns-query/tcp buffer bufflen ns timeout)
 305              (socket-connection-timeout-error () (try-again :tcp))
 306              (socket-error () (%error "TCP socket error"))
 307              (iomux:poll-timeout () (try-again :tcp))
 308              (:no-error (buf bytes) (parse-response buf bytes t))))
 309          (parse-response (buf bytes &optional on-tcp)
 310            ;; try to parse the response; in case of a parse error, try again
 311            (handler-case
 312                (read-dns-message (make-instance 'dynamic-buffer :sequence buf :size bytes))
 313              (dynamic-buffer-input-error () (try-again :tcp))
 314              (dns-message-error () (try-again :tcp))
 315              (:no-error (response)
 316                ;; if a truncated response was received by UDP, try TCP
 317                ;; if it was received by TCP, err
 318                (if (truncated-field response)
 319                    (if on-tcp (%error "TCP truncated messae") (try-again :tcp))
 320                    (return-response response)))))
 321          (try-again (protocol)
 322            ;; if no response received and there are tries left, try again
 323            (if (plusp (decf tries-left)) (start protocol) (%error "No more retries left")))
 324          (return-response (response) response)
 325          (%error (&optional cause) (declare (ignore cause))))
 326       (start :udp))))
 327
 328 (defun preprocess-dns-name (name type)
 329   (if (eql :ptr type)
 330       (dns-ptr-name name)
 331       name))
 332
 333 (defun dns-query (name &key (type :a) (search *dns-search-domain*)
 334                   (nameservers *dns-nameservers*) decode
 335                   (repeat *dns-repeat*) (timeout *dns-timeout*))
 336   (setf nameservers (ensure-list nameservers))
 337   (assert nameservers (nameservers) "Must supply a nameserver")
 338   (let ((pname (preprocess-dns-name name type)))
 339     (dolist (ns (mapcar #'ensure-address nameservers))
 340       (when-let (response (do-one-dns-query pname type search
 341                                             ns repeat timeout))
 342         (return* (if decode (decode-response response) response))))))