1;;; dns.el --- Domain Name Service lookups
2
3;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
4
5;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6;; Keywords: network
7
8;; This file is part of GNU Emacs.
9
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)
13;; any later version.
14
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.
19
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.
24
25;;; Commentary:
26
27;;; Code:
28
29(eval-when-compile (require 'cl))
30
31(require 'mm-util)
32
33(defvar dns-timeout 5
34  "How many seconds to wait when doing DNS queries.")
35
36(defvar dns-servers nil
37  "Which DNS servers to query.
38If nil, /etc/resolv.conf will be consulted.")
39
40;;; Internal code:
41
42(defvar dns-query-types
43  '((A 1)
44    (NS 2)
45    (MD 3)
46    (MF 4)
47    (CNAME 5)
48    (SOA 6)
49    (MB 7)
50    (MG 8)
51    (MR 9)
52    (NULL 10)
53    (WKS 11)
54    (PRT 12)
55    (HINFO 13)
56    (MINFO 14)
57    (MX 15)
58    (TXT 16)
59    (AXFR 252)
60    (MAILB 253)
61    (MAILA 254)
62    (* 255))
63  "Names of query types and their values.")
64
65(defvar dns-classes
66  '((IN 1)
67    (CS 2)
68    (CH 3)
69    (HS 4))
70  "Classes of queries.")
71
72(defun dns-write-bytes (value &optional length)
73  (let (bytes)
74    (dotimes (i (or length 1))
75      (push (% value 256) bytes)
76      (setq value (/ value 256)))
77    (dolist (byte bytes)
78      (insert byte))))
79
80(defun dns-read-bytes (length)
81  (let ((value 0))
82    (dotimes (i length)
83      (setq value (logior (* value 256) (following-char)))
84      (forward-char 1))
85    value))
86
87(defun dns-get (type spec)
88  (cadr (assq type spec)))
89
90(defun dns-inverse-get (value spec)
91  (let ((found nil))
92    (while (and (not found)
93		spec)
94      (if (eq value (cadr (car spec)))
95	  (setq found (caar spec))
96	(pop spec)))
97    found))
98
99(defun dns-write-name (name)
100  (dolist (part (split-string name "\\."))
101    (dns-write-bytes (length part))
102    (insert part))
103  (dns-write-bytes 0))
104
105(defun dns-read-string-name (string buffer)
106  (mm-with-unibyte-buffer
107    (insert string)
108    (goto-char (point-min))
109    (dns-read-name buffer)))
110
111(defun dns-read-name (&optional buffer)
112  (let ((ended nil)
113	(name nil)
114	length)
115    (while (not ended)
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))))
120	    (save-excursion
121	      (when buffer
122		(set-buffer buffer))
123	      (goto-char (1+ offset))
124	      (setq ended (dns-read-name buffer))))
125	(if (zerop length)
126	    (setq ended t)
127	  (push (buffer-substring (point)
128				  (progn (forward-char length) (point)))
129		name))))
130    (if (stringp ended)
131	(if (null name)
132	    ended
133	  (concat (mapconcat 'identity (nreverse name) ".") "." ended))
134      (mapconcat 'identity (nreverse name) "."))))
135
136(defun dns-write (spec &optional tcp-p)
137  "Write a DNS packet according to SPEC.
138If TCP-P, the first two bytes of the package with be the length field."
139  (with-temp-buffer
140    (dns-write-bytes (dns-get 'id spec) 2)
141    (dns-write-bytes
142     (logior
143      (lsh (if (dns-get 'response-p spec) 1 0) -7)
144      (lsh
145       (cond
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))))
150       -3)
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)))
154    (dns-write-bytes
155     (cond
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)
162      (t 0)))
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)
170				   dns-query-types)) 2)
171      (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
172				   dns-classes)) 2))
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))
177		       2)
178      (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
179		       2)
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))))
183    (when tcp-p
184      (goto-char (point-min))
185      (dns-write-bytes (buffer-size) 2))
186    (buffer-string)))
187
188(defun dns-read (packet)
189  (mm-with-unibyte-buffer
190    (let ((spec nil)
191	  queries answers authorities additionals)
192      (insert packet)
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))
197	      spec)
198	(let ((opcode (logand byte (lsh 7 3))))
199	  (push (list 'opcode
200		      (cond ((eq opcode 0) 'query)
201			    ((eq opcode 1) 'inverse-query)
202			    ((eq opcode 2) 'status)))
203		spec))
204	(push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
205					 nil t)) spec)
206	(push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
207	      spec)
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
212		    (cond
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)))
219	      spec))
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))
224      (let ((qs nil))
225	(dotimes (i queries)
226	  (push (list (dns-read-name)
227		      (list 'type (dns-inverse-get (dns-read-bytes 2)
228						   dns-query-types))
229		      (list 'class (dns-inverse-get (dns-read-bytes 2)
230						    dns-classes)))
231		qs))
232	(push (list 'queries qs) spec))
233    (dolist (slot '(answers authorities additionals))
234      (let ((qs nil)
235	    type)
236	(dotimes (i (symbol-value slot))
237	  (push (list (dns-read-name)
238		      (list 'type
239			    (setq type (dns-inverse-get (dns-read-bytes 2)
240							dns-query-types)))
241		      (list 'class (dns-inverse-get (dns-read-bytes 2)
242						    dns-classes))
243		      (list 'ttl (dns-read-bytes 4))
244		      (let ((length (dns-read-bytes 2)))
245			(list 'data
246			      (dns-read-type
247			       (buffer-substring
248				(point)
249				(progn (forward-char length) (point)))
250			       type))))
251		qs))
252	(push (list slot qs) spec)))
253    (nreverse spec))))
254
255(defun dns-read-type (string type)
256  (let ((buffer (current-buffer))
257	(point (point)))
258    (prog1
259	(mm-with-unibyte-buffer
260	  (insert string)
261	  (goto-char (point-min))
262	  (cond
263	   ((eq type 'A)
264	    (let ((bytes nil))
265	      (dotimes (i 4)
266		(push (dns-read-bytes 1) bytes))
267	      (mapconcat 'number-to-string (nreverse bytes) ".")))
268	   ((eq type 'NS)
269	    (dns-read-string-name string buffer))
270	   ((eq type 'CNAME)
271	    (dns-read-string-name string buffer))
272	   (t string)))
273      (goto-char point))))
274
275(defun dns-parse-resolv-conf ()
276  (when (file-exists-p "/etc/resolv.conf")
277    (with-temp-buffer
278      (insert-file-contents "/etc/resolv.conf")
279      (goto-char (point-min))
280      (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
281	(push (match-string 1) dns-servers))
282      (setq dns-servers (nreverse dns-servers)))))
283
284;;; Interface functions.
285(eval-when-compile
286  (when (featurep 'xemacs)
287    (require 'gnus-xmas)))
288
289(defmacro dns-make-network-process (server)
290  (if (featurep 'xemacs)
291      `(let ((coding-system-for-read 'binary)
292	     (coding-system-for-write 'binary))
293	 (gnus-xmas-open-network-stream "dns" (current-buffer)
294					,server "domain" 'udp))
295    `(let ((server ,server)
296	   (coding-system-for-read 'binary)
297	   (coding-system-for-write 'binary))
298       (if (fboundp 'make-network-process)
299	   (make-network-process
300	    :name "dns"
301	    :coding 'binary
302	    :buffer (current-buffer)
303	    :host server
304	    :service "domain"
305	    :type 'datagram)
306	 ;; Older versions of Emacs doesn't have
307	 ;; `make-network-process', so we fall back on opening a TCP
308	 ;; connection to the DNS server.
309	 (open-network-stream "dns" (current-buffer) server "domain")))))
310
311(defun query-dns (name &optional type fullp)
312  "Query a DNS server for NAME of TYPE.
313If FULLP, return the entire record returned."
314  (setq type (or type 'A))
315  (unless dns-servers
316    (dns-parse-resolv-conf))
317
318  (if (not dns-servers)
319      (message "No DNS server configuration found")
320    (mm-with-unibyte-buffer
321      (let ((process (condition-case ()
322			 (dns-make-network-process (car dns-servers))
323		       (error
324			(message "dns: Got an error while trying to talk to %s"
325				 (car dns-servers))
326			nil)))
327	    (tcp-p (and (not (fboundp 'make-network-process))
328			(not (featurep 'xemacs))))
329	    (step 100)
330	    (times (* dns-timeout 1000))
331	    (id (random 65000)))
332	(when process
333	  (process-send-string
334	   process
335	   (dns-write `((id ,id)
336			(opcode query)
337			(queries ((,name (type ,type))))
338			(recursion-desired-p t))
339		      tcp-p))
340	  (while (and (zerop (buffer-size))
341		      (> times 0))
342	    (accept-process-output process 0 step)
343	    (decf times step))
344	  (ignore-errors
345	    (delete-process process))
346	  (when (and tcp-p
347		     (>= (buffer-size) 2))
348	    (goto-char (point-min))
349	    (delete-region (point) (+ (point) 2)))
350	  (when (>= (buffer-size) 2)
351	    (let ((result (dns-read (buffer-string))))
352	      (if fullp
353		  result
354		(let ((answer (car (dns-get 'answers result))))
355		  (when (eq type (dns-get 'type answer))
356		    (dns-get 'data answer)))))))))))
357
358(provide 'dns)
359
360;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
361;;; dns.el ends here
362