ba6523f6f5fc8f193eba58459aa96a4e4a703258
[gnus] / lisp / dns.el
1 ;;; dns.el --- Domain Name Service lookups
2
3 ;; Copyright (C) 2002-2015 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: network comm
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 3 of the License, or
13 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (defvar dns-timeout 5
28   "How many seconds to wait when doing DNS queries.")
29
30 (defvar dns-servers nil
31   "List of DNS servers to query.
32 If nil, /etc/resolv.conf and nslookup will be consulted.")
33
34 (defvar dns-servers-valid-for-interfaces nil
35   "The return value of `network-interface-list' when `dns-servers' was set.
36 If the set of network interfaces and/or their IP addresses
37 change, then presumably the list of DNS servers needs to be
38 updated.  Set this variable to t to disable the check.")
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     (PTR 12)
55     (HINFO 13)
56     (MINFO 14)
57     (MX 15)
58     (TXT 16)
59     (AAAA 28) ; RFC3596
60     (SRV 33) ; RFC2782
61     (AXFR 252)
62     (MAILB 253)
63     (MAILA 254)
64     (* 255))
65   "Names of query types and their values.")
66
67 (defvar dns-classes
68   '((IN 1)
69     (CS 2)
70     (CH 3)
71     (HS 4))
72   "Classes of queries.")
73
74 (defun dns-write-bytes (value &optional length)
75   (let (bytes)
76     (dotimes (i (or length 1))
77       (push (% value 256) bytes)
78       (setq value (/ value 256)))
79     (dolist (byte bytes)
80       (insert byte))))
81
82 (defun dns-read-bytes (length)
83   (let ((value 0))
84     (dotimes (i length)
85       (setq value (logior (* value 256) (following-char)))
86       (forward-char 1))
87     value))
88
89 (defun dns-get (type spec)
90   (cadr (assq type spec)))
91
92 (defun dns-inverse-get (value spec)
93   (let ((found nil))
94     (while (and (not found)
95                 spec)
96       (if (eq value (cadr (car spec)))
97           (setq found (caar spec))
98         (pop spec)))
99     found))
100
101 (defun dns-write-name (name)
102   (dolist (part (split-string name "\\."))
103     (dns-write-bytes (length part))
104     (insert part))
105   (dns-write-bytes 0))
106
107 (defun dns-read-string-name (string buffer)
108   (with-temp-buffer
109     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
110     (insert string)
111     (goto-char (point-min))
112     (dns-read-name buffer)))
113
114 (defun dns-read-name (&optional buffer)
115   (let ((ended nil)
116         (name nil)
117         length)
118     (while (not ended)
119       (setq length (dns-read-bytes 1))
120       (if (= 192 (logand length (lsh 3 6)))
121           (let ((offset (+ (* (logand 63 length) 256)
122                            (dns-read-bytes 1))))
123             (save-excursion
124               (when buffer
125                 (set-buffer buffer))
126               (goto-char (1+ offset))
127               (setq ended (dns-read-name buffer))))
128         (if (zerop length)
129             (setq ended t)
130           (push (buffer-substring (point)
131                                   (progn (forward-char length) (point)))
132                 name))))
133     (if (stringp ended)
134         (if (null name)
135             ended
136           (concat (mapconcat 'identity (nreverse name) ".") "." ended))
137       (mapconcat 'identity (nreverse name) "."))))
138
139 (defun dns-write (spec &optional tcp-p)
140   "Write a DNS packet according to SPEC.
141 If TCP-P, the first two bytes of the package with be the length field."
142   (with-temp-buffer
143     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
144     (dns-write-bytes (dns-get 'id spec) 2)
145     (dns-write-bytes
146      (logior
147       (lsh (if (dns-get 'response-p spec) 1 0) -7)
148       (lsh
149        (cond
150         ((eq (dns-get 'opcode spec) 'query) 0)
151         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
152         ((eq (dns-get 'opcode spec) 'status) 2)
153         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
154        -3)
155       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
156       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
157       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
158     (dns-write-bytes
159      (cond
160       ((eq (dns-get 'response-code spec) 'no-error) 0)
161       ((eq (dns-get 'response-code spec) 'format-error) 1)
162       ((eq (dns-get 'response-code spec) 'server-failure) 2)
163       ((eq (dns-get 'response-code spec) 'name-error) 3)
164       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
165       ((eq (dns-get 'response-code spec) 'refused) 5)
166       (t 0)))
167     (dns-write-bytes (length (dns-get 'queries spec)) 2)
168     (dns-write-bytes (length (dns-get 'answers spec)) 2)
169     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
170     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
171     (dolist (query (dns-get 'queries spec))
172       (dns-write-name (car query))
173       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
174                                    dns-query-types)) 2)
175       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
176                                    dns-classes)) 2))
177     (dolist (slot '(answers authorities additionals))
178       (dolist (resource (dns-get slot spec))
179         (dns-write-name (car resource))
180       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
181                        2)
182       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
183                        2)
184       (dns-write-bytes (dns-get 'ttl resource) 4)
185       (dns-write-bytes (length (dns-get 'data resource)) 2)
186       (insert (dns-get 'data resource))))
187     (when tcp-p
188       (goto-char (point-min))
189       (dns-write-bytes (buffer-size) 2))
190     (buffer-string)))
191
192 (defun dns-read (packet)
193   (with-temp-buffer
194     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
195     (let ((spec nil)
196           queries answers authorities additionals)
197       (insert packet)
198       (goto-char (point-min))
199       (push (list 'id (dns-read-bytes 2)) spec)
200       (let ((byte (dns-read-bytes 1)))
201         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
202               spec)
203         (let ((opcode (logand byte (lsh 7 3))))
204           (push (list 'opcode
205                       (cond ((eq opcode 0) 'query)
206                             ((eq opcode 1) 'inverse-query)
207                             ((eq opcode 2) 'status)))
208                 spec))
209         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
210                                          nil t)) spec)
211         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
212               spec)
213         (push (list 'recursion-desired-p
214                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
215       (let ((rc (logand (dns-read-bytes 1) 15)))
216         (push (list 'response-code
217                     (cond
218                      ((eq rc 0) 'no-error)
219                      ((eq rc 1) 'format-error)
220                      ((eq rc 2) 'server-failure)
221                      ((eq rc 3) 'name-error)
222                      ((eq rc 4) 'not-implemented)
223                      ((eq rc 5) 'refused)))
224               spec))
225       (setq queries (dns-read-bytes 2))
226       (setq answers (dns-read-bytes 2))
227       (setq authorities (dns-read-bytes 2))
228       (setq additionals (dns-read-bytes 2))
229       (let ((qs nil))
230         (dotimes (i queries)
231           (push (list (dns-read-name)
232                       (list 'type (dns-inverse-get (dns-read-bytes 2)
233                                                    dns-query-types))
234                       (list 'class (dns-inverse-get (dns-read-bytes 2)
235                                                     dns-classes)))
236                 qs))
237         (push (list 'queries qs) spec))
238       (dolist (slot '(answers authorities additionals))
239         (let ((qs nil)
240               type)
241           (dotimes (i (symbol-value slot))
242             (push (list (dns-read-name)
243                         (list 'type
244                               (setq type (dns-inverse-get (dns-read-bytes 2)
245                                                           dns-query-types)))
246                         (list 'class (dns-inverse-get (dns-read-bytes 2)
247                                                       dns-classes))
248                         (list 'ttl (dns-read-bytes 4))
249                         (let ((length (dns-read-bytes 2)))
250                           (list 'data
251                                 (dns-read-type
252                                  (buffer-substring
253                                   (point)
254                                   (progn (forward-char length) (point)))
255                                  type))))
256                   qs))
257           (push (list slot qs) spec)))
258       (nreverse spec))))
259
260 (defun dns-read-int32 ()
261   ;; Full 32 bit Integers can't be handled by 32-bit Emacsen.  If we
262   ;; use floats, it works.
263   (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
264                     (dns-read-bytes 3))))
265
266 (defun dns-read-type (string type)
267   (let ((buffer (current-buffer))
268         (point (point)))
269     (prog1
270         (with-temp-buffer
271           (unless (featurep 'xemacs) (set-buffer-multibyte nil))
272           (insert string)
273           (goto-char (point-min))
274           (cond
275            ((eq type 'A)
276             (let ((bytes nil))
277               (dotimes (i 4)
278                 (push (dns-read-bytes 1) bytes))
279               (mapconcat 'number-to-string (nreverse bytes) ".")))
280            ((eq type 'AAAA)
281             (let (hextets)
282               (dotimes (i 8)
283                 (push (dns-read-bytes 2) hextets))
284               (mapconcat (lambda (n) (format "%x" n))
285                          (nreverse hextets) ":")))
286            ((eq type 'SOA)
287             (list (list 'mname (dns-read-name buffer))
288                   (list 'rname (dns-read-name buffer))
289                   (list 'serial (dns-read-int32))
290                   (list 'refresh (dns-read-int32))
291                   (list 'retry (dns-read-int32))
292                   (list 'expire (dns-read-int32))
293                   (list 'minimum (dns-read-int32))))
294            ((eq type 'SRV)
295             (list (list 'priority (dns-read-bytes 2))
296                   (list 'weight (dns-read-bytes 2))
297                   (list 'port (dns-read-bytes 2))
298                   (list 'target (dns-read-name buffer))))
299            ((eq type 'MX)
300             (cons (dns-read-bytes 2) (dns-read-name buffer)))
301            ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
302             (dns-read-string-name string buffer))
303            (t string)))
304       (goto-char point))))
305
306 (declare-function network-interface-list "process.c")
307
308 (defun dns-servers-up-to-date-p ()
309   "Return false if we need to recheck the list of DNS servers."
310   (and dns-servers
311        (or (eq dns-servers-valid-for-interfaces t)
312            ;; `network-interface-list' was introduced in Emacs 22.1.
313            (not (fboundp 'network-interface-list))
314            (equal dns-servers-valid-for-interfaces
315                   (network-interface-list)))))
316
317 (defun dns-set-servers ()
318   "Set `dns-servers' to a list of DNS servers or nil if none are found.
319 Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
320   (or (when (file-exists-p "/etc/resolv.conf")
321         (setq dns-servers nil)
322         (with-temp-buffer
323           (insert-file-contents "/etc/resolv.conf")
324           (goto-char (point-min))
325           (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
326             (push (match-string 1) dns-servers))
327           (setq dns-servers (nreverse dns-servers))))
328       (when (executable-find "nslookup")
329         (with-temp-buffer
330           (call-process "nslookup" nil t nil "localhost")
331           (goto-char (point-min))
332           (re-search-forward
333            "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
334           (setq dns-servers (list (match-string 1))))))
335   (when (fboundp 'network-interface-list)
336     (setq dns-servers-valid-for-interfaces (network-interface-list))))
337
338 (defun dns-read-txt (string)
339   (if (> (length string) 1)
340       (substring string 1)
341     string))
342
343 (defun dns-get-txt-answer (answers)
344   (let ((result "")
345         (do-next nil))
346     (dolist (answer answers)
347       (dolist (elem answer)
348         (when (consp elem)
349           (cond
350            ((eq (car elem) 'type)
351             (setq do-next (eq (cadr elem) 'TXT)))
352            ((eq (car elem) 'data)
353             (when do-next
354               (setq result (concat result (dns-read-txt (cadr elem))))))))))
355     result))
356
357 ;;; Interface functions.
358 (defmacro dns-make-network-process (server)
359   (if (featurep 'xemacs)
360       `(let ((coding-system-for-read 'binary)
361              (coding-system-for-write 'binary))
362          (open-network-stream "dns" (current-buffer)
363                               ,server "domain" 'udp))
364     `(let ((server ,server)
365            (coding-system-for-read 'binary)
366            (coding-system-for-write 'binary))
367        (if (fboundp 'make-network-process)
368            (make-network-process
369             :name "dns"
370             :coding 'binary
371             :buffer (current-buffer)
372             :host server
373             :service "domain"
374             :type 'datagram)
375          ;; Older versions of Emacs doesn't have
376          ;; `make-network-process', so we fall back on opening a TCP
377          ;; connection to the DNS server.
378          (open-network-stream "dns" (current-buffer) server "domain")))))
379
380 (defvar dns-cache (make-vector 4096 0))
381
382 (defun dns-query-cached (name &optional type fullp reversep)
383   (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
384          (sym (intern-soft key dns-cache)))
385     (if (and sym
386              (boundp sym))
387         (symbol-value sym)
388       (let ((result (dns-query name type fullp reversep)))
389         (set (intern key dns-cache) result)
390         result))))
391
392 ;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23
393 ;; yet, so no alias are provided.  --rsteib
394
395 (defun dns-query (name &optional type fullp reversep)
396   "Query a DNS server for NAME of TYPE.
397 If FULLP, return the entire record returned.
398 If REVERSEP, look up an IP address."
399   (setq type (or type 'A))
400   (unless (dns-servers-up-to-date-p)
401     (dns-set-servers))
402
403   (when reversep
404     (setq name (concat
405                 (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
406                 ".in-addr.arpa")
407           type 'PTR))
408
409   (if (not dns-servers)
410       (message "No DNS server configuration found")
411     (with-temp-buffer
412       (unless (featurep 'xemacs) (set-buffer-multibyte nil))
413       (let ((process (condition-case ()
414                          (dns-make-network-process (car dns-servers))
415                        (error
416                         (message
417                          "dns: Got an error while trying to talk to %s"
418                          (car dns-servers))
419                         nil)))
420             (tcp-p (and (not (fboundp 'make-network-process))
421                         (not (featurep 'xemacs))))
422             (step 100)
423             (times (* dns-timeout 1000))
424             (id (random 65000)))
425         (when process
426           (process-send-string
427            process
428            (dns-write `((id ,id)
429                         (opcode query)
430                         (queries ((,name (type ,type))))
431                         (recursion-desired-p t))
432                       tcp-p))
433           (while (and (zerop (buffer-size))
434                       (> times 0))
435             (sit-for (/ step 1000.0))
436             (accept-process-output process 0 step)
437             (setq times (- times step)))
438           (condition-case nil
439               (delete-process process)
440             (error nil))
441           (when (and tcp-p
442                      (>= (buffer-size) 2))
443             (goto-char (point-min))
444             (delete-region (point) (+ (point) 2)))
445           (when (and (>= (buffer-size) 2)
446                      ;; We had a time-out.
447                      (> times 0))
448             (let ((result (dns-read (buffer-string))))
449               (if fullp
450                   result
451                 (let ((answer (car (dns-get 'answers result))))
452                   (when (eq type (dns-get 'type answer))
453                     (if (eq type 'TXT)
454                         (dns-get-txt-answer (dns-get 'answers result))
455                       (dns-get 'data answer))))))))))))
456
457 (provide 'dns)
458
459 ;;; dns.el ends here