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
63 "Names of query types and their values.")
70 "Classes of queries.")
72 (defun dns-write-bytes (value &optional length)
74 (dotimes (i (or length 1))
75 (push (% value 256) bytes)
76 (setq value (/ value 256)))
80 (defun dns-read-bytes (length)
83 (setq value (logior (* value 256) (following-char)))
87 (defun dns-get (type spec)
88 (cadr (assq type spec)))
90 (defun dns-inverse-get (value spec)
92 (while (and (not found)
94 (if (eq value (cadr (car spec)))
95 (setq found (caar spec))
99 (defun dns-write-name (name)
100 (dolist (part (split-string name "\\."))
101 (dns-write-bytes (length part))
105 (defun dns-read-string-name (string buffer)
106 (mm-with-unibyte-buffer
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 (mm-with-unibyte-buffer
191 queries answers authorities additionals)
193 (goto-char (point-min))
194 (push (list 'id (dns-read-bytes 2)) spec)
195 (let ((byte (dns-read-bytes 1)))
196 (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
198 (let ((opcode (logand byte (lsh 7 3))))
200 (cond ((eq opcode 0) 'query)
201 ((eq opcode 1) 'inverse-query)
202 ((eq opcode 2) 'status)))
204 (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
206 (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
208 (push (list 'recursion-desired-p
209 (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
210 (let ((rc (logand (dns-read-bytes 1) 15)))
211 (push (list 'response-code
213 ((eq rc 0) 'no-error)
214 ((eq rc 1) 'format-error)
215 ((eq rc 2) 'server-failure)
216 ((eq rc 3) 'name-error)
217 ((eq rc 4) 'not-implemented)
218 ((eq rc 5) 'refused)))
220 (setq queries (dns-read-bytes 2))
221 (setq answers (dns-read-bytes 2))
222 (setq authorities (dns-read-bytes 2))
223 (setq additionals (dns-read-bytes 2))
226 (push (list (dns-read-name)
227 (list 'type (dns-inverse-get (dns-read-bytes 2)
229 (list 'class (dns-inverse-get (dns-read-bytes 2)
232 (push (list 'queries qs) spec))
233 (dolist (slot '(answers authorities additionals))
236 (dotimes (i (symbol-value slot))
237 (push (list (dns-read-name)
239 (setq type (dns-inverse-get (dns-read-bytes 2)
241 (list 'class (dns-inverse-get (dns-read-bytes 2)
243 (list 'ttl (dns-read-bytes 4))
244 (let ((length (dns-read-bytes 2)))
249 (progn (forward-char length) (point)))
252 (push (list slot qs) spec)))
255 (defun dns-read-int32 ()
256 ;; Full 32 bit Integers can't be handled by Emacs. If we use
258 (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
259 (dns-read-bytes 3))))
261 (defun dns-read-type (string type)
262 (let ((buffer (current-buffer))
265 (mm-with-unibyte-buffer
267 (goto-char (point-min))
272 (push (dns-read-bytes 1) bytes))
273 (mapconcat 'number-to-string (nreverse bytes) ".")))
277 (push (dns-read-bytes 2) hextets))
278 (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":")))
280 (list (list 'mname (dns-read-name buffer))
281 (list 'rname (dns-read-name buffer))
282 (list 'serial (dns-read-int32))
283 (list 'refresh (dns-read-int32))
284 (list 'retry (dns-read-int32))
285 (list 'expire (dns-read-int32))
286 (list 'minimum (dns-read-int32))))
288 (cons (dns-read-bytes 2) (dns-read-name buffer)))
289 ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
290 (dns-read-string-name string buffer))
294 (defun dns-parse-resolv-conf ()
295 (when (file-exists-p "/etc/resolv.conf")
297 (insert-file-contents "/etc/resolv.conf")
298 (goto-char (point-min))
299 (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
300 (push (match-string 1) dns-servers))
301 (setq dns-servers (nreverse dns-servers)))))
303 ;;; Interface functions.
305 (when (featurep 'xemacs)
306 (require 'gnus-xmas)))
308 (defmacro dns-make-network-process (server)
309 (if (featurep 'xemacs)
310 `(let ((coding-system-for-read 'binary)
311 (coding-system-for-write 'binary))
312 (open-network-stream "dns" (current-buffer)
313 ,server "domain" 'udp))
314 `(let ((server ,server)
315 (coding-system-for-read 'binary)
316 (coding-system-for-write 'binary)
317 (default-process-coding-system '(binary . binary))
318 program-coding-system-alist)
319 (if (fboundp 'make-network-process)
320 (make-network-process
323 :buffer (current-buffer)
327 ;; Older versions of Emacs doesn't have
328 ;; `make-network-process', so we fall back on opening a TCP
329 ;; connection to the DNS server.
330 (open-network-stream "dns" (current-buffer) server "domain")))))
332 (defun query-dns (name &optional type fullp)
333 "Query a DNS server for NAME of TYPE.
334 If FULLP, return the entire record returned."
335 (setq type (or type 'A))
337 (dns-parse-resolv-conf))
339 (if (not dns-servers)
340 (message "No DNS server configuration found")
341 (mm-with-unibyte-buffer
342 (let ((process (condition-case ()
343 (dns-make-network-process (car dns-servers))
345 (message "dns: Got an error while trying to talk to %s"
348 (tcp-p (and (not (fboundp 'make-network-process))
349 (not (featurep 'xemacs))))
351 (times (* dns-timeout 1000))
356 (dns-write `((id ,id)
358 (queries ((,name (type ,type))))
359 (recursion-desired-p t))
361 (while (and (zerop (buffer-size))
363 (accept-process-output process 0 step)
366 (delete-process process))
368 (goto-char (point-min))
369 (delete-region (point) (+ (point) 2)))
370 (unless (zerop (buffer-size))
371 (let ((result (dns-read (buffer-string))))
374 (let ((answer (car (dns-get 'answers result))))
375 (when (eq type (dns-get 'type answer))
376 (dns-get 'data answer)))))))))))