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

   1 ;;; dns.el --- Domain Name Service lookups
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: network
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (defvar dns-timeout 5
  31   "How many seconds to wait when doing DNS queries.")
  32
  33 (defvar dns-servers nil
  34   "Which DNS servers to query.
  35 If nil, /etc/resolv.conf will be consulted.")
  36
  37 ;;; Internal code:
  38
  39 (defvar dns-query-types
  40   '((A 1)
  41     (NS 2)
  42     (MD 3)
  43     (MF 4)
  44     (CNAME 5)
  45     (SOA 6)
  46     (MB 7)
  47     (MG 8)
  48     (MR 9)
  49     (NULL 10)
  50     (WKS 11)
  51     (PTR 12)
  52     (HINFO 13)
  53     (MINFO 14)
  54     (MX 15)
  55     (TXT 16)
  56     (AAAA 28) ; RFC3596
  57     (SRV 33) ; RFC2782
  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   (let (default-enable-multibyte-characters)
 106     (with-temp-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   (let (default-enable-multibyte-characters)
 190     (with-temp-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         (let (default-enable-multibyte-characters)
 267           (with-temp-buffer
 268             (insert string)
 269             (goto-char (point-min))
 270             (cond
 271              ((eq type 'A)
 272               (let ((bytes nil))
 273                 (dotimes (i 4)
 274                   (push (dns-read-bytes 1) bytes))
 275                 (mapconcat 'number-to-string (nreverse bytes) ".")))
 276              ((eq type 'AAAA)
 277               (let (hextets)
 278                 (dotimes (i 8)
 279                   (push (dns-read-bytes 2) hextets))
 280                 (mapconcat (lambda (n) (format "%x" n))
 281                            (nreverse hextets) ":")))
 282              ((eq type 'SOA)
 283               (list (list 'mname (dns-read-name buffer))
 284                     (list 'rname (dns-read-name buffer))
 285                     (list 'serial (dns-read-int32))
 286                     (list 'refresh (dns-read-int32))
 287                     (list 'retry (dns-read-int32))
 288                     (list 'expire (dns-read-int32))
 289                     (list 'minimum (dns-read-int32))))
 290              ((eq type 'SRV)
 291               (list (list 'priority (dns-read-bytes 2))
 292                     (list 'weight (dns-read-bytes 2))
 293                     (list 'port (dns-read-bytes 2))
 294                     (list 'target (dns-read-name buffer))))
 295              ((eq type 'MX)
 296               (cons (dns-read-bytes 2) (dns-read-name buffer)))
 297              ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
 298               (dns-read-string-name string buffer))
 299              (t string))))
 300       (goto-char point))))
 301
 302 (defun dns-parse-resolv-conf ()
 303   (when (file-exists-p "/etc/resolv.conf")
 304     (with-temp-buffer
 305       (insert-file-contents "/etc/resolv.conf")
 306       (goto-char (point-min))
 307       (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 308         (push (match-string 1) dns-servers))
 309       (setq dns-servers (nreverse dns-servers)))))
 310
 311 (defun dns-read-txt (string)
 312   (if (> (length string) 1)
 313       (substring string 1)
 314     string))
 315
 316 (defun dns-get-txt-answer (answers)
 317   (let ((result "")
 318         (do-next nil))
 319     (dolist (answer answers)
 320       (dolist (elem answer)
 321         (when (consp elem)
 322           (cond
 323            ((eq (car elem) 'type)
 324             (setq do-next (eq (cadr elem) 'TXT)))
 325            ((eq (car elem) 'data)
 326             (when do-next
 327               (setq result (concat result (dns-read-txt (cadr elem))))))))))
 328     result))
 329
 330 ;;; Interface functions.
 331 (defmacro dns-make-network-process (server)
 332   (if (featurep 'xemacs)
 333       `(let ((coding-system-for-read 'binary)
 334              (coding-system-for-write 'binary))
 335          (open-network-stream "dns" (current-buffer)
 336                               ,server "domain" 'udp))
 337     `(let ((server ,server)
 338            (coding-system-for-read 'binary)
 339            (coding-system-for-write 'binary))
 340        (if (fboundp 'make-network-process)
 341            (make-network-process
 342             :name "dns"
 343             :coding 'binary
 344             :buffer (current-buffer)
 345             :host server
 346             :service "domain"
 347             :type 'datagram)
 348          ;; Older versions of Emacs doesn't have
 349          ;; `make-network-process', so we fall back on opening a TCP
 350          ;; connection to the DNS server.
 351          (open-network-stream "dns" (current-buffer) server "domain")))))
 352
 353 (defvar dns-cache (make-vector 4096 0))
 354
 355 (defun query-dns-cached (name &optional type fullp reversep)
 356   (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
 357          (sym (intern-soft key dns-cache)))
 358     (if (and sym
 359              (boundp sym))
 360         (symbol-value sym)
 361       (let ((result (query-dns name type fullp reversep)))
 362         (set (intern key dns-cache) result)
 363         result))))
 364
 365 (defun query-dns (name &optional type fullp reversep)
 366   "Query a DNS server for NAME of TYPE.
 367 If FULLP, return the entire record returned.
 368 If REVERSEP, look up an IP address."
 369   (setq type (or type 'A))
 370   (unless dns-servers
 371     (dns-parse-resolv-conf))
 372
 373   (when reversep
 374     (setq name (concat
 375                 (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
 376                 ".in-addr.arpa")
 377           type 'PTR))
 378
 379   (if (not dns-servers)
 380       (message "No DNS server configuration found")
 381     (let (default-enable-multibyte-characters)
 382       (with-temp-buffer
 383         (let ((process (condition-case ()
 384                            (dns-make-network-process (car dns-servers))
 385                          (error
 386                           (message
 387                            "dns: Got an error while trying to talk to %s"
 388                            (car dns-servers))
 389                           nil)))
 390               (tcp-p (and (not (fboundp 'make-network-process))
 391                           (not (featurep 'xemacs))))
 392               (step 100)
 393               (times (* dns-timeout 1000))
 394               (id (random 65000)))
 395           (when process
 396             (process-send-string
 397              process
 398              (dns-write `((id ,id)
 399                           (opcode query)
 400                           (queries ((,name (type ,type))))
 401                           (recursion-desired-p t))
 402                         tcp-p))
 403             (while (and (zerop (buffer-size))
 404                         (> times 0))
 405               (sit-for (/ step 1000.0))
 406               (accept-process-output process 0 step)
 407               (setq times (- times step)))
 408             (condition-case nil
 409                 (delete-process process)
 410               (error nil))
 411             (when (and tcp-p
 412                        (>= (buffer-size) 2))
 413               (goto-char (point-min))
 414               (delete-region (point) (+ (point) 2)))
 415             (when (and (>= (buffer-size) 2)
 416                        ;; We had a time-out.
 417                        (> times 0))
 418               (let ((result (dns-read (buffer-string))))
 419                 (if fullp
 420                     result
 421                   (let ((answer (car (dns-get 'answers result))))
 422                     (when (eq type (dns-get 'type answer))
 423                       (if (eq type 'TXT)
 424                           (dns-get-txt-answer (dns-get 'answers result))
 425                         (dns-get 'data answer)))))))))))))
 426
 427 (provide 'dns)
 428
 429 ;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a
 430 ;;; dns.el ends here