cgit.sxemacs.org Git - gnus/blob - lisp/dns.el

   1 ;;; dns.el --- Domain Name Service lookups
   2 ;; Copyright (C) 2002, 2003 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: network
   6
   7 ;; This file is part of GNU Emacs.
   8
   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)
  12 ;; any later version.
  13
  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.
  18
  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.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'mm-util)
  31
  32 (defvar dns-timeout 5
  33   "How many seconds to wait when doing DNS queries.")
  34
  35 (defvar dns-servers nil
  36   "Which DNS servers to query.
  37 If nil, /etc/resolv.conf will be consulted.")
  38
  39 ;;; Internal code:
  40
  41 (defvar dns-query-types
  42   '((A 1)
  43     (NS 2)
  44     (MD 3)
  45     (MF 4)
  46     (CNAME 5)
  47     (SOA 6)
  48     (MB 7)
  49     (MG 8)
  50     (MR 9)
  51     (NULL 10)
  52     (WKS 11)
  53     (PRT 12)
  54     (HINFO 13)
  55     (MINFO 14)
  56     (MX 15)
  57     (TXT 16)
  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   (mm-with-unibyte-buffer
 106     (insert string)
 107     (goto-char (point-min))
 108     (dns-read-name buffer)))
 109
 110 (defun dns-read-name (&optional buffer)
 111   (let ((ended nil)
 112         (name nil)
 113         length)
 114     (while (not ended)
 115       (setq length (dns-read-bytes 1))
 116       (if (= 192 (logand length (lsh 3 6)))
 117           (let ((offset (+ (* (logand 63 length) 256)
 118                            (dns-read-bytes 1))))
 119             (save-excursion
 120               (when buffer
 121                 (set-buffer buffer))
 122               (goto-char (1+ offset))
 123               (setq ended (dns-read-name buffer))))
 124         (if (zerop length)
 125             (setq ended t)
 126           (push (buffer-substring (point)
 127                                   (progn (forward-char length) (point)))
 128                 name))))
 129     (if (stringp ended)
 130         (if (null name)
 131             ended
 132           (concat (mapconcat 'identity (nreverse name) ".") "." ended))
 133       (mapconcat 'identity (nreverse name) "."))))
 134
 135 (defun dns-write (spec &optional tcp-p)
 136   "Write a DNS packet according to SPEC.
 137 If TCP-P, the first two bytes of the package with be the length field."
 138   (with-temp-buffer
 139     (dns-write-bytes (dns-get 'id spec) 2)
 140     (dns-write-bytes
 141      (logior
 142       (lsh (if (dns-get 'response-p spec) 1 0) -7)
 143       (lsh
 144        (cond
 145         ((eq (dns-get 'opcode spec) 'query) 0)
 146         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
 147         ((eq (dns-get 'opcode spec) 'status) 2)
 148         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
 149        -3)
 150       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
 151       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
 152       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
 153     (dns-write-bytes
 154      (cond
 155       ((eq (dns-get 'response-code spec) 'no-error) 0)
 156       ((eq (dns-get 'response-code spec) 'format-error) 1)
 157       ((eq (dns-get 'response-code spec) 'server-failure) 2)
 158       ((eq (dns-get 'response-code spec) 'name-error) 3)
 159       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
 160       ((eq (dns-get 'response-code spec) 'refused) 5)
 161       (t 0)))
 162     (dns-write-bytes (length (dns-get 'queries spec)) 2)
 163     (dns-write-bytes (length (dns-get 'answers spec)) 2)
 164     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
 165     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
 166     (dolist (query (dns-get 'queries spec))
 167       (dns-write-name (car query))
 168       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
 169                                    dns-query-types)) 2)
 170       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
 171                                    dns-classes)) 2))
 172     (dolist (slot '(answers authorities additionals))
 173       (dolist (resource (dns-get slot spec))
 174         (dns-write-name (car resource))
 175       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
 176                        2)
 177       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
 178                        2)
 179       (dns-write-bytes (dns-get 'ttl resource) 4)
 180       (dns-write-bytes (length (dns-get 'data resource)) 2)
 181       (insert (dns-get 'data resource))))
 182     (when tcp-p
 183       (goto-char (point-min))
 184       (dns-write-bytes (buffer-size) 2))
 185     (buffer-string)))
 186
 187 (defun dns-read (packet)
 188   (mm-with-unibyte-buffer
 189     (let ((spec nil)
 190           queries answers authorities additionals)
 191       (insert packet)
 192       (goto-char (point-min))
 193       (push (list 'id (dns-read-bytes 2)) spec)
 194       (let ((byte (dns-read-bytes 1)))
 195         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
 196               spec)
 197         (let ((opcode (logand byte (lsh 7 3))))
 198           (push (list 'opcode
 199                       (cond ((eq opcode 0) 'query)
 200                             ((eq opcode 1) 'inverse-query)
 201                             ((eq opcode 2) 'status)))
 202                 spec))
 203         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
 204                                          nil t)) spec)
 205         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
 206               spec)
 207         (push (list 'recursion-desired-p
 208                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
 209       (let ((rc (logand (dns-read-bytes 1) 15)))
 210         (push (list 'response-code
 211                     (cond
 212                      ((eq rc 0) 'no-error)
 213                      ((eq rc 1) 'format-error)
 214                      ((eq rc 2) 'server-failure)
 215                      ((eq rc 3) 'name-error)
 216                      ((eq rc 4) 'not-implemented)
 217                      ((eq rc 5) 'refused)))
 218               spec))
 219       (setq queries (dns-read-bytes 2))
 220       (setq answers (dns-read-bytes 2))
 221       (setq authorities (dns-read-bytes 2))
 222       (setq additionals (dns-read-bytes 2))
 223       (let ((qs nil))
 224         (dotimes (i queries)
 225           (push (list (dns-read-name)
 226                       (list 'type (dns-inverse-get (dns-read-bytes 2)
 227                                                    dns-query-types))
 228                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 229                                                     dns-classes)))
 230                 qs))
 231         (push (list 'queries qs) spec))
 232     (dolist (slot '(answers authorities additionals))
 233       (let ((qs nil)
 234             type)
 235         (dotimes (i (symbol-value slot))
 236           (push (list (dns-read-name)
 237                       (list 'type
 238                             (setq type (dns-inverse-get (dns-read-bytes 2)
 239                                                         dns-query-types)))
 240                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 241                                                     dns-classes))
 242                       (list 'ttl (dns-read-bytes 4))
 243                       (let ((length (dns-read-bytes 2)))
 244                         (list 'data
 245                               (dns-read-type
 246                                (buffer-substring
 247                                 (point)
 248                                 (progn (forward-char length) (point)))
 249                                type))))
 250                 qs))
 251         (push (list slot qs) spec)))
 252     (nreverse spec))))
 253
 254 (defun dns-read-type (string type)
 255   (let ((buffer (current-buffer))
 256         (point (point)))
 257     (prog1
 258         (mm-with-unibyte-buffer
 259           (insert string)
 260           (goto-char (point-min))
 261           (cond
 262            ((eq type 'A)
 263             (let ((bytes nil))
 264               (dotimes (i 4)
 265                 (push (dns-read-bytes 1) bytes))
 266               (mapconcat 'number-to-string (nreverse bytes) ".")))
 267            ((eq type 'NS)
 268             (dns-read-string-name string buffer))
 269            ((eq type 'CNAME)
 270             (dns-read-string-name string buffer))
 271            (t string)))
 272       (goto-char point))))
 273
 274 (defun dns-parse-resolv-conf ()
 275   (when (file-exists-p "/etc/resolv.conf")
 276     (with-temp-buffer
 277       (insert-file-contents "/etc/resolv.conf")
 278       (goto-char (point-min))
 279       (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 280         (push (match-string 1) dns-servers))
 281       (setq dns-servers (nreverse dns-servers)))))
 282
 283 ;;; Interface functions.
 284
 285 (autoload 'gnus-xmacs-open-network-stream "gnus-xmas" nil nil 'macro)
 286
 287 (defmacro dns-make-network-process (server)
 288   (if (featurep 'xemacs)
 289       `(let ((coding-system-for-read 'binary)
 290              (coding-system-for-write 'binary))
 291          (gnus-xmas-open-network-stream "dns" (current-buffer)
 292                                         ,server "domain" 'udp))
 293     `(let ((server ,server)
 294            (coding-system-for-read 'binary)
 295            (coding-system-for-write 'binary))
 296        (if (fboundp 'make-network-process)
 297            (make-network-process
 298             :name "dns"
 299             :coding 'binary
 300             :buffer (current-buffer)
 301             :host server
 302             :service "domain"
 303             :type 'datagram)
 304          ;; Older versions of Emacs doesn't have
 305          ;; `make-network-process', so we fall back on opening a TCP
 306          ;; connection to the DNS server.
 307          (open-network-stream "dns" (current-buffer) server "domain")))))
 308
 309 (defun query-dns (name &optional type fullp)
 310   "Query a DNS server for NAME of TYPE.
 311 If FULLP, return the entire record returned."
 312   (setq type (or type 'A))
 313   (unless dns-servers
 314     (dns-parse-resolv-conf)
 315     (unless dns-servers
 316       (error "No DNS server configuration found")))
 317   (mm-with-unibyte-buffer
 318     (let ((process (condition-case ()
 319                        (dns-make-network-process (car dns-servers))
 320                      (error
 321                       (message "dns: Got an error while trying to talk to %s"
 322                                (car dns-servers))
 323                       nil)))
 324           (tcp-p (and (not (fboundp 'make-network-process))
 325                       (not (featurep 'xemacs))))
 326           (step 100)
 327           (times (* dns-timeout 1000))
 328           (id (random 65000)))
 329       (when process
 330         (process-send-string
 331          process
 332          (dns-write `((id ,id)
 333                       (opcode query)
 334                       (queries ((,name (type ,type))))
 335                       (recursion-desired-p t))
 336                     tcp-p))
 337         (while (and (zerop (buffer-size))
 338                     (> times 0))
 339           (accept-process-output process 0 step)
 340           (decf times step))
 341         (ignore-errors
 342           (delete-process process))
 343         (when tcp-p
 344           (goto-char (point-min))
 345           (delete-region (point) (+ (point) 2)))
 346         (unless (zerop (buffer-size))
 347           (let ((result (dns-read (buffer-string))))
 348             (if fullp
 349                 result
 350               (let ((answer (car (dns-get 'answers result))))
 351                 (when (eq type (dns-get 'type answer))
 352                   (dns-get 'data answer))))))))))
 353
 354 (provide 'dns)
 355
 356 ;;; dns.el ends here