git.chise.org Git - elisp/gnus.git-/blob - lisp/dns.el

   1 ;;; dns.el --- Domain Name Service lookups
   2 ;; Copyright (C) 2002 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 (require 'mm-util)
  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     (PRT 12)
  52     (HINFO 13)
  53     (MINFO 14)
  54     (MX 15)
  55     (TXT 16)
  56     (AXFR 252)
  57     (MAILB 253)
  58     (MAILA 254)
  59     (* 255))
  60   "Names of query types and their values.")
  61
  62 (defvar dns-classes
  63   '((IN 1)
  64     (CS 2)
  65     (CH 3)
  66     (HS 4))
  67   "Classes of queries.")
  68
  69 (defun dns-write-bytes (value &optional length)
  70   (let (bytes)
  71     (dotimes (i (or length 1))
  72       (push (% value 256) bytes)
  73       (setq value (/ value 256)))
  74     (dolist (byte bytes)
  75       (insert byte))))
  76
  77 (defun dns-read-bytes (length)
  78   (let ((value 0))
  79     (dotimes (i length)
  80       (setq value (logior (* value 256) (following-char)))
  81       (forward-char 1))
  82     value))
  83
  84 (defun dns-get (type spec)
  85   (cadr (assq type spec)))
  86
  87 (defun dns-inverse-get (value spec)
  88   (let ((found nil))
  89     (while (and (not found)
  90                 spec)
  91       (if (eq value (cadr (car spec)))
  92           (setq found (caar spec))
  93         (pop spec)))
  94     found))
  95
  96 (defun dns-write-name (name)
  97   (dolist (part (split-string name "\\."))
  98     (dns-write-bytes (length part))
  99     (insert part))
 100   (dns-write-bytes 0))
 101
 102 (defun dns-read-string-name (string buffer)
 103   (mm-with-unibyte-buffer
 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     (dns-write-bytes (dns-get 'id spec) 2)
 138     (dns-write-bytes
 139      (logior
 140       (lsh (if (dns-get 'response-p spec) 1 0) -7)
 141       (lsh
 142        (cond
 143         ((eq (dns-get 'opcode spec) 'query) 0)
 144         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
 145         ((eq (dns-get 'opcode spec) 'status) 2)
 146         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
 147        -3)
 148       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
 149       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
 150       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
 151     (dns-write-bytes
 152      (cond
 153       ((eq (dns-get 'response-code spec) 'no-error) 0)
 154       ((eq (dns-get 'response-code spec) 'format-error) 1)
 155       ((eq (dns-get 'response-code spec) 'server-failure) 2)
 156       ((eq (dns-get 'response-code spec) 'name-error) 3)
 157       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
 158       ((eq (dns-get 'response-code spec) 'refused) 5)
 159       (t 0)))
 160     (dns-write-bytes (length (dns-get 'queries spec)) 2)
 161     (dns-write-bytes (length (dns-get 'answers spec)) 2)
 162     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
 163     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
 164     (dolist (query (dns-get 'queries spec))
 165       (dns-write-name (car query))
 166       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
 167                                    dns-query-types)) 2)
 168       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
 169                                    dns-classes)) 2))
 170     (dolist (slot '(answers authorities additionals))
 171       (dolist (resource (dns-get slot spec))
 172         (dns-write-name (car resource))
 173       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
 174                        2)
 175       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
 176                        2)
 177       (dns-write-bytes (dns-get 'ttl resource) 4)
 178       (dns-write-bytes (length (dns-get 'data resource)) 2)
 179       (insert (dns-get 'data resource))))
 180     (when tcp-p
 181       (goto-char (point-min))
 182       (dns-write-bytes (buffer-size) 2))
 183     (buffer-string)))
 184
 185 (defun dns-read (packet)
 186   (mm-with-unibyte-buffer
 187     (let ((spec nil)
 188           queries answers authorities additionals)
 189       (insert packet)
 190       (goto-char (point-min))
 191       (push (list 'id (dns-read-bytes 2)) spec)
 192       (let ((byte (dns-read-bytes 1)))
 193         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
 194               spec)
 195         (let ((opcode (logand byte (lsh 7 3))))
 196           (push (list 'opcode
 197                       (cond ((eq opcode 0) 'query)
 198                             ((eq opcode 1) 'inverse-query)
 199                             ((eq opcode 2) 'status)))
 200                 spec))
 201         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
 202                                          nil t)) spec)
 203         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
 204               spec)
 205         (push (list 'recursion-desired-p
 206                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
 207       (let ((rc (logand (dns-read-bytes 1) 15)))
 208         (push (list 'response-code
 209                     (cond
 210                      ((eq rc 0) 'no-error)
 211                      ((eq rc 1) 'format-error)
 212                      ((eq rc 2) 'server-failure)
 213                      ((eq rc 3) 'name-error)
 214                      ((eq rc 4) 'not-implemented)
 215                      ((eq rc 5) 'refused)))
 216               spec))
 217       (setq queries (dns-read-bytes 2))
 218       (setq answers (dns-read-bytes 2))
 219       (setq authorities (dns-read-bytes 2))
 220       (setq additionals (dns-read-bytes 2))
 221       (let ((qs nil))
 222         (dotimes (i queries)
 223           (push (list (dns-read-name)
 224                       (list 'type (dns-inverse-get (dns-read-bytes 2)
 225                                                    dns-query-types))
 226                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 227                                                     dns-classes)))
 228                 qs))
 229         (push (list 'queries qs) spec))
 230     (dolist (slot '(answers authorities additionals))
 231       (let ((qs nil)
 232             type)
 233         (dotimes (i (symbol-value slot))
 234           (push (list (dns-read-name)
 235                       (list 'type
 236                             (setq type (dns-inverse-get (dns-read-bytes 2)
 237                                                         dns-query-types)))
 238                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 239                                                     dns-classes))
 240                       (list 'ttl (dns-read-bytes 4))
 241                       (let ((length (dns-read-bytes 2)))
 242                         (list 'data
 243                               (dns-read-type
 244                                (buffer-substring
 245                                 (point)
 246                                 (progn (forward-char length) (point)))
 247                                type))))
 248                 qs))
 249         (push (list slot qs) spec)))
 250     (nreverse spec))))
 251
 252 (defun dns-read-type (string type)
 253   (let ((buffer (current-buffer))
 254         (point (point)))
 255     (prog1
 256         (mm-with-unibyte-buffer
 257           (insert string)
 258           (goto-char (point-min))
 259           (cond
 260            ((eq type 'A)
 261             (let ((bytes nil))
 262               (dotimes (i 4)
 263                 (push (dns-read-bytes 1) bytes))
 264               (mapconcat 'number-to-string (nreverse bytes) ".")))
 265            ((eq type 'NS)
 266             (dns-read-string-name string buffer))
 267            ((eq type 'CNAME)
 268             (dns-read-string-name string buffer))
 269            (t string)))
 270       (goto-char point))))
 271
 272 (defun dns-parse-resolv-conf ()
 273   (when (file-exists-p "/etc/resolv.conf")
 274     (with-temp-buffer
 275       (insert-file-contents "/etc/resolv.conf")
 276       (goto-char (point-min))
 277       (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t)
 278         (push (match-string 1) dns-servers))
 279       (setq dns-servers (nreverse dns-servers)))))
 280
 281 ;;; Interface functions.
 282
 283 (defmacro dns-make-network-process (server)
 284   (if (featurep 'xemacs)
 285       `(let ((coding-system-for-read 'binary)
 286              (coding-system-for-write 'binary))
 287          (open-network-stream "dns" (current-buffer) ,server "domain" 'udp))
 288     `(let ((server ,server)
 289            (coding-system-for-read 'binary)
 290            (coding-system-for-write 'binary)
 291            (default-process-coding-system '(binary . binary))
 292            program-coding-system-alist)
 293        (if (fboundp 'make-network-process)
 294            (make-network-process
 295             :name "dns"
 296             :coding 'binary
 297             :buffer (current-buffer)
 298             :host server
 299             :service "domain"
 300             :type 'datagram)
 301          (open-network-stream "dns" (current-buffer) server "domain")))))
 302
 303 (defun query-dns (name &optional type fullp)
 304   "Query a DNS server for NAME of TYPE.
 305 If FULLP, return the entire record returned."
 306   (setq type (or type 'A))
 307   (unless dns-servers
 308     (dns-parse-resolv-conf)
 309     (unless dns-servers
 310       (error "No DNS server configuration found")))
 311   (mm-with-unibyte-buffer
 312     (let ((process (condition-case ()
 313                        (dns-make-network-process (car dns-servers))
 314                      (error
 315                       (message "dns: Got an error while trying to talk to %s"
 316                                (car dns-servers))
 317                       nil)))
 318           (tcp-p (and (not (fboundp 'make-network-process))
 319                       (not (featurep 'xemacs))))
 320           (step 100)
 321           (times (* dns-timeout 1000))
 322           (id (random 65000)))
 323       (when process
 324         (process-send-string
 325          process
 326          (dns-write `((id ,id)
 327                       (opcode query)
 328                       (queries ((,name (type ,type))))
 329                       (recursion-desired-p t))
 330                     tcp-p))
 331         (while (and (zerop (buffer-size))
 332                     (> times 0))
 333           (accept-process-output process 0 step)
 334           (decf times step))
 335         (ignore-errors
 336           (delete-process process))
 337         (when tcp-p
 338           (goto-char (point-min))
 339           (delete-region (point) (+ (point) 2)))
 340         (unless (zerop (buffer-size))
 341           (let ((result (dns-read (buffer-string))))
 342             (if fullp
 343                 result
 344               (let ((answer (car (dns-get 'answers result))))
 345                 (when (eq type (dns-get 'type answer))
 346                   (dns-get 'data answer))))))))))
 347
 348 (provide 'dns)
 349
 350 ;;; dns.el ends here