1 ;;; dns.el --- Domain Name Service lookups
3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
4 ;; Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 3, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
31 "How many seconds to wait when doing DNS queries.")
33 (defvar dns-servers nil
34 "Which DNS servers to query.
35 If nil, /etc/resolv.conf will be consulted.")
39 (defvar dns-query-types
62 "Names of query types and their values.")
69 "Classes of queries.")
71 (defun dns-write-bytes (value &optional length
)
73 (dotimes (i (or length
1))
74 (push (% value
256) bytes
)
75 (setq value
(/ value
256)))
79 (defun dns-read-bytes (length)
82 (setq value
(logior (* value
256) (following-char)))
86 (defun dns-get (type spec
)
87 (cadr (assq type spec
)))
89 (defun dns-inverse-get (value spec
)
91 (while (and (not found
)
93 (if (eq value
(cadr (car spec
)))
94 (setq found
(caar spec
))
98 (defun dns-write-name (name)
99 (dolist (part (split-string name
"\\."))
100 (dns-write-bytes (length part
))
104 (defun dns-read-string-name (string buffer
)
105 (let (default-enable-multibyte-characters)
108 (goto-char (point-min))
109 (dns-read-name buffer
))))
111 (defun dns-read-name (&optional buffer
)
116 (setq length
(dns-read-bytes 1))
117 (if (= 192 (logand length
(lsh 3 6)))
118 (let ((offset (+ (* (logand 63 length
) 256)
119 (dns-read-bytes 1))))
123 (goto-char (1+ offset
))
124 (setq ended
(dns-read-name buffer
))))
127 (push (buffer-substring (point)
128 (progn (forward-char length
) (point)))
133 (concat (mapconcat 'identity
(nreverse name
) ".") "." ended
))
134 (mapconcat 'identity
(nreverse name
) "."))))
136 (defun dns-write (spec &optional tcp-p
)
137 "Write a DNS packet according to SPEC.
138 If TCP-P, the first two bytes of the package with be the length field."
140 (dns-write-bytes (dns-get 'id spec
) 2)
143 (lsh (if (dns-get 'response-p spec
) 1 0) -
7)
146 ((eq (dns-get 'opcode spec
) 'query
) 0)
147 ((eq (dns-get 'opcode spec
) 'inverse-query
) 1)
148 ((eq (dns-get 'opcode spec
) 'status
) 2)
149 (t (error "No such opcode: %s" (dns-get 'opcode spec
))))
151 (lsh (if (dns-get 'authoritative-p spec
) 1 0) -
2)
152 (lsh (if (dns-get 'truncated-p spec
) 1 0) -
1)
153 (lsh (if (dns-get 'recursion-desired-p spec
) 1 0) 0)))
156 ((eq (dns-get 'response-code spec
) 'no-error
) 0)
157 ((eq (dns-get 'response-code spec
) 'format-error
) 1)
158 ((eq (dns-get 'response-code spec
) 'server-failure
) 2)
159 ((eq (dns-get 'response-code spec
) 'name-error
) 3)
160 ((eq (dns-get 'response-code spec
) 'not-implemented
) 4)
161 ((eq (dns-get 'response-code spec
) 'refused
) 5)
163 (dns-write-bytes (length (dns-get 'queries spec
)) 2)
164 (dns-write-bytes (length (dns-get 'answers spec
)) 2)
165 (dns-write-bytes (length (dns-get 'authorities spec
)) 2)
166 (dns-write-bytes (length (dns-get 'additionals spec
)) 2)
167 (dolist (query (dns-get 'queries spec
))
168 (dns-write-name (car query
))
169 (dns-write-bytes (cadr (assq (or (dns-get 'type query
) 'A
)
171 (dns-write-bytes (cadr (assq (or (dns-get 'class query
) 'IN
)
173 (dolist (slot '(answers authorities additionals
))
174 (dolist (resource (dns-get slot spec
))
175 (dns-write-name (car resource
))
176 (dns-write-bytes (cadr (assq (dns-get 'type resource
) dns-query-types
))
178 (dns-write-bytes (cadr (assq (dns-get 'class resource
) dns-classes
))
180 (dns-write-bytes (dns-get 'ttl resource
) 4)
181 (dns-write-bytes (length (dns-get 'data resource
)) 2)
182 (insert (dns-get 'data resource
))))
184 (goto-char (point-min))
185 (dns-write-bytes (buffer-size) 2))
188 (defun dns-read (packet)
189 (let (default-enable-multibyte-characters)
192 queries answers authorities additionals
)
194 (goto-char (point-min))
195 (push (list 'id
(dns-read-bytes 2)) spec
)
196 (let ((byte (dns-read-bytes 1)))
197 (push (list 'response-p
(if (zerop (logand byte
(lsh 1 7))) nil t
))
199 (let ((opcode (logand byte
(lsh 7 3))))
201 (cond ((eq opcode
0) 'query
)
202 ((eq opcode
1) 'inverse-query
)
203 ((eq opcode
2) 'status
)))
205 (push (list 'authoritative-p
(if (zerop (logand byte
(lsh 1 2)))
207 (push (list 'truncated-p
(if (zerop (logand byte
(lsh 1 2))) nil t
))
209 (push (list 'recursion-desired-p
210 (if (zerop (logand byte
(lsh 1 0))) nil t
)) spec
))
211 (let ((rc (logand (dns-read-bytes 1) 15)))
212 (push (list 'response-code
214 ((eq rc
0) 'no-error
)
215 ((eq rc
1) 'format-error
)
216 ((eq rc
2) 'server-failure
)
217 ((eq rc
3) 'name-error
)
218 ((eq rc
4) 'not-implemented
)
219 ((eq rc
5) 'refused
)))
221 (setq queries
(dns-read-bytes 2))
222 (setq answers
(dns-read-bytes 2))
223 (setq authorities
(dns-read-bytes 2))
224 (setq additionals
(dns-read-bytes 2))
227 (push (list (dns-read-name)
228 (list 'type
(dns-inverse-get (dns-read-bytes 2)
230 (list 'class
(dns-inverse-get (dns-read-bytes 2)
233 (push (list 'queries qs
) spec
))
234 (dolist (slot '(answers authorities additionals
))
237 (dotimes (i (symbol-value slot
))
238 (push (list (dns-read-name)
240 (setq type
(dns-inverse-get (dns-read-bytes 2)
242 (list 'class
(dns-inverse-get (dns-read-bytes 2)
244 (list 'ttl
(dns-read-bytes 4))
245 (let ((length (dns-read-bytes 2)))
250 (progn (forward-char length
) (point)))
253 (push (list slot qs
) spec
)))
256 (defun dns-read-int32 ()
257 ;; Full 32 bit Integers can't be handled by Emacs. If we use
259 (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
260 (dns-read-bytes 3))))
262 (defun dns-read-type (string type
)
263 (let ((buffer (current-buffer))
266 (let (default-enable-multibyte-characters)
269 (goto-char (point-min))
274 (push (dns-read-bytes 1) bytes
))
275 (mapconcat 'number-to-string
(nreverse bytes
) ".")))
279 (push (dns-read-bytes 2) hextets
))
280 (mapconcat (lambda (n) (format "%x" n
))
281 (nreverse hextets
) ":")))
283 (list (list 'mname
(dns-read-name buffer
))
284 (list 'rname
(dns-read-name buffer
))
285 (list 'serial
(dns-read-int32))
286 (list 'refresh
(dns-read-int32))
287 (list 'retry
(dns-read-int32))
288 (list 'expire
(dns-read-int32))
289 (list 'minimum
(dns-read-int32))))
291 (list (list 'priority
(dns-read-bytes 2))
292 (list 'weight
(dns-read-bytes 2))
293 (list 'port
(dns-read-bytes 2))
294 (list 'target
(dns-read-name buffer
))))
296 (cons (dns-read-bytes 2) (dns-read-name buffer
)))
297 ((or (eq type
'CNAME
) (eq type
'NS
) (eq type
'PTR
))
298 (dns-read-string-name string buffer
))
302 (defun dns-parse-resolv-conf ()
303 (when (file-exists-p "/etc/resolv.conf")
305 (insert-file-contents "/etc/resolv.conf")
306 (goto-char (point-min))
307 (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t
)
308 (push (match-string 1) dns-servers
))
309 (setq dns-servers
(nreverse dns-servers
)))))
311 (defun dns-read-txt (string)
312 (if (> (length string
) 1)
316 (defun dns-get-txt-answer (answers)
319 (dolist (answer answers
)
320 (dolist (elem answer
)
323 ((eq (car elem
) 'type
)
324 (setq do-next
(eq (cadr elem
) 'TXT
)))
325 ((eq (car elem
) 'data
)
327 (setq result
(concat result
(dns-read-txt (cadr elem
))))))))))
330 ;;; Interface functions.
331 (defmacro dns-make-network-process
(server)
332 (if (featurep 'xemacs
)
333 `(let ((coding-system-for-read 'binary
)
334 (coding-system-for-write 'binary
))
335 (open-network-stream "dns" (current-buffer)
336 ,server
"domain" 'udp
))
337 `(let ((server ,server
)
338 (coding-system-for-read 'binary
)
339 (coding-system-for-write 'binary
))
340 (if (fboundp 'make-network-process
)
341 (make-network-process
344 :buffer
(current-buffer)
348 ;; Older versions of Emacs doesn't have
349 ;; `make-network-process', so we fall back on opening a TCP
350 ;; connection to the DNS server.
351 (open-network-stream "dns" (current-buffer) server
"domain")))))
353 (defvar dns-cache
(make-vector 4096 0))
355 (defun query-dns-cached (name &optional type fullp reversep
)
356 (let* ((key (format "%s:%s:%s:%s" name type fullp reversep
))
357 (sym (intern-soft key dns-cache
)))
361 (let ((result (query-dns name type fullp reversep
)))
362 (set (intern key dns-cache
) result
)
365 (defun query-dns (name &optional type fullp reversep
)
366 "Query a DNS server for NAME of TYPE.
367 If FULLP, return the entire record returned.
368 If REVERSEP, look up an IP address."
369 (setq type
(or type
'A
))
371 (dns-parse-resolv-conf))
375 (mapconcat 'identity
(nreverse (split-string name
"\\.")) ".")
379 (if (not dns-servers
)
380 (message "No DNS server configuration found")
381 (let (default-enable-multibyte-characters)
383 (let ((process (condition-case ()
384 (dns-make-network-process (car dns-servers
))
387 "dns: Got an error while trying to talk to %s"
390 (tcp-p (and (not (fboundp 'make-network-process
))
391 (not (featurep 'xemacs
))))
393 (times (* dns-timeout
1000))
398 (dns-write `((id ,id
)
400 (queries ((,name
(type ,type
))))
401 (recursion-desired-p t
))
403 (while (and (zerop (buffer-size))
405 (sit-for (/ step
1000.0))
406 (accept-process-output process
0 step
)
407 (setq times
(- times step
)))
409 (delete-process process
)
412 (>= (buffer-size) 2))
413 (goto-char (point-min))
414 (delete-region (point) (+ (point) 2)))
415 (when (and (>= (buffer-size) 2)
416 ;; We had a time-out.
418 (let ((result (dns-read (buffer-string))))
421 (let ((answer (car (dns-get 'answers result
))))
422 (when (eq type
(dns-get 'type answer
))
424 (dns-get-txt-answer (dns-get 'answers result
))
425 (dns-get 'data answer
)))))))))))))
429 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a