Merge from emacs--devo--0
[gnus] / lisp / dns.el
1 ;;; dns.el --- Domain Name Service lookups
2
3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 ;;   Free Software Foundation, Inc.
5
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Keywords: network
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 3, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;;; Code:
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     (PTR 12)
52     (HINFO 13)
53     (MINFO 14)
54     (MX 15)
55     (TXT 16)
56     (AAAA 28) ; RFC3596
57     (SRV 33) ; RFC2782
58     (AXFR 252)
59     (MAILB 253)
60     (MAILA 254)
61     (* 255))
62   "Names of query types and their values.")
63
64 (defvar dns-classes
65   '((IN 1)
66     (CS 2)
67     (CH 3)
68     (HS 4))
69   "Classes of queries.")
70
71 (defun dns-write-bytes (value &optional length)
72   (let (bytes)
73     (dotimes (i (or length 1))
74       (push (% value 256) bytes)
75       (setq value (/ value 256)))
76     (dolist (byte bytes)
77       (insert byte))))
78
79 (defun dns-read-bytes (length)
80   (let ((value 0))
81     (dotimes (i length)
82       (setq value (logior (* value 256) (following-char)))
83       (forward-char 1))
84     value))
85
86 (defun dns-get (type spec)
87   (cadr (assq type spec)))
88
89 (defun dns-inverse-get (value spec)
90   (let ((found nil))
91     (while (and (not found)
92                 spec)
93       (if (eq value (cadr (car spec)))
94           (setq found (caar spec))
95         (pop spec)))
96     found))
97
98 (defun dns-write-name (name)
99   (dolist (part (split-string name "\\."))
100     (dns-write-bytes (length part))
101     (insert part))
102   (dns-write-bytes 0))
103
104 (defun dns-read-string-name (string buffer)
105   (let (default-enable-multibyte-characters)
106     (with-temp-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.
138 If 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   (let (default-enable-multibyte-characters)
190     (with-temp-buffer
191       (let ((spec nil)
192             queries answers authorities additionals)
193         (insert packet)
194         (goto-char (point-min))
195         (push (list 'id (dns-read-bytes 2)) spec)
196         (let ((byte (dns-read-bytes 1)))
197           (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
198                 spec)
199           (let ((opcode (logand byte (lsh 7 3))))
200             (push (list 'opcode
201                         (cond ((eq opcode 0) 'query)
202                               ((eq opcode 1) 'inverse-query)
203                               ((eq opcode 2) 'status)))
204                   spec))
205           (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
206                                            nil t)) spec)
207           (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
208                 spec)
209           (push (list 'recursion-desired-p
210                       (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
211         (let ((rc (logand (dns-read-bytes 1) 15)))
212           (push (list 'response-code
213                       (cond
214                        ((eq rc 0) 'no-error)
215                        ((eq rc 1) 'format-error)
216                        ((eq rc 2) 'server-failure)
217                        ((eq rc 3) 'name-error)
218                        ((eq rc 4) 'not-implemented)
219                        ((eq rc 5) 'refused)))
220                 spec))
221         (setq queries (dns-read-bytes 2))
222         (setq answers (dns-read-bytes 2))
223         (setq authorities (dns-read-bytes 2))
224         (setq additionals (dns-read-bytes 2))
225         (let ((qs nil))
226           (dotimes (i queries)
227             (push (list (dns-read-name)
228                         (list 'type (dns-inverse-get (dns-read-bytes 2)
229                                                      dns-query-types))
230                         (list 'class (dns-inverse-get (dns-read-bytes 2)
231                                                       dns-classes)))
232                   qs))
233           (push (list 'queries qs) spec))
234         (dolist (slot '(answers authorities additionals))
235           (let ((qs nil)
236                 type)
237             (dotimes (i (symbol-value slot))
238               (push (list (dns-read-name)
239                           (list 'type
240                                 (setq type (dns-inverse-get (dns-read-bytes 2)
241                                                             dns-query-types)))
242                           (list 'class (dns-inverse-get (dns-read-bytes 2)
243                                                         dns-classes))
244                           (list 'ttl (dns-read-bytes 4))
245                           (let ((length (dns-read-bytes 2)))
246                             (list 'data
247                                   (dns-read-type
248                                    (buffer-substring
249                                     (point)
250                                     (progn (forward-char length) (point)))
251                                    type))))
252                     qs))
253             (push (list slot qs) spec)))
254         (nreverse spec)))))
255
256 (defun dns-read-int32 ()
257   ;; Full 32 bit Integers can't be handled by Emacs.  If we use
258   ;; floats, it works.
259   (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
260                     (dns-read-bytes 3))))
261
262 (defun dns-read-type (string type)
263   (let ((buffer (current-buffer))
264         (point (point)))
265     (prog1
266         (let (default-enable-multibyte-characters)
267           (with-temp-buffer
268             (insert string)
269             (goto-char (point-min))
270             (cond
271              ((eq type 'A)
272               (let ((bytes nil))
273                 (dotimes (i 4)
274                   (push (dns-read-bytes 1) bytes))
275                 (mapconcat 'number-to-string (nreverse bytes) ".")))
276              ((eq type 'AAAA)
277               (let (hextets)
278                 (dotimes (i 8)
279                   (push (dns-read-bytes 2) hextets))
280                 (mapconcat (lambda (n) (format "%x" n))
281                            (nreverse hextets) ":")))
282              ((eq type 'SOA)
283               (list (list 'mname (dns-read-name buffer))
284                     (list 'rname (dns-read-name buffer))
285                     (list 'serial (dns-read-int32))
286                     (list 'refresh (dns-read-int32))
287                     (list 'retry (dns-read-int32))
288                     (list 'expire (dns-read-int32))
289                     (list 'minimum (dns-read-int32))))
290              ((eq type 'SRV)
291               (list (list 'priority (dns-read-bytes 2))
292                     (list 'weight (dns-read-bytes 2))
293                     (list 'port (dns-read-bytes 2))
294                     (list 'target (dns-read-name buffer))))
295              ((eq type 'MX)
296               (cons (dns-read-bytes 2) (dns-read-name buffer)))
297              ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
298               (dns-read-string-name string buffer))
299              (t string))))
300       (goto-char point))))
301
302 (defun dns-parse-resolv-conf ()
303   (when (file-exists-p "/etc/resolv.conf")
304     (with-temp-buffer
305       (insert-file-contents "/etc/resolv.conf")
306       (goto-char (point-min))
307       (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
308         (push (match-string 1) dns-servers))
309       (setq dns-servers (nreverse dns-servers)))))
310
311 (defun dns-read-txt (string)
312   (if (> (length string) 1)
313       (substring string 1)
314     string))
315
316 (defun dns-get-txt-answer (answers)
317   (let ((result "")
318         (do-next nil))
319     (dolist (answer answers)
320       (dolist (elem answer)
321         (when (consp elem)
322           (cond
323            ((eq (car elem) 'type)
324             (setq do-next (eq (cadr elem) 'TXT)))
325            ((eq (car elem) 'data)
326             (when do-next
327               (setq result (concat result (dns-read-txt (cadr elem))))))))))
328     result))
329
330 ;;; Interface functions.
331 (defmacro dns-make-network-process (server)
332   (if (featurep 'xemacs)
333       `(let ((coding-system-for-read 'binary)
334              (coding-system-for-write 'binary))
335          (open-network-stream "dns" (current-buffer)
336                               ,server "domain" 'udp))
337     `(let ((server ,server)
338            (coding-system-for-read 'binary)
339            (coding-system-for-write 'binary))
340        (if (fboundp 'make-network-process)
341            (make-network-process
342             :name "dns"
343             :coding 'binary
344             :buffer (current-buffer)
345             :host server
346             :service "domain"
347             :type 'datagram)
348          ;; Older versions of Emacs doesn't have
349          ;; `make-network-process', so we fall back on opening a TCP
350          ;; connection to the DNS server.
351          (open-network-stream "dns" (current-buffer) server "domain")))))
352
353 (defvar dns-cache (make-vector 4096 0))
354
355 (defun query-dns-cached (name &optional type fullp reversep)
356   (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
357          (sym (intern-soft key dns-cache)))
358     (if (and sym
359              (boundp sym))
360         (symbol-value sym)
361       (let ((result (query-dns name type fullp reversep)))
362         (set (intern key dns-cache) result)
363         result))))
364
365 (defun query-dns (name &optional type fullp reversep)
366   "Query a DNS server for NAME of TYPE.
367 If FULLP, return the entire record returned.
368 If REVERSEP, look up an IP address."
369   (setq type (or type 'A))
370   (unless dns-servers
371     (dns-parse-resolv-conf))
372
373   (when reversep
374     (setq name (concat
375                 (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
376                 ".in-addr.arpa")
377           type 'PTR))
378
379   (if (not dns-servers)
380       (message "No DNS server configuration found")
381     (let (default-enable-multibyte-characters)
382       (with-temp-buffer
383         (let ((process (condition-case ()
384                            (dns-make-network-process (car dns-servers))
385                          (error
386                           (message
387                            "dns: Got an error while trying to talk to %s"
388                            (car dns-servers))
389                           nil)))
390               (tcp-p (and (not (fboundp 'make-network-process))
391                           (not (featurep 'xemacs))))
392               (step 100)
393               (times (* dns-timeout 1000))
394               (id (random 65000)))
395           (when process
396             (process-send-string
397              process
398              (dns-write `((id ,id)
399                           (opcode query)
400                           (queries ((,name (type ,type))))
401                           (recursion-desired-p t))
402                         tcp-p))
403             (while (and (zerop (buffer-size))
404                         (> times 0))
405               (sit-for (/ step 1000.0))
406               (accept-process-output process 0 step)
407               (setq times (- times step)))
408             (condition-case nil
409                 (delete-process process)
410               (error nil))
411             (when (and tcp-p
412                        (>= (buffer-size) 2))
413               (goto-char (point-min))
414               (delete-region (point) (+ (point) 2)))
415             (when (and (>= (buffer-size) 2)
416                        ;; We had a time-out.
417                        (> times 0))
418               (let ((result (dns-read (buffer-string))))
419                 (if fullp
420                     result
421                   (let ((answer (car (dns-get 'answers result))))
422                     (when (eq type (dns-get 'type answer))
423                       (if (eq type 'TXT)
424                           (dns-get-txt-answer (dns-get 'answers result))
425                         (dns-get 'data answer)))))))))))))
426
427 (provide 'dns)
428
429 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
430 ;;; dns.el ends here