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

   1 ;;; dns.el --- Domain Name Service lookups
   2
   3 ;; Copyright (C) 2002-2014 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 (defvar dns-servers-valid-for-interfaces nil
  35   "The return value of `network-interface-list' when `dns-servers' was set.
  36 If the set of network interfaces and/or their IP addresses
  37 change, then presumably the list of DNS servers needs to be
  38 updated.  Set this variable to t to disable the check.")
  39
  40 ;;; Internal code:
  41
  42 (defvar dns-query-types
  43   '((A 1)
  44     (NS 2)
  45     (MD 3)
  46     (MF 4)
  47     (CNAME 5)
  48     (SOA 6)
  49     (MB 7)
  50     (MG 8)
  51     (MR 9)
  52     (NULL 10)
  53     (WKS 11)
  54     (PTR 12)
  55     (HINFO 13)
  56     (MINFO 14)
  57     (MX 15)
  58     (TXT 16)
  59     (AAAA 28) ; RFC3596
  60     (SRV 33) ; RFC2782
  61     (AXFR 252)
  62     (MAILB 253)
  63     (MAILA 254)
  64     (* 255))
  65   "Names of query types and their values.")
  66
  67 (defvar dns-classes
  68   '((IN 1)
  69     (CS 2)
  70     (CH 3)
  71     (HS 4))
  72   "Classes of queries.")
  73
  74 (defun dns-write-bytes (value &optional length)
  75   (let (bytes)
  76     (dotimes (i (or length 1))
  77       (push (% value 256) bytes)
  78       (setq value (/ value 256)))
  79     (dolist (byte bytes)
  80       (insert byte))))
  81
  82 (defun dns-read-bytes (length)
  83   (let ((value 0))
  84     (dotimes (i length)
  85       (setq value (logior (* value 256) (following-char)))
  86       (forward-char 1))
  87     value))
  88
  89 (defun dns-get (type spec)
  90   (cadr (assq type spec)))
  91
  92 (defun dns-inverse-get (value spec)
  93   (let ((found nil))
  94     (while (and (not found)
  95                 spec)
  96       (if (eq value (cadr (car spec)))
  97           (setq found (caar spec))
  98         (pop spec)))
  99     found))
 100
 101 (defun dns-write-name (name)
 102   (dolist (part (split-string name "\\."))
 103     (dns-write-bytes (length part))
 104     (insert part))
 105   (dns-write-bytes 0))
 106
 107 (defun dns-read-string-name (string buffer)
 108   (with-temp-buffer
 109     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 110     (insert string)
 111     (goto-char (point-min))
 112     (dns-read-name buffer)))
 113
 114 (defun dns-read-name (&optional buffer)
 115   (let ((ended nil)
 116         (name nil)
 117         length)
 118     (while (not ended)
 119       (setq length (dns-read-bytes 1))
 120       (if (= 192 (logand length (lsh 3 6)))
 121           (let ((offset (+ (* (logand 63 length) 256)
 122                            (dns-read-bytes 1))))
 123             (save-excursion
 124               (when buffer
 125                 (set-buffer buffer))
 126               (goto-char (1+ offset))
 127               (setq ended (dns-read-name buffer))))
 128         (if (zerop length)
 129             (setq ended t)
 130           (push (buffer-substring (point)
 131                                   (progn (forward-char length) (point)))
 132                 name))))
 133     (if (stringp ended)
 134         (if (null name)
 135             ended
 136           (concat (mapconcat 'identity (nreverse name) ".") "." ended))
 137       (mapconcat 'identity (nreverse name) "."))))
 138
 139 (defun dns-write (spec &optional tcp-p)
 140   "Write a DNS packet according to SPEC.
 141 If TCP-P, the first two bytes of the package with be the length field."
 142   (with-temp-buffer
 143     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 144     (dns-write-bytes (dns-get 'id spec) 2)
 145     (dns-write-bytes
 146      (logior
 147       (lsh (if (dns-get 'response-p spec) 1 0) -7)
 148       (lsh
 149        (cond
 150         ((eq (dns-get 'opcode spec) 'query) 0)
 151         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
 152         ((eq (dns-get 'opcode spec) 'status) 2)
 153         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
 154        -3)
 155       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
 156       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
 157       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
 158     (dns-write-bytes
 159      (cond
 160       ((eq (dns-get 'response-code spec) 'no-error) 0)
 161       ((eq (dns-get 'response-code spec) 'format-error) 1)
 162       ((eq (dns-get 'response-code spec) 'server-failure) 2)
 163       ((eq (dns-get 'response-code spec) 'name-error) 3)
 164       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
 165       ((eq (dns-get 'response-code spec) 'refused) 5)
 166       (t 0)))
 167     (dns-write-bytes (length (dns-get 'queries spec)) 2)
 168     (dns-write-bytes (length (dns-get 'answers spec)) 2)
 169     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
 170     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
 171     (dolist (query (dns-get 'queries spec))
 172       (dns-write-name (car query))
 173       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
 174                                    dns-query-types)) 2)
 175       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
 176                                    dns-classes)) 2))
 177     (dolist (slot '(answers authorities additionals))
 178       (dolist (resource (dns-get slot spec))
 179         (dns-write-name (car resource))
 180       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
 181                        2)
 182       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
 183                        2)
 184       (dns-write-bytes (dns-get 'ttl resource) 4)
 185       (dns-write-bytes (length (dns-get 'data resource)) 2)
 186       (insert (dns-get 'data resource))))
 187     (when tcp-p
 188       (goto-char (point-min))
 189       (dns-write-bytes (buffer-size) 2))
 190     (buffer-string)))
 191
 192 (defun dns-read (packet)
 193   (with-temp-buffer
 194     (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 195     (let ((spec nil)
 196           queries answers authorities additionals)
 197       (insert packet)
 198       (goto-char (point-min))
 199       (push (list 'id (dns-read-bytes 2)) spec)
 200       (let ((byte (dns-read-bytes 1)))
 201         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
 202               spec)
 203         (let ((opcode (logand byte (lsh 7 3))))
 204           (push (list 'opcode
 205                       (cond ((eq opcode 0) 'query)
 206                             ((eq opcode 1) 'inverse-query)
 207                             ((eq opcode 2) 'status)))
 208                 spec))
 209         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
 210                                          nil t)) spec)
 211         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
 212               spec)
 213         (push (list 'recursion-desired-p
 214                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
 215       (let ((rc (logand (dns-read-bytes 1) 15)))
 216         (push (list 'response-code
 217                     (cond
 218                      ((eq rc 0) 'no-error)
 219                      ((eq rc 1) 'format-error)
 220                      ((eq rc 2) 'server-failure)
 221                      ((eq rc 3) 'name-error)
 222                      ((eq rc 4) 'not-implemented)
 223                      ((eq rc 5) 'refused)))
 224               spec))
 225       (setq queries (dns-read-bytes 2))
 226       (setq answers (dns-read-bytes 2))
 227       (setq authorities (dns-read-bytes 2))
 228       (setq additionals (dns-read-bytes 2))
 229       (let ((qs nil))
 230         (dotimes (i queries)
 231           (push (list (dns-read-name)
 232                       (list 'type (dns-inverse-get (dns-read-bytes 2)
 233                                                    dns-query-types))
 234                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 235                                                     dns-classes)))
 236                 qs))
 237         (push (list 'queries qs) spec))
 238       (dolist (slot '(answers authorities additionals))
 239         (let ((qs nil)
 240               type)
 241           (dotimes (i (symbol-value slot))
 242             (push (list (dns-read-name)
 243                         (list 'type
 244                               (setq type (dns-inverse-get (dns-read-bytes 2)
 245                                                           dns-query-types)))
 246                         (list 'class (dns-inverse-get (dns-read-bytes 2)
 247                                                       dns-classes))
 248                         (list 'ttl (dns-read-bytes 4))
 249                         (let ((length (dns-read-bytes 2)))
 250                           (list 'data
 251                                 (dns-read-type
 252                                  (buffer-substring
 253                                   (point)
 254                                   (progn (forward-char length) (point)))
 255                                  type))))
 256                   qs))
 257           (push (list slot qs) spec)))
 258       (nreverse spec))))
 259
 260 (defun dns-read-int32 ()
 261   ;; Full 32 bit Integers can't be handled by 32-bit Emacsen.  If we
 262   ;; use floats, it works.
 263   (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0)
 264                     (dns-read-bytes 3))))
 265
 266 (defun dns-read-type (string type)
 267   (let ((buffer (current-buffer))
 268         (point (point)))
 269     (prog1
 270         (with-temp-buffer
 271           (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 272           (insert string)
 273           (goto-char (point-min))
 274           (cond
 275            ((eq type 'A)
 276             (let ((bytes nil))
 277               (dotimes (i 4)
 278                 (push (dns-read-bytes 1) bytes))
 279               (mapconcat 'number-to-string (nreverse bytes) ".")))
 280            ((eq type 'AAAA)
 281             (let (hextets)
 282               (dotimes (i 8)
 283                 (push (dns-read-bytes 2) hextets))
 284               (mapconcat (lambda (n) (format "%x" n))
 285                          (nreverse hextets) ":")))
 286            ((eq type 'SOA)
 287             (list (list 'mname (dns-read-name buffer))
 288                   (list 'rname (dns-read-name buffer))
 289                   (list 'serial (dns-read-int32))
 290                   (list 'refresh (dns-read-int32))
 291                   (list 'retry (dns-read-int32))
 292                   (list 'expire (dns-read-int32))
 293                   (list 'minimum (dns-read-int32))))
 294            ((eq type 'SRV)
 295             (list (list 'priority (dns-read-bytes 2))
 296                   (list 'weight (dns-read-bytes 2))
 297                   (list 'port (dns-read-bytes 2))
 298                   (list 'target (dns-read-name buffer))))
 299            ((eq type 'MX)
 300             (cons (dns-read-bytes 2) (dns-read-name buffer)))
 301            ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR))
 302             (dns-read-string-name string buffer))
 303            (t string)))
 304       (goto-char point))))
 305
 306 (defun dns-servers-up-to-date-p ()
 307   "Return false if we need to recheck the list of DNS servers."
 308   (and dns-servers
 309        (or (eq dns-servers-valid-for-interfaces t)
 310            ;; `network-interface-list' was introduced in Emacs 22.1.
 311            (not (fboundp 'network-interface-list))
 312            (equal dns-servers-valid-for-interfaces
 313                   (network-interface-list)))))
 314
 315 (defun dns-set-servers ()
 316   "Set `dns-servers' to a list of DNS servers or nil if none are found.
 317 Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
 318   (or (when (file-exists-p "/etc/resolv.conf")
 319         (setq dns-servers nil)
 320         (with-temp-buffer
 321           (insert-file-contents "/etc/resolv.conf")
 322           (goto-char (point-min))
 323           (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 324             (push (match-string 1) dns-servers))
 325           (setq dns-servers (nreverse dns-servers))))
 326       (when (executable-find "nslookup")
 327         (with-temp-buffer
 328           (call-process "nslookup" nil t nil "localhost")
 329           (goto-char (point-min))
 330           (re-search-forward
 331            "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
 332           (setq dns-servers (list (match-string 1))))))
 333   (when (fboundp 'network-interface-list)
 334     (setq dns-servers-valid-for-interfaces (network-interface-list))))
 335
 336 (defun dns-read-txt (string)
 337   (if (> (length string) 1)
 338       (substring string 1)
 339     string))
 340
 341 (defun dns-get-txt-answer (answers)
 342   (let ((result "")
 343         (do-next nil))
 344     (dolist (answer answers)
 345       (dolist (elem answer)
 346         (when (consp elem)
 347           (cond
 348            ((eq (car elem) 'type)
 349             (setq do-next (eq (cadr elem) 'TXT)))
 350            ((eq (car elem) 'data)
 351             (when do-next
 352               (setq result (concat result (dns-read-txt (cadr elem))))))))))
 353     result))
 354
 355 ;;; Interface functions.
 356 (defmacro dns-make-network-process (server)
 357   (if (featurep 'xemacs)
 358       `(let ((coding-system-for-read 'binary)
 359              (coding-system-for-write 'binary))
 360          (open-network-stream "dns" (current-buffer)
 361                               ,server "domain" 'udp))
 362     `(let ((server ,server)
 363            (coding-system-for-read 'binary)
 364            (coding-system-for-write 'binary))
 365        (if (fboundp 'make-network-process)
 366            (make-network-process
 367             :name "dns"
 368             :coding 'binary
 369             :buffer (current-buffer)
 370             :host server
 371             :service "domain"
 372             :type 'datagram)
 373          ;; Older versions of Emacs doesn't have
 374          ;; `make-network-process', so we fall back on opening a TCP
 375          ;; connection to the DNS server.
 376          (open-network-stream "dns" (current-buffer) server "domain")))))
 377
 378 (defvar dns-cache (make-vector 4096 0))
 379
 380 (defun dns-query-cached (name &optional type fullp reversep)
 381   (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
 382          (sym (intern-soft key dns-cache)))
 383     (if (and sym
 384              (boundp sym))
 385         (symbol-value sym)
 386       (let ((result (dns-query name type fullp reversep)))
 387         (set (intern key dns-cache) result)
 388         result))))
 389
 390 ;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23
 391 ;; yet, so no alias are provided.  --rsteib
 392
 393 (defun dns-query (name &optional type fullp reversep)
 394   "Query a DNS server for NAME of TYPE.
 395 If FULLP, return the entire record returned.
 396 If REVERSEP, look up an IP address."
 397   (setq type (or type 'A))
 398   (unless (dns-servers-up-to-date-p)
 399     (dns-set-servers))
 400
 401   (when reversep
 402     (setq name (concat
 403                 (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
 404                 ".in-addr.arpa")
 405           type 'PTR))
 406
 407   (if (not dns-servers)
 408       (message "No DNS server configuration found")
 409     (with-temp-buffer
 410       (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 411       (let ((process (condition-case ()
 412                          (dns-make-network-process (car dns-servers))
 413                        (error
 414                         (message
 415                          "dns: Got an error while trying to talk to %s"
 416                          (car dns-servers))
 417                         nil)))
 418             (tcp-p (and (not (fboundp 'make-network-process))
 419                         (not (featurep 'xemacs))))
 420             (step 100)
 421             (times (* dns-timeout 1000))
 422             (id (random 65000)))
 423         (when process
 424           (process-send-string
 425            process
 426            (dns-write `((id ,id)
 427                         (opcode query)
 428                         (queries ((,name (type ,type))))
 429                         (recursion-desired-p t))
 430                       tcp-p))
 431           (while (and (zerop (buffer-size))
 432                       (> times 0))
 433             (sit-for (/ step 1000.0))
 434             (accept-process-output process 0 step)
 435             (setq times (- times step)))
 436           (condition-case nil
 437               (delete-process process)
 438             (error nil))
 439           (when (and tcp-p
 440                      (>= (buffer-size) 2))
 441             (goto-char (point-min))
 442             (delete-region (point) (+ (point) 2)))
 443           (when (and (>= (buffer-size) 2)
 444                      ;; We had a time-out.
 445                      (> times 0))
 446             (let ((result (dns-read (buffer-string))))
 447               (if fullp
 448                   result
 449                 (let ((answer (car (dns-get 'answers result))))
 450                   (when (eq type (dns-get 'type answer))
 451                     (if (eq type 'TXT)
 452                         (dns-get-txt-answer (dns-get 'answers result))
 453                       (dns-get 'data answer))))))))))))
 454
 455 (provide 'dns)
 456
 457 ;;; dns.el ends here