1 ;;; dns.el --- Domain Name Service lookups
2 ;; Copyright (C) 2002 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
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)
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.
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.
31 "How many seconds to wait when doing DNS queries.")
35 (defvar dns-query-types
56 "Names of query types and their values.")
63 "Classes of queries.")
65 (defun dns-write-bytes (value &optional length)
67 (dotimes (i (or length 1))
68 (push (% value 256) bytes)
69 (setq value (/ value 256)))
73 (defun dns-read-bytes (length)
76 (setq value (logior (* value 256) (following-char)))
80 (defun dns-get (type spec)
81 (cadr (assq type spec)))
83 (defun dns-inverse-get (value spec)
85 (while (and (not found)
87 (if (eq value (cadr (car spec)))
88 (setq found (caar spec))
92 (defun dns-write-name (name)
93 (dolist (part (split-string name "\\."))
94 (dns-write-bytes (length part))
98 (defun dns-read-string-name (string buffer)
99 (mm-with-unibyte-buffer
101 (goto-char (point-min))
102 (dns-read-name buffer)))
104 (defun dns-read-name (&optional buffer)
109 (setq length (dns-read-bytes 1))
110 (if (= 192 (logand length (lsh 3 6)))
111 (let ((offset (+ (* (logand 63 length) 256)
112 (dns-read-bytes 1))))
116 (goto-char (1+ offset))
117 (setq ended (dns-read-name buffer))))
120 (push (buffer-substring (point)
121 (progn (forward-char length) (point)))
124 (concat (mapconcat 'identity (nreverse name) ".") "." ended)
125 (mapconcat 'identity (nreverse name) "."))))
127 (defun dns-write (spec)
128 "Write a DNS packet according to SPEC."
130 (dns-write-bytes (dns-get 'id spec) 2)
133 (lsh (if (dns-get 'response-p spec) 1 0) -7)
136 ((eq (dns-get 'opcode spec) 'query) 0)
137 ((eq (dns-get 'opcode spec) 'inverse-query) 1)
138 ((eq (dns-get 'opcode spec) 'status) 2)
139 (t (error "No such opcode: %s" (dns-get 'opcode spec))))
141 (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
142 (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
143 (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
146 ((eq (dns-get 'response-code spec) 'no-error) 0)
147 ((eq (dns-get 'response-code spec) 'format-error) 1)
148 ((eq (dns-get 'response-code spec) 'server-failure) 2)
149 ((eq (dns-get 'response-code spec) 'name-error) 3)
150 ((eq (dns-get 'response-code spec) 'not-implemented) 4)
151 ((eq (dns-get 'response-code spec) 'refused) 5)
153 (dns-write-bytes (length (dns-get 'queries spec)) 2)
154 (dns-write-bytes (length (dns-get 'answers spec)) 2)
155 (dns-write-bytes (length (dns-get 'authorities spec)) 2)
156 (dns-write-bytes (length (dns-get 'additionals spec)) 2)
157 (dolist (query (dns-get 'queries spec))
158 (dns-write-name (car query))
159 (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
161 (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
163 (dolist (slot '(answers authorities additionals))
164 (dolist (resource (dns-get slot spec))
165 (dns-write-name (car resource))
166 (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
168 (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
170 (dns-write-bytes (dns-get 'ttl resource) 4)
171 (dns-write-bytes (length (dns-get 'data resource)) 2)
172 (insert (dns-get 'data resource))))
175 (defun dns-read (packet)
176 (mm-with-unibyte-buffer
178 queries answers authorities additionals)
180 (goto-char (point-min))
181 (push (list 'id (dns-read-bytes 2)) spec)
182 (let ((byte (dns-read-bytes 1)))
183 (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
185 (let ((opcode (logand byte (lsh 7 3))))
187 (cond ((eq opcode 0) 'query)
188 ((eq opcode 1) 'inverse-query)
189 ((eq opcode 2) 'status)))
191 (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
193 (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
195 (push (list 'recursion-desired-p
196 (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
197 (let ((rc (logand (dns-read-bytes 1) 15)))
198 (push (list 'response-code
200 ((eq rc 0) 'no-error)
201 ((eq rc 1) 'format-error)
202 ((eq rc 2) 'server-failure)
203 ((eq rc 3) 'name-error)
204 ((eq rc 4) 'not-implemented)
205 ((eq rc 5) 'refused)))
207 (setq queries (dns-read-bytes 2))
208 (setq answers (dns-read-bytes 2))
209 (setq authorities (dns-read-bytes 2))
210 (setq additionals (dns-read-bytes 2))
213 (push (list (dns-read-name)
214 (list 'type (dns-inverse-get (dns-read-bytes 2)
216 (list 'class (dns-inverse-get (dns-read-bytes 2)
219 (push (list 'queries qs) spec))
220 (dolist (slot '(answers authorities additionals))
223 (dotimes (i (symbol-value slot))
224 (push (list (dns-read-name)
226 (setq type (dns-inverse-get (dns-read-bytes 2)
228 (list 'class (dns-inverse-get (dns-read-bytes 2)
230 (list 'ttl (dns-read-bytes 4))
231 (let ((length (dns-read-bytes 2)))
236 (progn (forward-char length) (point)))
239 (push (list slot qs) spec)))
242 (defun dns-read-type (string type)
243 (let ((buffer (current-buffer))
246 (mm-with-unibyte-buffer
248 (goto-char (point-min))
253 (push (dns-read-bytes 1) bytes))
254 (mapconcat 'number-to-string (nreverse bytes) ".")))
256 (dns-read-string-name string buffer))
260 ;;; Interface functions.
262 (defun query-dns (name &optional type)
263 "Query a DNS server for NAME of TYPE."
264 (setq type (or type 'A))
265 (mm-with-unibyte-buffer
266 (let ((coding-system-for-read 'binary)
267 (coding-system-for-write 'binary))
269 (make-network-process
272 :buffer (current-buffer)
273 :host "ns2.netfonds.no"
277 (times (* dns-timeout 1000)))
282 (queries ((,name (type ,type))))
283 (recursion-desired-p t))))
284 (while (and (zerop (buffer-size))
286 (accept-process-output process 0 step)
289 (delete-process process))
290 (let ((answer (car (dns-get 'answers (dns-read (buffer-string))))))
291 (when (eq type (dns-get 'type answer))
292 (dns-get 'data answer)))))))