protocols/dns-client/dns-do-query.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006 by Stelian Ionescu                                 ;
   5 ;                                                                         ;
   6 ;   This program is free software; you can redistribute it and/or modify  ;
   7 ;   it under the terms of the GNU General Public License as published by  ;
   8 ;   the Free Software Foundation; either version 2 of the License, or     ;
   9 ;   (at your option) any later version.                                   ;
  10 ;                                                                         ;
  11 ;   This program is distributed in the hope that it will be useful,       ;
  12 ;   but WITHOUT ANY WARRANTY; without even the implied warranty of        ;
  13 ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         ;
  14 ;   GNU General Public License for more details.                          ;
  15 ;                                                                         ;
  16 ;   You should have received a copy of the GNU General Public License     ;
  17 ;   along with this program; if not, write to the                         ;
  18 ;   Free Software Foundation, Inc.,                                       ;
  19 ;   51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA              ;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21
  22 ;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2)))
  23 (declaim (optimize (speed 0) (safety 2) (space 0) (debug 2)))
  24
  25 (in-package :net.sockets)
  26
  27 (defvar *dns-nameservers* nil
  28   "List of the DNS nameservers to use.")
  29 (defvar *dns-recursion-desired* t
  30   "Whether the \"RECURSION-DESIRED\" field should be set ot not.")
  31 (defvar *dns-repeat* 5
  32   "The number of times a failed query will be retried.")
  33 (defvar *dns-timeout* 5
  34   "Timeout for DNS queries in seconds.")
  35 (defvar *dns-domain* nil
  36   "The current machine's domain.")
  37 (defvar *dns-search-domain* nil
  38   "A domain name to be appended to the name to be searched when the latter does not contain dots.")
  39
  40 (defun send-query (socket-type buffer nameserver timeout)
  41   (let ((socket (make-socket :type socket-type
  42                              :ipv6 (ipv6-address-p nameserver)))
  43         (input-buffer (make-array +dns-datagram-size+
  44                                   :element-type 'octet)))
  45     (unwind-protect
  46          (progn
  47            (connect socket nameserver :port 53)
  48            (socket-send buffer socket)
  49            (set-socket-option socket :receive-timeout :sec timeout :usec 0)
  50            (socket-receive input-buffer socket))
  51       (socket-close socket))))
  52
  53 (define-constant +max-16-bits+ (1- (expt 2 16)))
  54
  55 (defun prepare-query (name type)
  56   (let* ((question (make-question name type :in))
  57          (query (make-query (random +max-16-bits+)
  58                             question *dns-recursion-desired*)))
  59     (write-dns-message query)))
  60
  61 (defun reverse-vector (vector)
  62   (let* ((vector-length (length vector))
  63          (reverse-vector
  64           (make-array vector-length
  65                       :element-type (array-element-type vector))))
  66     (loop
  67        :for target-index :below vector-length
  68        :for source-index := (1- vector-length) :then (1- source-index)
  69        :do (setf (aref reverse-vector target-index) (aref vector source-index)))
  70     reverse-vector))
  71
  72 (defun ipv4-dns-ptr-name (address)
  73   (declare (type (simple-array octet (4)) address))
  74   (concatenate 'string (vector-to-dotted (reverse-vector address))
  75                ".in-addr.arpa."))
  76
  77 (defun ipv6-vector-to-dotted (vector)
  78   (declare (type (simple-array ub16 (8)) vector))
  79   (with-standard-io-syntax
  80     (let ((*print-base* 16))
  81       (with-output-to-string (dotted-address)
  82         (loop
  83            :for index :below (length vector)
  84            :for element := (aref vector index)
  85            :do
  86            (when (plusp index)
  87              (princ #\. dotted-address))
  88            (princ (ldb (byte 4  0) element) dotted-address)
  89            (princ #\. dotted-address)
  90            (princ (ldb (byte 4  4) element) dotted-address)
  91            (princ #\. dotted-address)
  92            (princ (ldb (byte 4  8) element) dotted-address)
  93            (princ #\. dotted-address)
  94            (princ (ldb (byte 4 12) element) dotted-address))))))
  95
  96 (defun ipv6-dns-ptr-name (address)
  97   (declare (type (simple-array ub16 (8)) address))
  98   (concatenate 'string (ipv6-vector-to-dotted (reverse-vector address))
  99                ".ip6.arpa."))
 100
 101 (defun dns-ptr-name (address)
 102   (multiple-value-bind (vector address-type)
 103       (vector-address-or-nil address)
 104     (when (null address)
 105       (error "The argument is not a valid IP address"))
 106     (ecase address-type
 107       (:ipv4 (ipv4-dns-ptr-name vector))
 108       (:ipv6 (ipv6-dns-ptr-name vector)))))
 109
 110
 111 ;;
 112 ;; RESOURCE RECORD decoding
 113 ;;
 114 (defgeneric do-decode-rr (rr type class))
 115
 116 (defmethod do-decode-rr ((rr dns-rr) (type (eql :cname)) class)
 117   (declare (ignore class))
 118   (let ((cname (dns-rr-data rr)))
 119     (cons (dns-rr-ttl rr)
 120           (subseq cname 0 (1- (length cname))))))
 121
 122 (defmethod do-decode-rr ((rr dns-rr) (type (eql :a)) (class (eql :in)))
 123   (let ((address (dns-rr-data rr)))
 124     (cons (dns-rr-ttl rr)
 125           (make-address address))))
 126
 127 (defmethod do-decode-rr ((rr dns-rr) (type (eql :aaaa)) (class (eql :in)))
 128   (let ((address (dns-rr-data rr)))
 129     (cons (dns-rr-ttl rr)
 130           (make-address address))))
 131
 132 (defmethod do-decode-rr ((rr dns-rr) (type (eql :ptr)) class)
 133   (declare (ignore class))
 134   (let ((name (dns-rr-data rr)))
 135     (cons (dns-rr-ttl rr)
 136           (subseq name 0 (1- (length name))))))
 137
 138 (defmethod do-decode-rr ((rr dns-rr) (type (eql :mx)) class)
 139   (declare (ignore class))
 140   (destructuring-bind (preference name) (dns-rr-data rr)
 141     (cons (dns-rr-ttl rr)
 142           (cons preference
 143                 (subseq name 0 (1- (length name)))))))
 144
 145 (defmethod do-decode-rr ((rr dns-rr) (type (eql :txt)) class)
 146   (declare (ignore class))
 147   (cons (dns-rr-ttl rr) (dns-rr-data rr)))
 148
 149 (defun decode-rr (rr)
 150   (do-decode-rr rr (dns-record-type rr) (dns-record-class rr)))
 151
 152 ;;
 153 ;; RESPONSE decoding
 154 ;;
 155 (defgeneric do-decode-response (dns-message question-type))
 156
 157 (defmethod do-decode-response :around ((msg dns-message) question-type)
 158   (let ((return-code (rcode-field msg)))
 159     (if (eql return-code :no-error) ; no error
 160         (call-next-method)
 161         (values return-code))))
 162
 163 (defun decode-a-or-aaaa-response (msg)
 164   (declare (type dns-message msg))
 165   (let ((answer (dns-message-answer msg))
 166         (answer-count (dns-message-answer-count msg))
 167         (cname nil)
 168         (first-address-place 0)
 169         (first-address nil)
 170         (other-addresses nil))
 171     ;; when the address is valid(we have at least one answer)
 172     (when (plusp answer-count)
 173       ;; we have a CNAME
 174       (when (eql (dns-record-type (aref answer 0))
 175                  :cname)
 176         (setf cname (decode-rr (aref answer 0)))
 177         (incf first-address-place))
 178       ;; this means the message actually contains addresses
 179       (when (> (dns-message-answer-count msg) first-address-place)
 180         (setf first-address (decode-rr (aref answer first-address-place))))
 181       (setf other-addresses
 182             (loop
 183                :for i :from (1+ first-address-place) :below (dns-message-answer-count msg)
 184                :collect (decode-rr (aref answer i)))))
 185     (values cname first-address other-addresses)))
 186
 187 (defmethod do-decode-response ((msg dns-message) (question-type (eql :a)))
 188   (decode-a-or-aaaa-response msg))
 189
 190 (defmethod do-decode-response ((msg dns-message) (question-type (eql :aaaa)))
 191   (decode-a-or-aaaa-response msg))
 192
 193 (defmethod do-decode-response ((msg dns-message) (question-type (eql :ptr)))
 194   (decode-rr (aref (dns-message-answer msg) 0)))
 195
 196 ;; TODO: got a lot to do here
 197 (defmethod do-decode-response ((msg dns-message) (question-type (eql :mx)))
 198   (let ((rr (aref (dns-message-answer msg) 0)))
 199     (decode-rr rr)))
 200
 201 (defmethod do-decode-response ((msg dns-message) (question-type (eql :txt)))
 202   (decode-rr (aref (dns-message-answer msg) 0)))
 203
 204 (defmethod do-decode-response ((msg dns-message) question-type)
 205   msg)
 206
 207 (defun decode-response (message)
 208   (do-decode-response message (dns-record-type (aref (dns-message-question message) 0))))
 209
 210 ;;
 211 ;; DNS-QUERY
 212 ;;
 213 (defun dns-query (name &key (type :a) (nameserver *dns-nameservers*)
 214                   (repeat *dns-repeat*) (timeout *dns-timeout*)
 215                   (decode nil) (search nil))
 216   ;; TODO: implement search
 217   (declare (ignore search))
 218
 219   (when (eq type :ptr)
 220     (setf name (dns-ptr-name name)))
 221   (let* ((query (prepare-query name type))
 222          (buffer (buffer-sequence query))
 223          (bufflen (length buffer))
 224          (tries-left repeat)
 225          in-buff bytes-received response tcp-done)
 226
 227     ;; at the moment only one nameserver is used
 228     (when (listp nameserver)
 229       (setf nameserver (car nameserver)))
 230     (assert nameserver)
 231
 232     (tagbody
 233      :start
 234        (setf tcp-done nil
 235              response nil)
 236
 237      :do-any-query
 238        ;; if the query size fits into a datagram(512 bytes max) do a
 239        ;; UDP query, otherwise use TCP
 240        ;; in case of a socket error, try again
 241        (multiple-value-setq (in-buff bytes-received)
 242          (if (> bufflen +dns-datagram-size+)
 243              (go :do-tcp-query)
 244              (handler-case
 245                  (send-query :datagram buffer nameserver timeout)
 246                (socket-error (err)
 247                  (declare (ignore err))
 248                  (go :try-again-if-possible)))))
 249        ;; if no socket error, go parse the response
 250        (go :parse-response)
 251
 252      :do-tcp-query
 253        ;; do a TCP query; in case of a socket error, try again
 254        (multiple-value-setq (in-buff bytes-received)
 255          (handler-case
 256              (send-query :stream buffer nameserver timeout)
 257            (socket-error (err)
 258              (declare (ignore err))
 259              (go :try-again-if-possible))))
 260        (setf tcp-done t)
 261
 262      :parse-response
 263        ;; try to parse the response; in case of a parse error, try again
 264        (setf response
 265              (handler-case
 266                  (read-dns-message
 267                   (make-instance 'dynamic-input-buffer
 268                                  :sequence in-buff
 269                                  :size bytes-received))
 270                (input-buffer-error (err)
 271                  (declare (ignore err))
 272                  (go :try-again-if-possible))
 273                (dns-message-error (err)
 274                  (declare (ignore err))
 275                  (go :try-again-if-possible))))
 276        ;; if a truncated response was received by UDP, try TCP
 277        (when (and (not tcp-done)
 278                   (truncated-field response))
 279          (go :do-tcp-query))
 280
 281      :try-again-if-possible
 282        (decf tries-left)
 283        ;; if no response received and there are tries left, try again
 284        (when (and (not response)
 285                   (plusp tries-left))
 286          (go :start))
 287
 288      :return-response
 289        (when response
 290          (return-from dns-query (if decode
 291                                     (decode-response response)
 292                                     response)))
 293
 294      :raise-error
 295        (error "Could not query nameserver !!"))))