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

   1 ;;; dns.el --- Domain Name Service lookups
   2 ;; Copyright (C) 2002, 2003, 2004 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     (SRV 33) ; RFC2782
  60     (AXFR 252)
  61     (MAILB 253)
  62     (MAILA 254)
  63     (* 255))
  64   "Names of query types and their values.")
  65
  66 (defvar dns-classes
  67   '((IN 1)
  68     (CS 2)
  69     (CH 3)
  70     (HS 4))
  71   "Classes of queries.")
  72
  73 (defun dns-write-bytes (value &optional length)
  74   (let (bytes)
  75     (dotimes (i (or length 1))
  76       (push (% value 256) bytes)
  77       (setq value (/ value 256)))
  78     (dolist (byte bytes)
  79       (insert byte))))
  80
  81 (defun dns-read-bytes (length)
  82   (let ((value 0))
  83     (dotimes (i length)
  84       (setq value (logior (* value 256) (following-char)))
  85       (forward-char 1))
  86     value))
  87
  88 (defun dns-get (type spec)
  89   (cadr (assq type spec)))
  90
  91 (defun dns-inverse-get (value spec)
  92   (let ((found nil))
  93     (while (and (not found)
  94                 spec)
  95       (if (eq value (cadr (car spec)))
  96           (setq found (caar spec))
  97         (pop spec)))
  98     found))
  99
 100 (defun dns-write-name (name)
 101   (dolist (part (split-string name "\\."))
 102     (dns-write-bytes (length part))
 103     (insert part))
 104   (dns-write-bytes 0))
 105
 106 (defun dns-read-string-name (string buffer)
 107   (mm-with-unibyte-buffer
 108     (insert string)
 109     (goto-char (point-min))
 110     (dns-read-name buffer)))
 111
 112 (defun dns-read-name (&optional buffer)
 113   (let ((ended nil)
 114         (name nil)
 115         length)
 116     (while (not ended)
 117       (setq length (dns-read-bytes 1))
 118       (if (= 192 (logand length (lsh 3 6)))
 119           (let ((offset (+ (* (logand 63 length) 256)
 120                            (dns-read-bytes 1))))
 121             (save-excursion
 122               (when buffer
 123                 (set-buffer buffer))
 124               (goto-char (1+ offset))
 125               (setq ended (dns-read-name buffer))))
 126         (if (zerop length)
 127             (setq ended t)
 128           (push (buffer-substring (point)
 129                                   (progn (forward-char length) (point)))
 130                 name))))
 131     (if (stringp ended)
 132         (if (null name)
 133             ended
 134           (concat (mapconcat 'identity (nreverse name) ".") "." ended))
 135       (mapconcat 'identity (nreverse name) "."))))
 136
 137 (defun dns-write (spec &optional tcp-p)
 138   "Write a DNS packet according to SPEC.
 139 If TCP-P, the first two bytes of the package with be the length field."
 140   (with-temp-buffer
 141     (dns-write-bytes (dns-get 'id spec) 2)
 142     (dns-write-bytes
 143      (logior
 144       (lsh (if (dns-get 'response-p spec) 1 0) -7)
 145       (lsh
 146        (cond
 147         ((eq (dns-get 'opcode spec) 'query) 0)
 148         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
 149         ((eq (dns-get 'opcode spec) 'status) 2)
 150         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
 151        -3)
 152       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
 153       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
 154       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
 155     (dns-write-bytes
 156      (cond
 157       ((eq (dns-get 'response-code spec) 'no-error) 0)
 158       ((eq (dns-get 'response-code spec) 'format-error) 1)
 159       ((eq (dns-get 'response-code spec) 'server-failure) 2)
 160       ((eq (dns-get 'response-code spec) 'name-error) 3)
 161       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
 162       ((eq (dns-get 'response-code spec) 'refused) 5)
 163       (t 0)))
 164     (dns-write-bytes (length (dns-get 'queries spec)) 2)
 165     (dns-write-bytes (length (dns-get 'answers spec)) 2)
 166     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
 167     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
 168     (dolist (query (dns-get 'queries spec))
 169       (dns-write-name (car query))
 170       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
 171                                    dns-query-types)) 2)
 172       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
 173                                    dns-classes)) 2))
 174     (dolist (slot '(answers authorities additionals))
 175       (dolist (resource (dns-get slot spec))
 176         (dns-write-name (car resource))
 177       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
 178                        2)
 179       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
 180                        2)
 181       (dns-write-bytes (dns-get 'ttl resource) 4)
 182       (dns-write-bytes (length (dns-get 'data resource)) 2)
 183       (insert (dns-get 'data resource))))
 184     (when tcp-p
 185       (goto-char (point-min))
 186       (dns-write-bytes (buffer-size) 2))
 187     (buffer-string)))
 188
 189 (defun dns-read (packet)
 190   (mm-with-unibyte-buffer
 191     (let ((spec nil)
 192           queries answers authorities additionals)
 193       (insert packet)
 194       (goto-char (point-min))
 195       (push (list 'id (dns-read-bytes 2)) spec)
 196       (let ((byte (dns-read-bytes 1)))
 197         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
 198               spec)
 199         (let ((opcode (logand byte (lsh 7 3))))
 200           (push (list 'opcode
 201                       (cond ((eq opcode 0) 'query)
 202                             ((eq opcode 1) 'inverse-query)
 203                             ((eq opcode 2) 'status)))
 204                 spec))
 205         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
 206                                          nil t)) spec)
 207         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
 208               spec)
 209         (push (list 'recursion-desired-p
 210                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
 211       (let ((rc (logand (dns-read-bytes 1) 15)))
 212         (push (list 'response-code
 213                     (cond
 214                      ((eq rc 0) 'no-error)
 215                      ((eq rc 1) 'format-error)
 216                      ((eq rc 2) 'server-failure)
 217                      ((eq rc 3) 'name-error)
 218                      ((eq rc 4) 'not-implemented)
 219                      ((eq rc 5) 'refused)))
 220               spec))
 221       (setq queries (dns-read-bytes 2))
 222       (setq answers (dns-read-bytes 2))
 223       (setq authorities (dns-read-bytes 2))
 224       (setq additionals (dns-read-bytes 2))
 225       (let ((qs nil))
 226         (dotimes (i queries)
 227           (push (list (dns-read-name)
 228                       (list 'type (dns-inverse-get (dns-read-bytes 2)
 229                                                    dns-query-types))
 230                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 231                                                     dns-classes)))
 232                 qs))
 233         (push (list 'queries qs) spec))
 234     (dolist (slot '(answers authorities additionals))
 235       (let ((qs nil)
 236             type)
 237         (dotimes (i (symbol-value slot))
 238           (push (list (dns-read-name)
 239                       (list 'type
 240                             (setq type (dns-inverse-get (dns-read-bytes 2)
 241                                                         dns-query-types)))
 242                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 243                                                     dns-classes))
 244                       (list 'ttl (dns-read-bytes 4))
 245                       (let ((length (dns-read-bytes 2)))
 246                         (list 'data
 247                               (dns-read-type
 248                                (buffer-substring
 249                                 (point)
 250                                 (progn (forward-char length) (point)))
 251                                type))))
 252                 qs))
 253         (push (list slot qs) spec)))
 254     (nreverse spec))))
 255
 256 (defun dns-read-int32 ()
 257   ;; Full 32 bit Integers can't be handled by Emacs.  If we use
 258   ;; floats, it works.
 259   (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
 260                     (dns-read-bytes 3))))
 261
 262 (defun dns-read-type (string type)
 263   (let ((buffer (current-buffer))
 264         (point (point)))
 265     (prog1
 266         (mm-with-unibyte-buffer
 267           (insert string)
 268           (goto-char (point-min))
 269           (cond
 270            ((eq type 'A)
 271             (let ((bytes nil))
 272               (dotimes (i 4)
 273                 (push (dns-read-bytes 1) bytes))
 274               (mapconcat 'number-to-string (nreverse bytes) ".")))
 275            ((eq type 'AAAA)
 276             (let (hextets)
 277               (dotimes (i 8)
 278                 (push (dns-read-bytes 2) hextets))
 279               (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":")))
 280            ((eq type 'SOA)
 281             (list (list 'mname (dns-read-name buffer))
 282                   (list 'rname (dns-read-name buffer))
 283                   (list 'serial (dns-read-int32))
 284                   (list 'refresh (dns-read-int32))
 285                   (list 'retry (dns-read-int32))
 286                   (list 'expire (dns-read-int32))
 287                   (list 'minimum (dns-read-int32))))
 288            ((eq type 'SRV)
 289             (list (list 'priority (dns-read-bytes 2))
 290                   (list 'weight (dns-read-bytes 2))
 291                   (list 'port (dns-read-bytes 2))
 292                   (list 'target (dns-read-name buffer))))
 293            ((eq type 'MX)
 294             (cons (dns-read-bytes 2) (dns-read-name buffer)))
 295            ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
 296             (dns-read-string-name string buffer))
 297            (t string)))
 298       (goto-char point))))
 299
 300 (defun dns-parse-resolv-conf ()
 301   (when (file-exists-p "/etc/resolv.conf")
 302     (with-temp-buffer
 303       (insert-file-contents "/etc/resolv.conf")
 304       (goto-char (point-min))
 305       (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 306         (push (match-string 1) dns-servers))
 307       (setq dns-servers (nreverse dns-servers)))))
 308
 309 ;;; Interface functions.
 310 (defmacro dns-make-network-process (server)
 311   (if (featurep 'xemacs)
 312       `(let ((coding-system-for-read 'binary)
 313              (coding-system-for-write 'binary))
 314          (open-network-stream "dns" (current-buffer)
 315                               ,server "domain" 'udp))
 316     `(let ((server ,server)
 317            (coding-system-for-read 'binary)
 318            (coding-system-for-write 'binary))
 319        (if (fboundp 'make-network-process)
 320            (make-network-process
 321             :name "dns"
 322             :coding 'binary
 323             :buffer (current-buffer)
 324             :host server
 325             :service "domain"
 326             :type 'datagram)
 327          ;; Older versions of Emacs doesn't have
 328          ;; `make-network-process', so we fall back on opening a TCP
 329          ;; connection to the DNS server.
 330          (open-network-stream "dns" (current-buffer) server "domain")))))
 331
 332 (defun query-dns (name &optional type fullp)
 333   "Query a DNS server for NAME of TYPE.
 334 If FULLP, return the entire record returned."
 335   (setq type (or type 'A))
 336   (unless dns-servers
 337     (dns-parse-resolv-conf))
 338
 339   (if (not dns-servers)
 340       (message "No DNS server configuration found")
 341     (mm-with-unibyte-buffer
 342       (let ((process (condition-case ()
 343                          (dns-make-network-process (car dns-servers))
 344                        (error
 345                         (message "dns: Got an error while trying to talk to %s"
 346                                  (car dns-servers))
 347                         nil)))
 348             (tcp-p (and (not (fboundp 'make-network-process))
 349                         (not (featurep 'xemacs))))
 350             (step 100)
 351             (times (* dns-timeout 1000))
 352             (id (random 65000)))
 353         (when process
 354           (process-send-string
 355            process
 356            (dns-write `((id ,id)
 357                         (opcode query)
 358                         (queries ((,name (type ,type))))
 359                         (recursion-desired-p t))
 360                       tcp-p))
 361           (while (and (zerop (buffer-size))
 362                       (> times 0))
 363             (accept-process-output process 0 step)
 364             (decf times step))
 365           (ignore-errors
 366             (delete-process process))
 367           (when tcp-p
 368             (goto-char (point-min))
 369             (delete-region (point) (+ (point) 2)))
 370           (unless (zerop (buffer-size))
 371             (let ((result (dns-read (buffer-string))))
 372               (if fullp
 373                   result
 374                 (let ((answer (car (dns-get 'answers result))))
 375                   (when (eq type (dns-get 'type answer))
 376                     (dns-get 'data answer)))))))))))
 377
 378 (provide 'dns)
 379
 380 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
 381 ;;; dns.el ends here