1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
3 ;;; query.lisp --- Make DNS queries.
5 ;;; Copyright (C) 2006-2008, Stelian Ionescu <sionescu@common-lisp.net>
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
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.
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
24 (in-package :net.sockets
)
26 (defvar *dns-recursion-desired
* t
27 "Whether the \"RECURSION-DESIRED\" field should be set ot not.")
29 (defvar *dns-repeat
* 3
30 "The number of times a failed query will be retried.")
32 (defvar *dns-timeout
* 10
33 "Timeout for DNS queries in seconds.")
35 (define-constant +max-16-bits
+ (1- (expt 2 16)))
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
)))
43 (defun reverse-vector (vector)
44 (let* ((vector-length (length 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
)))
54 (defun ipv4-dns-ptr-name (address)
55 (declare (type ipv4-array address
))
56 (concatenate 'string
(vector-to-dotted (reverse-vector address
))
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
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
))))))
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
))
81 (defun dns-ptr-name (address)
82 (multiple-value-bind (vector address-type
)
83 (address-to-vector address
)
85 (error "The argument is not a valid IP address"))
87 (:ipv4
(ipv4-dns-ptr-name vector
))
88 (:ipv6
(ipv6-dns-ptr-name vector
)))))
90 ;;;; Resource Record Decoding
92 (defgeneric %decode-rr
(rr type class
))
94 (defmethod %decode-rr
((rr dns-rr
) type class
)
95 (declare (ignore type class
))
96 (cons (dns-rr-ttl rr
) (dns-rr-data rr
)))
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
))))))
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
))))
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
))))
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
))))))
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
)
125 (subseq name
0 (1- (length name
)))))))
127 (defun decode-rr (rr)
128 (%decode-rr rr
(dns-record-type rr
) (dns-record-class rr
)))
130 ;;;; Response Decoding
132 (defgeneric %decode-response
(dns-message question-type
))
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
139 (values return-code
))))
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
))
146 (first-address-place 0)
148 (other-addresses nil
))
149 ;; when the address is valid(we have at least one answer)
150 (when (plusp answer-count
)
152 (when (eql (dns-record-type (aref answer
0))
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
)))
165 (defmethod %decode-response
((msg dns-message
) (question-type (eql :a
)))
166 (declare (ignore question-type
))
167 (decode-a-or-aaaa-response msg
))
169 (defmethod %decode-response
((msg dns-message
) (question-type (eql :aaaa
)))
170 (declare (ignore question-type
))
171 (decode-a-or-aaaa-response msg
))
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)))
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)))
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)))
187 (defmethod %decode-response
((msg dns-message
) question-type
)
188 (declare (ignore question-type
))
191 (defun decode-response (message)
192 (%decode-response message
194 (aref (dns-message-question message
) 0))))
198 (defconstant +dns-port
+ 53)
200 (defun do-udp-dns-query (buffer length nameserver timeout
)
201 (let ((input-buffer (make-array +dns-datagram-size
+
202 :element-type
'ub8
)))
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
))))
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
)))
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))))
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)
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
))))
239 (when (= off message-length
)
240 (return (values input-buffer off
))))))))
242 (defun do-tcp-dns-query (buffer length nameserver timeout
)
243 (let* ((t0 (osicat-sys:get-monotonic-time
))
244 (tend (+ t0 timeout
)))
246 (let ((rem (- tend
(osicat-sys:get-monotonic-time
))))
247 (if (not (minusp rem
)) rem
248 (error 'socket-connection-timeout-error
)))))
250 (socket (make-socket :connect
:active
:type
:stream
251 :ipv6
(ipv6-address-p nameserver
)))
252 (setf (fd-non-blocking socket
) t
)
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
)))))
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
))
267 in-buff bytes-received response tcp-done
)
270 (setf tcp-done nil response nil
)
271 ;; if the query size fits into a datagram(512 bytes max) do a
272 ;; UDP query, otherwise use TCP
273 (when (> bufflen
+dns-datagram-size
+)
276 ;; do a UDP query; in case of a socket error, try again
278 (setf (values in-buff bytes-received
)
279 (do-udp-dns-query buffer bufflen ns timeout
))
280 (socket-error () (go :error
))
281 (iomux:poll-timeout
() (go :try-again-if-possible
)))
282 ;; no socket error, go parse the response
285 ;; do a TCP query; in case of a socket error, try again
287 (setf (values in-buff bytes-received
)
288 (do-tcp-dns-query buffer bufflen ns timeout
))
289 (socket-connection-timeout-error () (go :try-again-if-possible
))
290 (socket-error () (go :error
))
291 (iomux:poll-timeout
() (go :try-again-if-possible
)))
294 ;; try to parse the response; in case of a parse error, try again
298 (make-instance 'dynamic-buffer
300 :size bytes-received
)))
301 (dynamic-buffer-input-error () (go :error
))
302 (dns-message-error () (go :error
)))
303 ;; if a truncated response was received by UDP, try TCP
304 (when (and (not tcp-done
)
305 (truncated-field response
))
307 :try-again-if-possible
309 ;; if no response received and there are tries left, try again
310 (when (and (not response
)
315 (return-from do-one-dns-query
317 (decode-response response
)
320 (return-from do-one-dns-query
))))
322 (defun preprocess-dns-name (name type
)
327 (defun dns-query (name &key
(type :a
) decode search
328 (nameservers *dns-nameservers
*)
329 (repeat *dns-repeat
*) (timeout *dns-timeout
*))
330 (setf nameservers
(ensure-list nameservers
))
331 (assert nameservers
(nameservers) "Must supply a nameserver")
332 (let ((pname (preprocess-dns-name name type
)))
333 (dolist (ns (mapcar #'ensure-address nameservers
))
334 (when-let ((response (do-one-dns-query pname type search decode
336 (return-from dns-query response
)))))