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     (PTR 12)
  54     (HINFO 13)
  55     (MINFO 14)
  56     (MX 15)
  57     (TXT 16)
  58     (AAAA 28) ; RFC3596
  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-int32 ()
 256   ;; Full 32 bit Integers can't be handled by Emacs.  If we use
 257   ;; floats, it works.
 258   (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
 259                     (dns-read-bytes 3))))
 260
 261 (defun dns-read-type (string type)
 262   (let ((buffer (current-buffer))
 263         (point (point)))
 264     (prog1
 265         (mm-with-unibyte-buffer
 266           (insert string)
 267           (goto-char (point-min))
 268           (cond
 269            ((eq type 'A)
 270             (let ((bytes nil))
 271               (dotimes (i 4)
 272                 (push (dns-read-bytes 1) bytes))
 273               (mapconcat 'number-to-string (nreverse bytes) ".")))
 274            ((eq type 'AAAA)
 275             (let (hextets)
 276               (dotimes (i 8)
 277                 (push (dns-read-bytes 2) hextets))
 278               (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":")))
 279            ((eq type 'SOA)
 280             (list (list 'mname (dns-read-name buffer))
 281                   (list 'rname (dns-read-name buffer))
 282                   (list 'serial (dns-read-int32))
 283                   (list 'refresh (dns-read-int32))
 284                   (list 'retry (dns-read-int32))
 285                   (list 'expire (dns-read-int32))
 286                   (list 'minimum (dns-read-int32))))
 287            ((eq type 'MX)
 288             (cons (dns-read-bytes 2) (dns-read-name buffer)))
 289            ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
 290             (dns-read-string-name string buffer))
 291            (t string)))
 292       (goto-char point))))
 293
 294 (defun dns-parse-resolv-conf ()
 295   (when (file-exists-p "/etc/resolv.conf")
 296     (with-temp-buffer
 297       (insert-file-contents "/etc/resolv.conf")
 298       (goto-char (point-min))
 299       (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 300         (push (match-string 1) dns-servers))
 301       (setq dns-servers (nreverse dns-servers)))))
 302
 303 ;;; Interface functions.
 304 (defmacro dns-make-network-process (server)
 305   (if (featurep 'xemacs)
 306       `(let ((coding-system-for-read 'binary)
 307              (coding-system-for-write 'binary))
 308          (open-network-stream "dns" (current-buffer)
 309                               ,server "domain" 'udp))
 310     `(let ((server ,server)
 311            (coding-system-for-read 'binary)
 312            (coding-system-for-write 'binary))
 313        (if (fboundp 'make-network-process)
 314            (make-network-process
 315             :name "dns"
 316             :coding 'binary
 317             :buffer (current-buffer)
 318             :host server
 319             :service "domain"
 320             :type 'datagram)
 321          ;; Older versions of Emacs doesn't have
 322          ;; `make-network-process', so we fall back on opening a TCP
 323          ;; connection to the DNS server.
 324          (open-network-stream "dns" (current-buffer) server "domain")))))
 325
 326 (defun query-dns (name &optional type fullp)
 327   "Query a DNS server for NAME of TYPE.
 328 If FULLP, return the entire record returned."
 329   (setq type (or type 'A))
 330   (unless dns-servers
 331     (dns-parse-resolv-conf))
 332
 333   (if (not dns-servers)
 334       (message "No DNS server configuration found")
 335     (mm-with-unibyte-buffer
 336       (let ((process (condition-case ()
 337                          (dns-make-network-process (car dns-servers))
 338                        (error
 339                         (message "dns: Got an error while trying to talk to %s"
 340                                  (car dns-servers))
 341                         nil)))
 342             (tcp-p (and (not (fboundp 'make-network-process))
 343                         (not (featurep 'xemacs))))
 344             (step 100)
 345             (times (* dns-timeout 1000))
 346             (id (random 65000)))
 347         (when process
 348           (process-send-string
 349            process
 350            (dns-write `((id ,id)
 351                         (opcode query)
 352                         (queries ((,name (type ,type))))
 353                         (recursion-desired-p t))
 354                       tcp-p))
 355           (while (and (zerop (buffer-size))
 356                       (> times 0))
 357             (accept-process-output process 0 step)
 358             (decf times step))
 359           (ignore-errors
 360             (delete-process process))
 361           (when tcp-p
 362             (goto-char (point-min))
 363             (delete-region (point) (+ (point) 2)))
 364           (unless (zerop (buffer-size))
 365             (let ((result (dns-read (buffer-string))))
 366               (if fullp
 367                   result
 368                 (let ((answer (car (dns-get 'answers result))))
 369                   (when (eq type (dns-get 'type answer))
 370                     (dns-get 'data answer)))))))))))
 371
 372 (provide 'dns)
 373
 374 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
 375 ;;; dns.el ends here