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

   1 ;;; dns.el --- Domain Name Service lookups
   2
   3 ;; Copyright (C) 2002-2011  Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: network comm
   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 3 of the License, or
  13 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (defvar dns-timeout 5
  28   "How many seconds to wait when doing DNS queries.")
  29
  30 (defvar dns-servers nil
  31   "List of DNS servers to query.
  32 If nil, /etc/resolv.conf and nslookup will be consulted.")
  33
  34 ;;; Internal code:
  35
  36 (defvar dns-query-types
  37   '((A 1)
  38     (NS 2)
  39     (MD 3)
  40     (MF 4)
  41     (CNAME 5)
  42     (SOA 6)
  43     (MB 7)
  44     (MG 8)
  45     (MR 9)
  46     (NULL 10)
  47     (WKS 11)
  48     (PTR 12)
  49     (HINFO 13)
  50     (MINFO 14)
  51     (MX 15)
  52     (TXT 16)
  53     (AAAA 28) ; RFC3596
  54     (SRV 33) ; RFC2782
  55     (AXFR 252)
  56     (MAILB 253)
  57     (MAILA 254)
  58     (* 255))
  59   "Names of query types and their values.")
  60
  61 (defvar dns-classes
  62   '((IN 1)
  63     (CS 2)
  64     (CH 3)
  65     (HS 4))
  66   "Classes of queries.")
  67
  68 (defun dns-write-bytes (value &optional length)
  69   (let (bytes)
  70     (dotimes (i (or length 1))
  71       (push (% value 256) bytes)
  72       (setq value (/ value 256)))
  73     (dolist (byte bytes)
  74       (insert byte))))
  75
  76 (defun dns-read-bytes (length)
  77   (let ((value 0))
  78     (dotimes (i length)
  79       (setq value (logior (* value 256) (following-char)))
  80       (forward-char 1))
  81     value))
  82
  83 (defun dns-get (type spec)
  84   (cadr (assq type spec)))
  85
  86 (defun dns-inverse-get (value spec)
  87   (let ((found nil))
  88     (while (and (not found)
  89                 spec)
  90       (if (eq value (cadr (car spec)))
  91           (setq found (caar spec))
  92         (pop spec)))
  93     found))
  94
  95 (defun dns-write-name (name)
  96   (dolist (part (split-string name "\\."))
  97     (dns-write-bytes (length part))
  98     (insert part))
  99   (dns-write-bytes 0))
 100
 101 (defun dns-read-string-name (string buffer)
 102   (with-temp-buffer
 103     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 104     (insert string)
 105     (goto-char (point-min))
 106     (dns-read-name buffer)))
 107
 108 (defun dns-read-name (&optional buffer)
 109   (let ((ended nil)
 110         (name nil)
 111         length)
 112     (while (not ended)
 113       (setq length (dns-read-bytes 1))
 114       (if (= 192 (logand length (lsh 3 6)))
 115           (let ((offset (+ (* (logand 63 length) 256)
 116                            (dns-read-bytes 1))))
 117             (save-excursion
 118               (when buffer
 119                 (set-buffer buffer))
 120               (goto-char (1+ offset))
 121               (setq ended (dns-read-name buffer))))
 122         (if (zerop length)
 123             (setq ended t)
 124           (push (buffer-substring (point)
 125                                   (progn (forward-char length) (point)))
 126                 name))))
 127     (if (stringp ended)
 128         (if (null name)
 129             ended
 130           (concat (mapconcat 'identity (nreverse name) ".") "." ended))
 131       (mapconcat 'identity (nreverse name) "."))))
 132
 133 (defun dns-write (spec &optional tcp-p)
 134   "Write a DNS packet according to SPEC.
 135 If TCP-P, the first two bytes of the package with be the length field."
 136   (with-temp-buffer
 137     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 138     (dns-write-bytes (dns-get 'id spec) 2)
 139     (dns-write-bytes
 140      (logior
 141       (lsh (if (dns-get 'response-p spec) 1 0) -7)
 142       (lsh
 143        (cond
 144         ((eq (dns-get 'opcode spec) 'query) 0)
 145         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
 146         ((eq (dns-get 'opcode spec) 'status) 2)
 147         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
 148        -3)
 149       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
 150       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
 151       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
 152     (dns-write-bytes
 153      (cond
 154       ((eq (dns-get 'response-code spec) 'no-error) 0)
 155       ((eq (dns-get 'response-code spec) 'format-error) 1)
 156       ((eq (dns-get 'response-code spec) 'server-failure) 2)
 157       ((eq (dns-get 'response-code spec) 'name-error) 3)
 158       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
 159       ((eq (dns-get 'response-code spec) 'refused) 5)
 160       (t 0)))
 161     (dns-write-bytes (length (dns-get 'queries spec)) 2)
 162     (dns-write-bytes (length (dns-get 'answers spec)) 2)
 163     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
 164     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
 165     (dolist (query (dns-get 'queries spec))
 166       (dns-write-name (car query))
 167       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
 168                                    dns-query-types)) 2)
 169       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
 170                                    dns-classes)) 2))
 171     (dolist (slot '(answers authorities additionals))
 172       (dolist (resource (dns-get slot spec))
 173         (dns-write-name (car resource))
 174       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
 175                        2)
 176       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
 177                        2)
 178       (dns-write-bytes (dns-get 'ttl resource) 4)
 179       (dns-write-bytes (length (dns-get 'data resource)) 2)
 180       (insert (dns-get 'data resource))))
 181     (when tcp-p
 182       (goto-char (point-min))
 183       (dns-write-bytes (buffer-size) 2))
 184     (buffer-string)))
 185
 186 (defun dns-read (packet)
 187   (with-temp-buffer
 188     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 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-int32 ()
 255   ;; Full 32 bit Integers can't be handled by 32-bit Emacsen.  If we
 256   ;; use floats, it works.
 257   (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
 258                     (dns-read-bytes 3))))
 259
 260 (defun dns-read-type (string type)
 261   (let ((buffer (current-buffer))
 262         (point (point)))
 263     (prog1
 264         (with-temp-buffer
 265           (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 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))
 279                          (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-set-servers ()
 301   "Set `dns-servers' to a list of DNS servers or nil if none are found.
 302 Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
 303   (or (when (file-exists-p "/etc/resolv.conf")
 304         (setq dns-servers nil)
 305         (with-temp-buffer
 306           (insert-file-contents "/etc/resolv.conf")
 307           (goto-char (point-min))
 308           (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 309             (push (match-string 1) dns-servers))
 310           (setq dns-servers (nreverse dns-servers))))
 311       (when (executable-find "nslookup")
 312         (with-temp-buffer
 313           (call-process "nslookup" nil t nil "localhost")
 314           (goto-char (point-min))
 315           (re-search-forward
 316            "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
 317           (setq dns-servers (list (match-string 1)))))))
 318
 319 (defun dns-read-txt (string)
 320   (if (> (length string) 1)
 321       (substring string 1)
 322     string))
 323
 324 (defun dns-get-txt-answer (answers)
 325   (let ((result "")
 326         (do-next nil))
 327     (dolist (answer answers)
 328       (dolist (elem answer)
 329         (when (consp elem)
 330           (cond
 331            ((eq (car elem) 'type)
 332             (setq do-next (eq (cadr elem) 'TXT)))
 333            ((eq (car elem) 'data)
 334             (when do-next
 335               (setq result (concat result (dns-read-txt (cadr elem))))))))))
 336     result))
 337
 338 ;;; Interface functions.
 339 (defmacro dns-make-network-process (server)
 340   (if (featurep 'xemacs)
 341       `(let ((coding-system-for-read 'binary)
 342              (coding-system-for-write 'binary))
 343          (open-network-stream "dns" (current-buffer)
 344                               ,server "domain" 'udp))
 345     `(let ((server ,server)
 346            (coding-system-for-read 'binary)
 347            (coding-system-for-write 'binary))
 348        (if (fboundp 'make-network-process)
 349            (make-network-process
 350             :name "dns"
 351             :coding 'binary
 352             :buffer (current-buffer)
 353             :host server
 354             :service "domain"
 355             :type 'datagram)
 356          ;; Older versions of Emacs doesn't have
 357          ;; `make-network-process', so we fall back on opening a TCP
 358          ;; connection to the DNS server.
 359          (open-network-stream "dns" (current-buffer) server "domain")))))
 360
 361 (defvar dns-cache (make-vector 4096 0))
 362
 363 (defun dns-query-cached (name &optional type fullp reversep)
 364   (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
 365          (sym (intern-soft key dns-cache)))
 366     (if (and sym
 367              (boundp sym))
 368         (symbol-value sym)
 369       (let ((result (dns-query name type fullp reversep)))
 370         (set (intern key dns-cache) result)
 371         result))))
 372
 373 ;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23
 374 ;; yet, so no alias are provided.  --rsteib
 375
 376 (defun dns-query (name &optional type fullp reversep)
 377   "Query a DNS server for NAME of TYPE.
 378 If FULLP, return the entire record returned.
 379 If REVERSEP, look up an IP address."
 380   (setq type (or type 'A))
 381   (unless dns-servers
 382     (dns-set-servers))
 383
 384   (when reversep
 385     (setq name (concat
 386                 (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
 387                 ".in-addr.arpa")
 388           type 'PTR))
 389
 390   (if (not dns-servers)
 391       (message "No DNS server configuration found")
 392     (with-temp-buffer
 393       (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 394       (let ((process (condition-case ()
 395                          (dns-make-network-process (car dns-servers))
 396                        (error
 397                         (message
 398                          "dns: Got an error while trying to talk to %s"
 399                          (car dns-servers))
 400                         nil)))
 401             (tcp-p (and (not (fboundp 'make-network-process))
 402                         (not (featurep 'xemacs))))
 403             (step 100)
 404             (times (* dns-timeout 1000))
 405             (id (random 65000)))
 406         (when process
 407           (process-send-string
 408            process
 409            (dns-write `((id ,id)
 410                         (opcode query)
 411                         (queries ((,name (type ,type))))
 412                         (recursion-desired-p t))
 413                       tcp-p))
 414           (while (and (zerop (buffer-size))
 415                       (> times 0))
 416             (sit-for (/ step 1000.0))
 417             (accept-process-output process 0 step)
 418             (setq times (- times step)))
 419           (condition-case nil
 420               (delete-process process)
 421             (error nil))
 422           (when (and tcp-p
 423                      (>= (buffer-size) 2))
 424             (goto-char (point-min))
 425             (delete-region (point) (+ (point) 2)))
 426           (when (and (>= (buffer-size) 2)
 427                      ;; We had a time-out.
 428                      (> times 0))
 429             (let ((result (dns-read (buffer-string))))
 430               (if fullp
 431                   result
 432                 (let ((answer (car (dns-get 'answers result))))
 433                   (when (eq type (dns-get 'type answer))
 434                     (if (eq type 'TXT)
 435                         (dns-get-txt-answer (dns-get 'answers result))
 436                       (dns-get 'data answer))))))))))))
 437
 438 (provide 'dns)
 439
 440 ;;; dns.el ends here