1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-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 (defun decode-rr (rr)
110 (%decode-rr rr
(dns-record-type rr
) (dns-record-class rr
)))
112 ;;;; Response Decoding
114 (defgeneric %decode-response
(dns-message question-type
))
116 (defmethod %decode-response
:around
((msg dns-message
) question-type
)
117 (declare (ignore question-type
))
118 (let ((return-code (rcode-field msg
)))
119 (if (eql :no-error return-code
) ; no error
121 (values return-code
))))
123 (defun remove-trailing-dot (string)
124 (assert (>= (length string
) 2) (string)
125 "String length must be at least 2: ~S" string
)
126 (assert (char= #\.
(char string
(1- (length string
)))) (string)
127 "Must end with a dot: ~S" string
)
128 (subseq string
0 (1- (length string
))))
130 (defun find-cname (msg)
131 (let ((answer (dns-message-answer msg
))
132 (answer-count (dns-message-answer-count msg
))
133 (cnames (make-hash-table :test
'equal
:size
3))
135 (loop :for i
:below answer-count
136 :for ans
:= (aref answer i
) :do
137 (if (eql :cname
(dns-record-type ans
))
138 (setf (gethash (dns-record-name ans
) cnames
)
141 :finally
(setf consumed i
))
142 (do ((cname (dns-record-name (aref (dns-message-question msg
) 0)))
144 (exit (values (remove-trailing-dot cname
) consumed
))
145 (let ((name (gethash cname cnames
)))
147 (remhash cname cnames
)
149 (t (setf exit t
)))))))
151 (defun decode-a-or-aaaa-response (msg)
152 (declare (type dns-message msg
))
153 (let ((answer (dns-message-answer msg
))
154 (answer-count (dns-message-answer-count msg
))
156 (first-address-place 0)
158 (other-addresses nil
))
159 ;; when the address is valid(we have at least one answer)
160 (when (plusp answer-count
)
161 (setf (values cname first-address-place
) (find-cname msg
))
162 ;; this means the message actually contains addresses
163 (when (> (dns-message-answer-count msg
) first-address-place
)
164 (setf first-address
(decode-rr (aref answer first-address-place
))))
165 (setf other-addresses
166 (loop :for i
:from
(1+ first-address-place
)
167 :below
(dns-message-answer-count msg
)
168 :collect
(decode-rr (aref answer i
)))))
169 (values cname first-address other-addresses
)))
171 (defmethod %decode-response
((msg dns-message
) (question-type (eql :a
)))
172 (declare (ignore question-type
))
173 (decode-a-or-aaaa-response msg
))
175 (defmethod %decode-response
((msg dns-message
) (question-type (eql :aaaa
)))
176 (declare (ignore question-type
))
177 (decode-a-or-aaaa-response msg
))
179 (defmethod %decode-response
((msg dns-message
) (question-type (eql :ptr
)))
180 (declare (ignore question-type
))
181 (decode-rr (aref (dns-message-answer msg
) 0)))
183 ;; TODO: got a lot to do here
184 (defmethod %decode-response
((msg dns-message
) (question-type (eql :mx
)))
185 (declare (ignore question-type
))
186 (let ((rr (aref (dns-message-answer msg
) 0)))
189 (defmethod %decode-response
((msg dns-message
) (question-type (eql :txt
)))
190 (declare (ignore question-type
))
191 (decode-rr (aref (dns-message-answer msg
) 0)))
193 (defmethod %decode-response
((msg dns-message
) question-type
)
194 (declare (ignore question-type
))
197 (defun decode-response (message)
198 (%decode-response message
200 (aref (dns-message-question message
) 0))))
204 (defconstant +dns-port
+ 53)
206 (defun dns-query/udp
(buffer length nameserver timeout
)
208 (socket :type
:datagram
:ipv6
(ipv6-address-p nameserver
)
209 :remote-host nameserver
:remote-port
+dns-port
+)
210 (send-to socket buffer
:end length
)
211 (iomux:wait-until-fd-ready
(fd-of socket
) :input timeout t
)
212 (multiple-value-bind (buf len
)
213 (receive-from socket
:size
+dns-max-datagram-size
+)
216 (defun wait-until-socket-connected (socket timeout
)
217 (if (nth-value 1 (iomux:wait-until-fd-ready
(fd-of socket
) :output timeout
))
218 (let ((errcode (socket-option socket
:error
)))
219 (when (minusp errcode
) (signal-socket-error errcode
(fd-of socket
))))
220 (error 'socket-connection-timeout-error
)))
222 (defun send-tcp-dns-query (socket buffer length
)
223 (let ((minibuf (make-array (+ length
2) :element-type
'ub8
)))
224 ;; two-octet length prefix
225 (replace minibuf
(ub16-to-vector length
))
226 (replace minibuf buffer
:start1
2 :end2 length
)
227 (send-to socket minibuf
:end
(+ length
2))))
229 (defun get-tcp-query-length (socket timeout
)
230 (iomux:wait-until-fd-ready
(fd-of socket
) :input timeout t
)
231 (multiple-value-bind (minibuf)
232 (receive-from socket
:size
2)
233 (+ (ash (aref minibuf
0) 8)
236 (defun receive-tcp-dns-message (socket time-fn
)
237 (with-accessors ((fd fd-of
)) socket
238 (let* ((message-length (get-tcp-query-length socket
(funcall time-fn
)))
239 (input-buffer (make-array message-length
:element-type
'ub8
)))
240 (loop :with off
:= 0 :do
241 (iomux:wait-until-fd-ready fd
:input
(funcall time-fn
) t
)
242 (let ((inbytes (nth-value 1 (receive-from socket
:buffer input-buffer
:start off
))))
244 (when (= off message-length
)
245 (return (values input-buffer off
))))))))
247 (defun dns-query/tcp
(buffer length nameserver timeout
)
248 (let* ((t0 (isys:get-monotonic-time
))
249 (tend (+ t0 timeout
)))
251 (let ((rem (- tend
(isys:get-monotonic-time
))))
252 (if (not (minusp rem
))
254 (error 'socket-connection-timeout-error
)))))
256 (socket :connect
:active
:type
:stream
257 :ipv6
(ipv6-address-p nameserver
))
259 (connect socket nameserver
:port
+dns-port
+)
260 (socket-connection-in-progress-error ()
261 (wait-until-socket-connected socket
(remtime))))
262 (send-tcp-dns-query socket buffer length
)
263 (receive-tcp-dns-message socket
#'remtime
)))))
265 (defun do-one-dns-query (name type search ns repeat timeout
)
266 ;; TODO: implement search
267 (declare (ignore search
))
268 (let* ((query (prepare-query name type
))
269 (buffer (sequence-of query
))
270 (bufflen (write-cursor-of query
))
274 ;; if the query size fits into a datagram(512 bytes max) do a
275 ;; UDP query, otherwise use TCP
280 ;; do a UDP query; in case of a socket error, try again
282 (dns-query/udp buffer bufflen ns timeout
)
283 (socket-error () (%error
"UDP socket error"))
284 (iomux:poll-timeout
() (try-again :udp
))
285 (:no-error
(buf bytes
) (parse-response buf bytes
))))
287 ;; do a TCP query; in case of a socket error, try again
289 (dns-query/tcp buffer bufflen ns timeout
)
290 (socket-connection-timeout-error () (try-again :tcp
))
291 (socket-error () (%error
"TCP socket error"))
292 (iomux:poll-timeout
() (try-again :tcp
))
293 (:no-error
(buf bytes
) (parse-response buf bytes t
))))
294 (parse-response (buf bytes
&optional on-tcp
)
295 ;; try to parse the response; in case of a parse error, try again
297 (read-dns-message (make-instance 'dynamic-buffer
:sequence buf
:size bytes
))
298 (dynamic-buffer-input-error () (try-again :tcp
))
299 (dns-message-error () (try-again :tcp
))
300 (:no-error
(response)
301 ;; if a truncated response was received by UDP, try TCP
302 ;; if it was received by TCP, err
303 (if (truncated-field response
)
304 (if on-tcp
(%error
"TCP truncated messae") (try-again :tcp
))
305 (return-response response
)))))
306 (try-again (protocol)
307 ;; if no response received and there are tries left, try again
308 (if (plusp (decf tries-left
)) (start protocol
) (%error
"No more retries left")))
309 (return-response (response) response
)
310 (%error
(&optional cause
) (declare (ignore cause
))))
313 (defun preprocess-dns-name (name type
)
318 (defun dns-query (name &key
(type :a
) (search *dns-search-domain
*)
319 (nameservers *dns-nameservers
*) decode
320 (repeat *dns-repeat
*) (timeout *dns-timeout
*))
321 (setf nameservers
(ensure-list nameservers
))
322 (assert nameservers
(nameservers) "Must supply a nameserver")
323 (let ((pname (preprocess-dns-name name type
)))
324 (dolist (ns (mapcar #'ensure-address nameservers
))
325 (when-let (response (do-one-dns-query pname type search
327 (return* (if decode
(decode-response response
) response
))))))