1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
3 ;;; --- Make DNS queries.
6 (in-package :iolib.sockets
)
8 (defvar *dns-recursion-desired
* t
9 "Whether the \"RECURSION-DESIRED\" field should be set ot not.")
11 (defvar *dns-repeat
* 3
12 "The number of times a failed query will be retried.")
14 (defvar *dns-timeout
* 10
15 "Timeout for DNS queries in seconds.")
17 (defconstant +max-16-bits
+ (1- (expt 2 16)))
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
)))
25 (defun reverse-vector (vector)
26 (let* ((vector-length (length 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
)))
36 (defun ipv4-dns-ptr-name (address)
37 (declare (type ipv4-array address
))
38 (concatenate 'string
(vector-to-dotted (reverse-vector address
))
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
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
))))))
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
))
63 (defun dns-ptr-name (address)
64 (multiple-value-bind (vector address-type
)
65 (address-to-vector address
)
67 (error "The argument is not a valid IP address"))
69 (:ipv4
(ipv4-dns-ptr-name vector
))
70 (:ipv6
(ipv6-dns-ptr-name vector
)))))
72 ;;;; Resource Record Decoding
74 (defgeneric %decode-rr
(rr type class
))
76 (defmethod %decode-rr
((rr dns-rr
) type class
)
77 (declare (ignore type class
))
78 (cons (dns-rr-ttl rr
) (dns-rr-data rr
)))
80 (defmethod %decode-rr
((rr dns-rr
) (type (eql :cname
)) class
)
81 (declare (ignore class
))
82 (let ((cname (dns-rr-data rr
)))
84 (subseq cname
0 (1- (length cname
))))))
86 (defmethod %decode-rr
((rr dns-rr
) (type (eql :a
)) (class (eql :in
)))
87 (let ((address (dns-rr-data rr
)))
89 (make-address address
))))
91 (defmethod %decode-rr
((rr dns-rr
) (type (eql :aaaa
)) (class (eql :in
)))
92 (let ((address (dns-rr-data rr
)))
94 (make-address address
))))
96 (defmethod %decode-rr
((rr dns-rr
) (type (eql :ptr
)) class
)
97 (declare (ignore class
))
98 (let ((name (dns-rr-data rr
)))
100 (subseq name
0 (1- (length name
))))))
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
)
107 (subseq name
0 (1- (length name
)))))))
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
)
116 (subseq target
0 (1- (length target
))))))
118 (defun decode-rr (rr)
119 (%decode-rr rr
(dns-record-type rr
) (dns-record-class rr
)))
121 ;;;; Response Decoding
123 (defgeneric %decode-response
(dns-message question-type
))
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
130 (values return-code
))))
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
))))
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))
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
)
150 :finally
(setf consumed i
))
151 (do ((cname (dns-record-name (aref (dns-message-question msg
) 0)))
153 (exit (values (remove-trailing-dot cname
) consumed
))
154 (let ((name (gethash cname cnames
)))
156 (remhash cname cnames
)
158 (t (setf exit t
)))))))
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
))
165 (first-address-place 0)
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
)))
180 (defmethod %decode-response
((msg dns-message
) (question-type (eql :a
)))
181 (declare (ignore question-type
))
182 (decode-a-or-aaaa-response msg
))
184 (defmethod %decode-response
((msg dns-message
) (question-type (eql :aaaa
)))
185 (declare (ignore question-type
))
186 (decode-a-or-aaaa-response msg
))
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)))
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)))
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)))
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)))
208 (defmethod %decode-response
((msg dns-message
) question-type
)
209 (declare (ignore question-type
))
212 (defun decode-response (message)
213 (%decode-response message
215 (aref (dns-message-question message
) 0))))
219 (defconstant +dns-port
+ 53)
221 (defun dns-query/udp
(buffer length nameserver timeout
)
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
+)
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
)))
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))))
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)
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
))))
259 (when (= off message-length
)
260 (return (values input-buffer off
))))))))
262 (defun dns-query/tcp
(buffer length nameserver timeout
)
263 (let* ((t0 (isys:get-monotonic-time
))
264 (tend (+ t0 timeout
)))
266 (let ((rem (- tend
(isys:get-monotonic-time
))))
267 (if (not (minusp rem
))
269 (error 'socket-connection-timeout-error
)))))
271 (socket :connect
:active
:type
:stream
272 :ipv6
(ipv6-address-p nameserver
))
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
)))))
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
))
289 ;; if the query size fits into a datagram(512 bytes max) do a
290 ;; UDP query, otherwise use TCP
295 ;; do a UDP query; in case of a socket error, try again
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
))))
302 ;; do a TCP query; in case of a socket error, try again
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
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
))))
328 (defun preprocess-dns-name (name type
)
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
342 (return* (if decode
(decode-response response
) response
))))))