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

   1 ;;; dns.el --- Domain Name Service lookups
   2
   3 ;; Copyright (C) 2002-2016 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 (declare-function network-interface-list "process.c")
 307
 308 (defun dns-servers-up-to-date-p ()
 309   "Return false if we need to recheck the list of DNS servers."
 310   (and dns-servers
 311        (or (eq dns-servers-valid-for-interfaces t)
 312            ;; `network-interface-list' was introduced in Emacs 22.1.
 313            (not (fboundp 'network-interface-list))
 314            (equal dns-servers-valid-for-interfaces
 315                   (network-interface-list)))))
 316
 317 (defun dns-set-servers ()
 318   "Set `dns-servers' to a list of DNS servers or nil if none are found.
 319 Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
 320   (or (when (file-exists-p "/etc/resolv.conf")
 321         (setq dns-servers nil)
 322         (with-temp-buffer
 323           (insert-file-contents "/etc/resolv.conf")
 324           (goto-char (point-min))
 325           (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 326             (push (match-string 1) dns-servers))
 327           (setq dns-servers (nreverse dns-servers))))
 328       (when (executable-find "nslookup")
 329         (with-temp-buffer
 330           (call-process "nslookup" nil t nil "localhost")
 331           (goto-char (point-min))
 332           (re-search-forward
 333            "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
 334           (setq dns-servers (list (match-string 1))))))
 335   (when (fboundp 'network-interface-list)
 336     (setq dns-servers-valid-for-interfaces (network-interface-list))))
 337
 338 (defun dns-read-txt (string)
 339   (if (> (length string) 1)
 340       (substring string 1)
 341     string))
 342
 343 (defun dns-get-txt-answer (answers)
 344   (let ((result "")
 345         (do-next nil))
 346     (dolist (answer answers)
 347       (dolist (elem answer)
 348         (when (consp elem)
 349           (cond
 350            ((eq (car elem) 'type)
 351             (setq do-next (eq (cadr elem) 'TXT)))
 352            ((eq (car elem) 'data)
 353             (when do-next
 354               (setq result (concat result (dns-read-txt (cadr elem))))))))))
 355     result))
 356
 357 ;;; Interface functions.
 358 (defmacro dns-make-network-process (server)
 359   (if (featurep 'xemacs)
 360       `(let ((coding-system-for-read 'binary)
 361              (coding-system-for-write 'binary))
 362          (open-network-stream "dns" (current-buffer)
 363                               ,server "domain" 'udp))
 364     `(let ((server ,server)
 365            (coding-system-for-read 'binary)
 366            (coding-system-for-write 'binary))
 367        (if (fboundp 'make-network-process)
 368            (make-network-process
 369             :name "dns"
 370             :coding 'binary
 371             :buffer (current-buffer)
 372             :host server
 373             :service "domain"
 374             :type 'datagram)
 375          ;; Older versions of Emacs doesn't have
 376          ;; `make-network-process', so we fall back on opening a TCP
 377          ;; connection to the DNS server.
 378          (open-network-stream "dns" (current-buffer) server "domain")))))
 379
 380 (defvar dns-cache (make-vector 4096 0))
 381
 382 (defun dns-query-cached (name &optional type fullp reversep)
 383   (let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
 384          (sym (intern-soft key dns-cache)))
 385     (if (and sym
 386              (boundp sym))
 387         (symbol-value sym)
 388       (let ((result (dns-query name type fullp reversep)))
 389         (set (intern key dns-cache) result)
 390         result))))
 391
 392 ;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23
 393 ;; yet, so no alias are provided.  --rsteib
 394
 395 (defun dns-query (name &optional type fullp reversep)
 396   "Query a DNS server for NAME of TYPE.
 397 If FULLP, return the entire record returned.
 398 If REVERSEP, look up an IP address."
 399   (setq type (or type 'A))
 400   (unless (dns-servers-up-to-date-p)
 401     (dns-set-servers))
 402
 403   (when reversep
 404     (setq name (concat
 405                 (mapconcat 'identity (nreverse (split-string name "\\.")) ".")
 406                 ".in-addr.arpa")
 407           type 'PTR))
 408
 409   (if (not dns-servers)
 410       (message "No DNS server configuration found")
 411     (with-temp-buffer
 412       (unless (featurep 'xemacs) (set-buffer-multibyte nil))
 413       (let ((process (condition-case ()
 414                          (dns-make-network-process (car dns-servers))
 415                        (error
 416                         (message
 417                          "dns: Got an error while trying to talk to %s"
 418                          (car dns-servers))
 419                         nil)))
 420             (tcp-p (and (not (fboundp 'make-network-process))
 421                         (not (featurep 'xemacs))))
 422             (step 100)
 423             (times (* dns-timeout 1000))
 424             (id (random 65000)))
 425         (when process
 426           (process-send-string
 427            process
 428            (dns-write `((id ,id)
 429                         (opcode query)
 430                         (queries ((,name (type ,type))))
 431                         (recursion-desired-p t))
 432                       tcp-p))
 433           (while (and (zerop (buffer-size))
 434                       (> times 0))
 435             (sit-for (/ step 1000.0))
 436             (accept-process-output process 0 step)
 437             (setq times (- times step)))
 438           (condition-case nil
 439               (delete-process process)
 440             (error nil))
 441           (when (and tcp-p
 442                      (>= (buffer-size) 2))
 443             (goto-char (point-min))
 444             (delete-region (point) (+ (point) 2)))
 445           (when (and (>= (buffer-size) 2)
 446                      ;; We had a time-out.
 447                      (> times 0))
 448             (let ((result (dns-read (buffer-string))))
 449               (if fullp
 450                   result
 451                 (let ((answer (car (dns-get 'answers result))))
 452                   (when (eq type (dns-get 'type answer))
 453                     (if (eq type 'TXT)
 454                         (dns-get-txt-answer (dns-get 'answers result))
 455                       (dns-get 'data answer))))))))))))
 456
 457 (provide 'dns)
 458
 459 ;;; dns.el ends here