lisp/gnus/dns.el

   1 ;;; dns.el --- Domain Name Service lookups
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: network
   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 2, or (at your option)
  13 ;; 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; 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.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'mm-util)
  32
  33 (defvar dns-timeout 5
  34   "How many seconds to wait when doing DNS queries.")
  35
  36 (defvar dns-servers nil
  37   "Which DNS servers to query.
  38 If nil, /etc/resolv.conf will be consulted.")
  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     (PRT 12)
  55     (HINFO 13)
  56     (MINFO 14)
  57     (MX 15)
  58     (TXT 16)
  59     (AXFR 252)
  60     (MAILB 253)
  61     (MAILA 254)
  62     (* 255))
  63   "Names of query types and their values.")
  64
  65 (defvar dns-classes
  66   '((IN 1)
  67     (CS 2)
  68     (CH 3)
  69     (HS 4))
  70   "Classes of queries.")
  71
  72 (defun dns-write-bytes (value &optional length)
  73   (let (bytes)
  74     (dotimes (i (or length 1))
  75       (push (% value 256) bytes)
  76       (setq value (/ value 256)))
  77     (dolist (byte bytes)
  78       (insert byte))))
  79
  80 (defun dns-read-bytes (length)
  81   (let ((value 0))
  82     (dotimes (i length)
  83       (setq value (logior (* value 256) (following-char)))
  84       (forward-char 1))
  85     value))
  86
  87 (defun dns-get (type spec)
  88   (cadr (assq type spec)))
  89
  90 (defun dns-inverse-get (value spec)
  91   (let ((found nil))
  92     (while (and (not found)
  93                 spec)
  94       (if (eq value (cadr (car spec)))
  95           (setq found (caar spec))
  96         (pop spec)))
  97     found))
  98
  99 (defun dns-write-name (name)
 100   (dolist (part (split-string name "\\."))
 101     (dns-write-bytes (length part))
 102     (insert part))
 103   (dns-write-bytes 0))
 104
 105 (defun dns-read-string-name (string buffer)
 106   (mm-with-unibyte-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   (mm-with-unibyte-buffer
 190     (let ((spec nil)
 191           queries answers authorities additionals)
 192       (insert packet)
 193       (goto-char (point-min))
 194       (push (list 'id (dns-read-bytes 2)) spec)
 195       (let ((byte (dns-read-bytes 1)))
 196         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
 197               spec)
 198         (let ((opcode (logand byte (lsh 7 3))))
 199           (push (list 'opcode
 200                       (cond ((eq opcode 0) 'query)
 201                             ((eq opcode 1) 'inverse-query)
 202                             ((eq opcode 2) 'status)))
 203                 spec))
 204         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
 205                                          nil t)) spec)
 206         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
 207               spec)
 208         (push (list 'recursion-desired-p
 209                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
 210       (let ((rc (logand (dns-read-bytes 1) 15)))
 211         (push (list 'response-code
 212                     (cond
 213                      ((eq rc 0) 'no-error)
 214                      ((eq rc 1) 'format-error)
 215                      ((eq rc 2) 'server-failure)
 216                      ((eq rc 3) 'name-error)
 217                      ((eq rc 4) 'not-implemented)
 218                      ((eq rc 5) 'refused)))
 219               spec))
 220       (setq queries (dns-read-bytes 2))
 221       (setq answers (dns-read-bytes 2))
 222       (setq authorities (dns-read-bytes 2))
 223       (setq additionals (dns-read-bytes 2))
 224       (let ((qs nil))
 225         (dotimes (i queries)
 226           (push (list (dns-read-name)
 227                       (list 'type (dns-inverse-get (dns-read-bytes 2)
 228                                                    dns-query-types))
 229                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 230                                                     dns-classes)))
 231                 qs))
 232         (push (list 'queries qs) spec))
 233     (dolist (slot '(answers authorities additionals))
 234       (let ((qs nil)
 235             type)
 236         (dotimes (i (symbol-value slot))
 237           (push (list (dns-read-name)
 238                       (list 'type
 239                             (setq type (dns-inverse-get (dns-read-bytes 2)
 240                                                         dns-query-types)))
 241                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 242                                                     dns-classes))
 243                       (list 'ttl (dns-read-bytes 4))
 244                       (let ((length (dns-read-bytes 2)))
 245                         (list 'data
 246                               (dns-read-type
 247                                (buffer-substring
 248                                 (point)
 249                                 (progn (forward-char length) (point)))
 250                                type))))
 251                 qs))
 252         (push (list slot qs) spec)))
 253     (nreverse spec))))
 254
 255 (defun dns-read-type (string type)
 256   (let ((buffer (current-buffer))
 257         (point (point)))
 258     (prog1
 259         (mm-with-unibyte-buffer
 260           (insert string)
 261           (goto-char (point-min))
 262           (cond
 263            ((eq type 'A)
 264             (let ((bytes nil))
 265               (dotimes (i 4)
 266                 (push (dns-read-bytes 1) bytes))
 267               (mapconcat 'number-to-string (nreverse bytes) ".")))
 268            ((eq type 'NS)
 269             (dns-read-string-name string buffer))
 270            ((eq type 'CNAME)
 271             (dns-read-string-name string buffer))
 272            (t string)))
 273       (goto-char point))))
 274
 275 (defun dns-parse-resolv-conf ()
 276   (when (file-exists-p "/etc/resolv.conf")
 277     (with-temp-buffer
 278       (insert-file-contents "/etc/resolv.conf")
 279       (goto-char (point-min))
 280       (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 281         (push (match-string 1) dns-servers))
 282       (setq dns-servers (nreverse dns-servers)))))
 283
 284 ;;; Interface functions.
 285 (eval-when-compile
 286   (when (featurep 'xemacs)
 287     (require 'gnus-xmas)))
 288
 289 (defmacro dns-make-network-process (server)
 290   (if (featurep 'xemacs)
 291       `(let ((coding-system-for-read 'binary)
 292              (coding-system-for-write 'binary))
 293          (gnus-xmas-open-network-stream "dns" (current-buffer)
 294                                         ,server "domain" 'udp))
 295     `(let ((server ,server)
 296            (coding-system-for-read 'binary)
 297            (coding-system-for-write 'binary))
 298        (if (fboundp 'make-network-process)
 299            (make-network-process
 300             :name "dns"
 301             :coding 'binary
 302             :buffer (current-buffer)
 303             :host server
 304             :service "domain"
 305             :type 'datagram)
 306          ;; Older versions of Emacs doesn't have
 307          ;; `make-network-process', so we fall back on opening a TCP
 308          ;; connection to the DNS server.
 309          (open-network-stream "dns" (current-buffer) server "domain")))))
 310
 311 (defun query-dns (name &optional type fullp)
 312   "Query a DNS server for NAME of TYPE.
 313 If FULLP, return the entire record returned."
 314   (setq type (or type 'A))
 315   (unless dns-servers
 316     (dns-parse-resolv-conf))
 317
 318   (if (not dns-servers)
 319       (message "No DNS server configuration found")
 320     (mm-with-unibyte-buffer
 321       (let ((process (condition-case ()
 322                          (dns-make-network-process (car dns-servers))
 323                        (error
 324                         (message "dns: Got an error while trying to talk to %s"
 325                                  (car dns-servers))
 326                         nil)))
 327             (tcp-p (and (not (fboundp 'make-network-process))
 328                         (not (featurep 'xemacs))))
 329             (step 100)
 330             (times (* dns-timeout 1000))
 331             (id (random 65000)))
 332         (when process
 333           (process-send-string
 334            process
 335            (dns-write `((id ,id)
 336                         (opcode query)
 337                         (queries ((,name (type ,type))))
 338                         (recursion-desired-p t))
 339                       tcp-p))
 340           (while (and (zerop (buffer-size))
 341                       (> times 0))
 342             (accept-process-output process 0 step)
 343             (decf times step))
 344           (ignore-errors
 345             (delete-process process))
 346           (when tcp-p
 347             (goto-char (point-min))
 348             (delete-region (point) (+ (point) 2)))
 349           (unless (zerop (buffer-size))
 350             (let ((result (dns-read (buffer-string))))
 351               (if fullp
 352                   result
 353                 (let ((answer (car (dns-get 'answers result))))
 354                   (when (eq type (dns-get 'type answer))
 355                     (dns-get 'data answer)))))))))))
 356
 357 (provide 'dns)
 358
 359 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
 360 ;;; dns.el ends here