1 ;;; dns.el --- Domain Name Service lookups
3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
29 (eval-when-compile (require 'cl))
32 (defvar default-enable-multibyte-characters))
37 "How many seconds to wait when doing DNS queries.")
39 (defvar dns-servers nil
40 "Which DNS servers to query.
41 If nil, /etc/resolv.conf will be consulted.")
45 (defvar dns-query-types
68 "Names of query types and their values.")
75 "Classes of queries.")
77 (defun dns-write-bytes (value &optional length)
79 (dotimes (i (or length 1))
80 (push (% value 256) bytes)
81 (setq value (/ value 256)))
85 (defun dns-read-bytes (length)
88 (setq value (logior (* value 256) (following-char)))
92 (defun dns-get (type spec)
93 (cadr (assq type spec)))
95 (defun dns-inverse-get (value spec)
97 (while (and (not found)
99 (if (eq value (cadr (car spec)))
100 (setq found (caar spec))
104 (defun dns-write-name (name)
105 (dolist (part (split-string name "\\."))
106 (dns-write-bytes (length part))
110 (defun dns-read-string-name (string buffer)
111 (mm-with-unibyte-buffer
113 (goto-char (point-min))
114 (dns-read-name buffer)))
116 (defun dns-read-name (&optional buffer)
121 (setq length (dns-read-bytes 1))
122 (if (= 192 (logand length (lsh 3 6)))
123 (let ((offset (+ (* (logand 63 length) 256)
124 (dns-read-bytes 1))))
128 (goto-char (1+ offset))
129 (setq ended (dns-read-name buffer))))
132 (push (buffer-substring (point)
133 (progn (forward-char length) (point)))
138 (concat (mapconcat 'identity (nreverse name) ".") "." ended))
139 (mapconcat 'identity (nreverse name) "."))))
141 (defun dns-write (spec &optional tcp-p)
142 "Write a DNS packet according to SPEC.
143 If TCP-P, the first two bytes of the package with be the length field."
145 (dns-write-bytes (dns-get 'id spec) 2)
148 (lsh (if (dns-get 'response-p spec) 1 0) -7)
151 ((eq (dns-get 'opcode spec) 'query) 0)
152 ((eq (dns-get 'opcode spec) 'inverse-query) 1)
153 ((eq (dns-get 'opcode spec) 'status) 2)
154 (t (error "No such opcode: %s" (dns-get 'opcode spec))))
156 (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
157 (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
158 (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
161 ((eq (dns-get 'response-code spec) 'no-error) 0)
162 ((eq (dns-get 'response-code spec) 'format-error) 1)
163 ((eq (dns-get 'response-code spec) 'server-failure) 2)
164 ((eq (dns-get 'response-code spec) 'name-error) 3)
165 ((eq (dns-get 'response-code spec) 'not-implemented) 4)
166 ((eq (dns-get 'response-code spec) 'refused) 5)
168 (dns-write-bytes (length (dns-get 'queries spec)) 2)
169 (dns-write-bytes (length (dns-get 'answers spec)) 2)
170 (dns-write-bytes (length (dns-get 'authorities spec)) 2)
171 (dns-write-bytes (length (dns-get 'additionals spec)) 2)
172 (dolist (query (dns-get 'queries spec))
173 (dns-write-name (car query))
174 (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
176 (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
178 (dolist (slot '(answers authorities additionals))
179 (dolist (resource (dns-get slot spec))
180 (dns-write-name (car resource))
181 (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
183 (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
185 (dns-write-bytes (dns-get 'ttl resource) 4)
186 (dns-write-bytes (length (dns-get 'data resource)) 2)
187 (insert (dns-get 'data resource))))
189 (goto-char (point-min))
190 (dns-write-bytes (buffer-size) 2))
196 (defvar additionals))
198 (defun dns-read (packet)
199 (mm-with-unibyte-buffer
201 queries answers authorities additionals)
203 (goto-char (point-min))
204 (push (list 'id (dns-read-bytes 2)) spec)
205 (let ((byte (dns-read-bytes 1)))
206 (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
208 (let ((opcode (logand byte (lsh 7 3))))
210 (cond ((eq opcode 0) 'query)
211 ((eq opcode 1) 'inverse-query)
212 ((eq opcode 2) 'status)))
214 (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
216 (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
218 (push (list 'recursion-desired-p
219 (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
220 (let ((rc (logand (dns-read-bytes 1) 15)))
221 (push (list 'response-code
223 ((eq rc 0) 'no-error)
224 ((eq rc 1) 'format-error)
225 ((eq rc 2) 'server-failure)
226 ((eq rc 3) 'name-error)
227 ((eq rc 4) 'not-implemented)
228 ((eq rc 5) 'refused)))
230 (setq queries (dns-read-bytes 2))
231 (setq answers (dns-read-bytes 2))
232 (setq authorities (dns-read-bytes 2))
233 (setq additionals (dns-read-bytes 2))
236 (push (list (dns-read-name)
237 (list 'type (dns-inverse-get (dns-read-bytes 2)
239 (list 'class (dns-inverse-get (dns-read-bytes 2)
242 (push (list 'queries qs) spec))
243 (dolist (slot '(answers authorities additionals))
246 (dotimes (i (symbol-value slot))
247 (push (list (dns-read-name)
249 (setq type (dns-inverse-get (dns-read-bytes 2)
251 (list 'class (dns-inverse-get (dns-read-bytes 2)
253 (list 'ttl (dns-read-bytes 4))
254 (let ((length (dns-read-bytes 2)))
259 (progn (forward-char length) (point)))
262 (push (list slot qs) spec)))
265 (defun dns-read-int32 ()
266 ;; Full 32 bit Integers can't be handled by Emacs. If we use
268 (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
269 (dns-read-bytes 3))))
271 (defun dns-read-type (string type)
272 (let ((buffer (current-buffer))
275 (mm-with-unibyte-buffer
277 (goto-char (point-min))
282 (push (dns-read-bytes 1) bytes))
283 (mapconcat 'number-to-string (nreverse bytes) ".")))
287 (push (dns-read-bytes 2) hextets))
288 (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":")))
290 (list (list 'mname (dns-read-name buffer))
291 (list 'rname (dns-read-name buffer))
292 (list 'serial (dns-read-int32))
293 (list 'refresh (dns-read-int32))
294 (list 'retry (dns-read-int32))
295 (list 'expire (dns-read-int32))
296 (list 'minimum (dns-read-int32))))
298 (list (list 'priority (dns-read-bytes 2))
299 (list 'weight (dns-read-bytes 2))
300 (list 'port (dns-read-bytes 2))
301 (list 'target (dns-read-name buffer))))
303 (cons (dns-read-bytes 2) (dns-read-name buffer)))
304 ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
305 (dns-read-string-name string buffer))
309 (defun dns-parse-resolv-conf ()
310 (when (file-exists-p "/etc/resolv.conf")
312 (insert-file-contents "/etc/resolv.conf")
313 (goto-char (point-min))
314 (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
315 (push (match-string 1) dns-servers))
316 (setq dns-servers (nreverse dns-servers)))))
318 (defun dns-read-txt (string)
319 (if (> (length string) 1)
323 (defun dns-get-txt-answer (answers)
326 (dolist (answer answers)
327 (dolist (elem answer)
330 ((eq (car elem) 'type)
331 (setq do-next (eq (cadr elem) 'TXT)))
332 ((eq (car elem) 'data)
334 (setq result (concat result (dns-read-txt (cadr elem))))))))))
337 ;;; Interface functions.
338 (defmacro dns-make-network-process (server)
339 (if (featurep 'xemacs)
340 `(let ((coding-system-for-read 'binary)
341 (coding-system-for-write 'binary))
342 (open-network-stream "dns" (current-buffer)
343 ,server "domain" 'udp))
344 `(let ((server ,server)
345 (coding-system-for-read 'binary)
346 (coding-system-for-write 'binary))
347 (if (fboundp 'make-network-process)
348 (make-network-process
351 :buffer (current-buffer)
355 ;; Older versions of Emacs doesn't have
356 ;; `make-network-process', so we fall back on opening a TCP
357 ;; connection to the DNS server.
358 (open-network-stream "dns" (current-buffer) server "domain")))))
360 (defvar dns-cache (make-vector 4096 0))
362 (defun query-dns-cached (name &optional type fullp reversep)
363 (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
364 (sym (intern-soft key dns-cache)))
368 (let ((result (query-dns name type fullp reversep)))
369 (set (intern key dns-cache) result)
372 (defun query-dns (name &optional type fullp reversep)
373 "Query a DNS server for NAME of TYPE.
374 If FULLP, return the entire record returned.
375 If REVERSEP, look up an IP address."
376 (setq type (or type 'A))
378 (dns-parse-resolv-conf))
382 (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
386 (if (not dns-servers)
387 (message "No DNS server configuration found")
388 (mm-with-unibyte-buffer
389 (let ((process (condition-case ()
390 (dns-make-network-process (car dns-servers))
392 (message "dns: Got an error while trying to talk to %s"
395 (tcp-p (and (not (fboundp 'make-network-process))
396 (not (featurep 'xemacs))))
398 (times (* dns-timeout 1000))
403 (dns-write `((id ,id)
405 (queries ((,name (type ,type))))
406 (recursion-desired-p t))
408 (while (and (zerop (buffer-size))
410 (sit-for (/ step 1000.0))
411 (accept-process-output process 0 step)
414 (delete-process process))
416 (>= (buffer-size) 2))
417 (goto-char (point-min))
418 (delete-region (point) (+ (point) 2)))
419 (when (and (>= (buffer-size) 2)
420 ;; We had a time-out.
422 (let ((result (dns-read (buffer-string))))
425 (let ((answer (car (dns-get 'answers result))))
426 (when (eq type (dns-get 'type answer))
428 (dns-get-txt-answer (dns-get 'answers result))
429 (dns-get 'data answer))))))))))))