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 (eq :no-error return-code
) ; no error
139 (values return-code
))))
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
))))
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))
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
)
159 :finally
(setf consumed i
))
160 (do ((cname (dns-record-name (aref (dns-message-question msg
) 0)))
162 (exit (values (remove-trailing-dot cname
) consumed
))
163 (let ((name (gethash cname cnames
)))
165 (remhash cname cnames
)
167 (t (setf exit t
)))))))
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
))
174 (first-address-place 0)
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
)))
189 (defmethod %decode-response
((msg dns-message
) (question-type (eql :a
)))
190 (declare (ignore question-type
))
191 (decode-a-or-aaaa-response msg
))
193 (defmethod %decode-response
((msg dns-message
) (question-type (eql :aaaa
)))
194 (declare (ignore question-type
))
195 (decode-a-or-aaaa-response msg
))
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)))
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)))
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)))
211 (defmethod %decode-response
((msg dns-message
) question-type
)
212 (declare (ignore question-type
))
215 (defun decode-response (message)
216 (%decode-response message
218 (aref (dns-message-question message
) 0))))
222 (defconstant +dns-port
+ 53)
224 (defun do-udp-dns-query (buffer length nameserver timeout
)
226 (socket (make-socket :connect
:active
:type
:datagram
227 :remote-host nameserver
:remote-port
+dns-port
+
228 :ipv6
(ipv6-address-p nameserver
)))
229 (send-to socket buffer
:end length
)
230 (iomux:wait-until-fd-ready
(fd-of socket
) :read timeout t
)
231 (multiple-value-bind (buf len
)
232 (receive-from socket
:size
+dns-max-datagram-size
+)
235 (defun wait-until-socket-connected (socket timeout
)
236 (if (nth-value 1 (iomux:wait-until-fd-ready
(fd-of socket
) :write timeout
))
237 (let ((errcode (socket-option socket
:error
)))
238 (when (minusp errcode
) (signal-socket-error)))
239 (error 'socket-connection-timeout-error
)))
241 (defun send-tcp-dns-query (socket buffer length
)
242 (let ((minibuf (make-array (+ length
2) :element-type
'ub8
)))
243 ;; two-octet length prefix
244 (replace minibuf
(ub16-to-vector length
))
245 (replace minibuf buffer
:start1
2 :end2 length
)
246 (send-to socket minibuf
:end
(+ length
2))))
248 (defun get-tcp-query-length (socket timeout
)
249 (iomux:wait-until-fd-ready
(fd-of socket
) :read timeout t
)
250 (multiple-value-bind (minibuf)
251 (receive-from socket
:size
2)
252 (+ (ash (aref minibuf
0) 8)
255 (defun receive-tcp-dns-message (socket time-fn
)
256 (with-accessors ((fd fd-of
)) socket
257 (let* ((message-length (get-tcp-query-length socket
(funcall time-fn
)))
258 (input-buffer (make-array message-length
:element-type
'ub8
)))
259 (loop :with off
:= 0 :do
260 (iomux:wait-until-fd-ready fd
:read
(funcall time-fn
) t
)
261 (let ((inbytes (nth-value 1 (receive-from socket
:buffer input-buffer
:start off
))))
263 (when (= off message-length
)
264 (return (values input-buffer off
))))))))
266 (defun do-tcp-dns-query (buffer length nameserver timeout
)
267 (let* ((t0 (osicat-sys:get-monotonic-time
))
268 (tend (+ t0 timeout
)))
270 (let ((rem (- tend
(osicat-sys:get-monotonic-time
))))
271 (if (not (minusp rem
)) rem
272 (error 'socket-connection-timeout-error
)))))
274 (socket (make-socket :connect
:active
:type
:stream
275 :ipv6
(ipv6-address-p nameserver
)))
276 (setf (fd-non-blocking socket
) t
)
278 (connect socket nameserver
:port
+dns-port
+)
279 (socket-connection-in-progress-error ()
280 (wait-until-socket-connected socket
(remtime))))
281 (send-tcp-dns-query socket buffer length
)
282 (receive-tcp-dns-message socket
#'remtime
)))))
284 (defun do-one-dns-query (name type search ns repeat timeout
)
285 (declare (optimize (debug 3)))
286 ;; TODO: implement search
287 (declare (ignore search
))
288 (let* ((query (prepare-query name type
))
289 (buffer (sequence-of query
))
290 (bufflen (write-cursor-of query
))
294 ;; if the query size fits into a datagram(512 bytes max) do a
295 ;; UDP query, otherwise use TCP
296 (if (eq :udp protocol
)
300 ;; do a UDP query; in case of a socket error, try again
302 (do-udp-dns-query buffer bufflen ns timeout
)
303 (socket-error () (%error
"UDP socket error"))
304 (iomux:poll-timeout
() (try-again :udp
))
305 (:no-error
(buf bytes
) (parse-response buf bytes
))))
307 ;; do a TCP query; in case of a socket error, try again
309 (do-tcp-dns-query buffer bufflen ns timeout
)
310 (socket-connection-timeout-error () (try-again :tcp
))
311 (socket-error () (%error
"TCP socket error"))
312 (iomux:poll-timeout
() (try-again :tcp
))
313 (:no-error
(buf bytes
) (parse-response buf bytes t
))))
314 (parse-response (buf bytes
&optional on-tcp
)
315 ;; try to parse the response; in case of a parse error, try again
317 (read-dns-message (make-instance 'dynamic-buffer
:sequence buf
:size bytes
))
318 (dynamic-buffer-input-error () (try-again :tcp
))
319 (dns-message-error () (try-again :tcp
))
320 (:no-error
(response)
321 ;; if a truncated response was received by UDP, try TCP
322 ;; if it was received by TCP, err
323 (if (truncated-field response
)
324 (if on-tcp
(%error
"TCP truncated messae") (try-again :tcp
))
325 (return-response response
)))))
326 (try-again (protocol)
327 ;; if no response received and there are tries left, try again
328 (if (plusp (decf tries-left
)) (start protocol
) (%error
"No more retries left")))
329 (return-response (response) response
)
330 (%error
(&optional cause
) (declare (ignore cause
))))
333 (defun preprocess-dns-name (name type
)
338 (defun dns-query (name &key
(type :a
) (search *dns-search-domain
*)
339 (nameservers *dns-nameservers
*) decode
340 (repeat *dns-repeat
*) (timeout *dns-timeout
*))
341 (setf nameservers
(ensure-list nameservers
))
342 (assert nameservers
(nameservers) "Must supply a nameserver")
343 (let ((pname (preprocess-dns-name name type
)))
344 (dolist (ns (mapcar #'ensure-address nameservers
))
345 (when-let ((response (do-one-dns-query pname type search
347 (return-from dns-query
348 (if decode
(decode-response response
) response
))))))