1 ;;; dns.el --- Domain Name Service lookups
3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
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)
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.
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.
29 (eval-when-compile (require 'cl))
34 "How many seconds to wait when doing DNS queries.")
36 (defvar dns-servers nil
37 "Which DNS servers to query.
38 If nil, /etc/resolv.conf will be consulted.")
42 (defvar dns-query-types
65 "Names of query types and their values.")
72 "Classes of queries.")
74 (defun dns-write-bytes (value &optional length)
76 (dotimes (i (or length 1))
77 (push (% value 256) bytes)
78 (setq value (/ value 256)))
82 (defun dns-read-bytes (length)
85 (setq value (logior (* value 256) (following-char)))
89 (defun dns-get (type spec)
90 (cadr (assq type spec)))
92 (defun dns-inverse-get (value spec)
94 (while (and (not found)
96 (if (eq value (cadr (car spec)))
97 (setq found (caar spec))
101 (defun dns-write-name (name)
102 (dolist (part (split-string name "\\."))
103 (dns-write-bytes (length part))
107 (defun dns-read-string-name (string buffer)
108 (mm-with-unibyte-buffer
110 (goto-char (point-min))
111 (dns-read-name buffer)))
113 (defun dns-read-name (&optional buffer)
118 (setq length (dns-read-bytes 1))
119 (if (= 192 (logand length (lsh 3 6)))
120 (let ((offset (+ (* (logand 63 length) 256)
121 (dns-read-bytes 1))))
125 (goto-char (1+ offset))
126 (setq ended (dns-read-name buffer))))
129 (push (buffer-substring (point)
130 (progn (forward-char length) (point)))
135 (concat (mapconcat 'identity (nreverse name) ".") "." ended))
136 (mapconcat 'identity (nreverse name) "."))))
138 (defun dns-write (spec &optional tcp-p)
139 "Write a DNS packet according to SPEC.
140 If TCP-P, the first two bytes of the package with be the length field."
142 (dns-write-bytes (dns-get 'id spec) 2)
145 (lsh (if (dns-get 'response-p spec) 1 0) -7)
148 ((eq (dns-get 'opcode spec) 'query) 0)
149 ((eq (dns-get 'opcode spec) 'inverse-query) 1)
150 ((eq (dns-get 'opcode spec) 'status) 2)
151 (t (error "No such opcode: %s" (dns-get 'opcode spec))))
153 (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
154 (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
155 (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
158 ((eq (dns-get 'response-code spec) 'no-error) 0)
159 ((eq (dns-get 'response-code spec) 'format-error) 1)
160 ((eq (dns-get 'response-code spec) 'server-failure) 2)
161 ((eq (dns-get 'response-code spec) 'name-error) 3)
162 ((eq (dns-get 'response-code spec) 'not-implemented) 4)
163 ((eq (dns-get 'response-code spec) 'refused) 5)
165 (dns-write-bytes (length (dns-get 'queries spec)) 2)
166 (dns-write-bytes (length (dns-get 'answers spec)) 2)
167 (dns-write-bytes (length (dns-get 'authorities spec)) 2)
168 (dns-write-bytes (length (dns-get 'additionals spec)) 2)
169 (dolist (query (dns-get 'queries spec))
170 (dns-write-name (car query))
171 (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
173 (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
175 (dolist (slot '(answers authorities additionals))
176 (dolist (resource (dns-get slot spec))
177 (dns-write-name (car resource))
178 (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
180 (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
182 (dns-write-bytes (dns-get 'ttl resource) 4)
183 (dns-write-bytes (length (dns-get 'data resource)) 2)
184 (insert (dns-get 'data resource))))
186 (goto-char (point-min))
187 (dns-write-bytes (buffer-size) 2))
190 (defun dns-read (packet)
191 (mm-with-unibyte-buffer
193 queries answers authorities additionals)
195 (goto-char (point-min))
196 (push (list 'id (dns-read-bytes 2)) spec)
197 (let ((byte (dns-read-bytes 1)))
198 (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
200 (let ((opcode (logand byte (lsh 7 3))))
202 (cond ((eq opcode 0) 'query)
203 ((eq opcode 1) 'inverse-query)
204 ((eq opcode 2) 'status)))
206 (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
208 (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
210 (push (list 'recursion-desired-p
211 (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
212 (let ((rc (logand (dns-read-bytes 1) 15)))
213 (push (list 'response-code
215 ((eq rc 0) 'no-error)
216 ((eq rc 1) 'format-error)
217 ((eq rc 2) 'server-failure)
218 ((eq rc 3) 'name-error)
219 ((eq rc 4) 'not-implemented)
220 ((eq rc 5) 'refused)))
222 (setq queries (dns-read-bytes 2))
223 (setq answers (dns-read-bytes 2))
224 (setq authorities (dns-read-bytes 2))
225 (setq additionals (dns-read-bytes 2))
228 (push (list (dns-read-name)
229 (list 'type (dns-inverse-get (dns-read-bytes 2)
231 (list 'class (dns-inverse-get (dns-read-bytes 2)
234 (push (list 'queries qs) spec))
235 (dolist (slot '(answers authorities additionals))
238 (dotimes (i (symbol-value slot))
239 (push (list (dns-read-name)
241 (setq type (dns-inverse-get (dns-read-bytes 2)
243 (list 'class (dns-inverse-get (dns-read-bytes 2)
245 (list 'ttl (dns-read-bytes 4))
246 (let ((length (dns-read-bytes 2)))
251 (progn (forward-char length) (point)))
254 (push (list slot qs) spec)))
257 (defun dns-read-int32 ()
258 ;; Full 32 bit Integers can't be handled by Emacs. If we use
260 (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
261 (dns-read-bytes 3))))