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