1 ;;; dns.el --- Domain Name Service lookups
2 ;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs 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 General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
28 (eval-when-compile (require 'cl
))
33 "How many seconds to wait when doing DNS queries.")
35 (defvar dns-servers nil
36 "Which DNS servers to query.
37 If nil, /etc/resolv.conf will be consulted.")
41 (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 (mm-with-unibyte-buffer
107 (goto-char (point-min))
108 (dns-read-name buffer
)))
110 (defun dns-read-name (&optional buffer
)
115 (setq length
(dns-read-bytes 1))
116 (if (= 192 (logand length
(lsh 3 6)))
117 (let ((offset (+ (* (logand 63 length
) 256)
118 (dns-read-bytes 1))))
122 (goto-char (1+ offset
))
123 (setq ended
(dns-read-name buffer
))))
126 (push (buffer-substring (point)
127 (progn (forward-char length
) (point)))
132 (concat (mapconcat 'identity
(nreverse name
) ".") "." ended
))
133 (mapconcat 'identity
(nreverse name
) "."))))
135 (defun dns-write (spec &optional tcp-p
)
136 "Write a DNS packet according to SPEC.
137 If TCP-P, the first two bytes of the package with be the length field."
139 (dns-write-bytes (dns-get 'id spec
) 2)
142 (lsh (if (dns-get 'response-p spec
) 1 0) -
7)
145 ((eq (dns-get 'opcode spec
) 'query
) 0)
146 ((eq (dns-get 'opcode spec
) 'inverse-query
) 1)
147 ((eq (dns-get 'opcode spec
) 'status
) 2)
148 (t (error "No such opcode: %s" (dns-get 'opcode spec
))))
150 (lsh (if (dns-get 'authoritative-p spec
) 1 0) -
2)
151 (lsh (if (dns-get 'truncated-p spec
) 1 0) -
1)
152 (lsh (if (dns-get 'recursion-desired-p spec
) 1 0) 0)))
155 ((eq (dns-get 'response-code spec
) 'no-error
) 0)
156 ((eq (dns-get 'response-code spec
) 'format-error
) 1)
157 ((eq (dns-get 'response-code spec
) 'server-failure
) 2)
158 ((eq (dns-get 'response-code spec
) 'name-error
) 3)
159 ((eq (dns-get 'response-code spec
) 'not-implemented
) 4)
160 ((eq (dns-get 'response-code spec
) 'refused
) 5)
162 (dns-write-bytes (length (dns-get 'queries spec
)) 2)
163 (dns-write-bytes (length (dns-get 'answers spec
)) 2)
164 (dns-write-bytes (length (dns-get 'authorities spec
)) 2)
165 (dns-write-bytes (length (dns-get 'additionals spec
)) 2)
166 (dolist (query (dns-get 'queries spec
))
167 (dns-write-name (car query
))
168 (dns-write-bytes (cadr (assq (or (dns-get 'type query
) 'A
)
170 (dns-write-bytes (cadr (assq (or (dns-get 'class query
) 'IN
)
172 (dolist (slot '(answers authorities additionals
))
173 (dolist (resource (dns-get slot spec
))
174 (dns-write-name (car resource
))
175 (dns-write-bytes (cadr (assq (dns-get 'type resource
) dns-query-types
))
177 (dns-write-bytes (cadr (assq (dns-get 'class resource
) dns-classes
))
179 (dns-write-bytes (dns-get 'ttl resource
) 4)
180 (dns-write-bytes (length (dns-get 'data resource
)) 2)
181 (insert (dns-get 'data resource
))))
183 (goto-char (point-min))
184 (dns-write-bytes (buffer-size) 2))
187 (defun dns-read (packet)
188 (mm-with-unibyte-buffer
190 queries answers authorities additionals
)
192 (goto-char (point-min))
193 (push (list 'id
(dns-read-bytes 2)) spec
)
194 (let ((byte (dns-read-bytes 1)))
195 (push (list 'response-p
(if (zerop (logand byte
(lsh 1 7))) nil t
))
197 (let ((opcode (logand byte
(lsh 7 3))))
199 (cond ((eq opcode
0) 'query
)
200 ((eq opcode
1) 'inverse-query
)
201 ((eq opcode
2) 'status
)))
203 (push (list 'authoritative-p
(if (zerop (logand byte
(lsh 1 2)))
205 (push (list 'truncated-p
(if (zerop (logand byte
(lsh 1 2))) nil t
))
207 (push (list 'recursion-desired-p
208 (if (zerop (logand byte
(lsh 1 0))) nil t
)) spec
))
209 (let ((rc (logand (dns-read-bytes 1) 15)))
210 (push (list 'response-code
212 ((eq rc
0) 'no-error
)
213 ((eq rc
1) 'format-error
)
214 ((eq rc
2) 'server-failure
)
215 ((eq rc
3) 'name-error
)
216 ((eq rc
4) 'not-implemented
)
217 ((eq rc
5) 'refused
)))
219 (setq queries
(dns-read-bytes 2))
220 (setq answers
(dns-read-bytes 2))
221 (setq authorities
(dns-read-bytes 2))
222 (setq additionals
(dns-read-bytes 2))
225 (push (list (dns-read-name)
226 (list 'type
(dns-inverse-get (dns-read-bytes 2)
228 (list 'class
(dns-inverse-get (dns-read-bytes 2)
231 (push (list 'queries qs
) spec
))
232 (dolist (slot '(answers authorities additionals
))
235 (dotimes (i (symbol-value slot
))
236 (push (list (dns-read-name)
238 (setq type
(dns-inverse-get (dns-read-bytes 2)
240 (list 'class
(dns-inverse-get (dns-read-bytes 2)
242 (list 'ttl
(dns-read-bytes 4))
243 (let ((length (dns-read-bytes 2)))
248 (progn (forward-char length
) (point)))
251 (push (list slot qs
) spec
)))
254 (defun dns-read-type (string type
)
255 (let ((buffer (current-buffer))
258 (mm-with-unibyte-buffer
260 (goto-char (point-min))
265 (push (dns-read-bytes 1) bytes
))
266 (mapconcat 'number-to-string
(nreverse bytes
) ".")))
268 (dns-read-string-name string buffer
))
270 (dns-read-string-name string buffer
))
274 (defun dns-parse-resolv-conf ()
275 (when (file-exists-p "/etc/resolv.conf")
277 (insert-file-contents "/etc/resolv.conf")
278 (goto-char (point-min))
279 (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t
)
280 (push (match-string 1) dns-servers
))
281 (setq dns-servers
(nreverse dns-servers
)))))
283 ;;; Interface functions.
285 (when (featurep 'xemacs
)
286 (require 'gnus-xmas
)))
288 (defmacro dns-make-network-process
(server)
289 (if (featurep 'xemacs
)
290 `(let ((coding-system-for-read 'binary
)
291 (coding-system-for-write 'binary
))
292 (gnus-xmas-open-network-stream "dns" (current-buffer)
293 ,server
"domain" 'udp
))
294 `(let ((server ,server
)
295 (coding-system-for-read 'binary
)
296 (coding-system-for-write 'binary
))
297 (if (fboundp 'make-network-process
)
298 (make-network-process
301 :buffer
(current-buffer)
305 ;; Older versions of Emacs doesn't have
306 ;; `make-network-process', so we fall back on opening a TCP
307 ;; connection to the DNS server.
308 (open-network-stream "dns" (current-buffer) server
"domain")))))
310 (defun query-dns (name &optional type fullp
)
311 "Query a DNS server for NAME of TYPE.
312 If FULLP, return the entire record returned."
313 (setq type
(or type
'A
))
315 (dns-parse-resolv-conf))
317 (if (not dns-servers
)
318 (message "No DNS server configuration found")
319 (mm-with-unibyte-buffer
320 (let ((process (condition-case ()
321 (dns-make-network-process (car dns-servers
))
323 (message "dns: Got an error while trying to talk to %s"
326 (tcp-p (and (not (fboundp 'make-network-process
))
327 (not (featurep 'xemacs
))))
329 (times (* dns-timeout
1000))
334 (dns-write `((id ,id
)
336 (queries ((,name
(type ,type
))))
337 (recursion-desired-p t
))
339 (while (and (zerop (buffer-size))
341 (accept-process-output process
0 step
)
344 (delete-process process
))
346 (goto-char (point-min))
347 (delete-region (point) (+ (point) 2)))
348 (unless (zerop (buffer-size))
349 (let ((result (dns-read (buffer-string))))
352 (let ((answer (car (dns-get 'answers result
))))
353 (when (eq type
(dns-get 'type answer
))
354 (dns-get 'data answer
)))))))))))
358 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a