cgit.sxemacs.org Git - gnus/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 ;;; Internal code:
  34
  35 (defvar dns-query-types
  36   '((A 1)
  37     (NS 2)
  38     (MD 3)
  39     (MF 4)
  40     (CNAME 5)
  41     (SOA 6)
  42     (MB 7)
  43     (MG 8)
  44     (MR 9)
  45     (NULL 10)
  46     (WKS 11)
  47     (PRT 12)
  48     (HINFO 13)
  49     (MINFO 14)
  50     (MX 15)
  51     (TXT 16)
  52     (AXFR 252)
  53     (MAILB 253)
  54     (MAILA 254)
  55     (* 255))
  56   "Names of query types and their values.")
  57
  58 (defvar dns-classes
  59   '((IN 1)
  60     (CS 2)
  61     (CH 3)
  62     (HS 4))
  63   "Classes of queries.")
  64
  65 (defun dns-write-bytes (value &optional length)
  66   (let (bytes)
  67     (dotimes (i (or length 1))
  68       (push (% value 256) bytes)
  69       (setq value (/ value 256)))
  70     (dolist (byte bytes)
  71       (insert byte))))
  72
  73 (defun dns-read-bytes (length)
  74   (let ((value 0))
  75     (dotimes (i length)
  76       (setq value (logior (* value 256) (following-char)))
  77       (forward-char 1))
  78     value))
  79
  80 (defun dns-get (type spec)
  81   (cadr (assq type spec)))
  82
  83 (defun dns-inverse-get (value spec)
  84   (let ((found nil))
  85     (while (and (not found)
  86                 spec)
  87       (if (eq value (cadr (car spec)))
  88           (setq found (caar spec))
  89         (pop spec)))
  90     found))
  91
  92 (defun dns-write-name (name)
  93   (dolist (part (split-string name "\\."))
  94     (dns-write-bytes (length part))
  95     (insert part))
  96   (dns-write-bytes 0))
  97
  98 (defun dns-read-string-name (string buffer)
  99   (mm-with-unibyte-buffer
 100     (insert string)
 101     (goto-char (point-min))
 102     (dns-read-name buffer)))
 103
 104 (defun dns-read-name (&optional buffer)
 105   (let ((ended nil)
 106         (name nil)
 107         length)
 108     (while (not ended)
 109       (setq length (dns-read-bytes 1))
 110       (if (= 192 (logand length (lsh 3 6)))
 111           (let ((offset (+ (* (logand 63 length) 256)
 112                            (dns-read-bytes 1))))
 113             (save-excursion
 114               (when buffer
 115                 (set-buffer buffer))
 116               (goto-char (1+ offset))
 117               (setq ended (dns-read-name buffer))))
 118         (if (zerop length)
 119             (setq ended t)
 120           (push (buffer-substring (point)
 121                                   (progn (forward-char length) (point)))
 122                 name))))
 123     (if (stringp ended)
 124         (concat (mapconcat 'identity (nreverse name) ".") "." ended)
 125       (mapconcat 'identity (nreverse name) "."))))
 126
 127 (defun dns-write (spec)
 128   "Write a DNS packet according to SPEC."
 129   (with-temp-buffer
 130     (dns-write-bytes (dns-get 'id spec) 2)
 131     (dns-write-bytes
 132      (logior
 133       (lsh (if (dns-get 'response-p spec) 1 0) -7)
 134       (lsh
 135        (cond
 136         ((eq (dns-get 'opcode spec) 'query) 0)
 137         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
 138         ((eq (dns-get 'opcode spec) 'status) 2)
 139         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
 140        -3)
 141       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
 142       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
 143       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
 144     (dns-write-bytes
 145      (cond
 146       ((eq (dns-get 'response-code spec) 'no-error) 0)
 147       ((eq (dns-get 'response-code spec) 'format-error) 1)
 148       ((eq (dns-get 'response-code spec) 'server-failure) 2)
 149       ((eq (dns-get 'response-code spec) 'name-error) 3)
 150       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
 151       ((eq (dns-get 'response-code spec) 'refused) 5)
 152       (t 0)))
 153     (dns-write-bytes (length (dns-get 'queries spec)) 2)
 154     (dns-write-bytes (length (dns-get 'answers spec)) 2)
 155     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
 156     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
 157     (dolist (query (dns-get 'queries spec))
 158       (dns-write-name (car query))
 159       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
 160                                    dns-query-types)) 2)
 161       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
 162                                    dns-classes)) 2))
 163     (dolist (slot '(answers authorities additionals))
 164       (dolist (resource (dns-get slot spec))
 165         (dns-write-name (car resource))
 166       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
 167                        2)
 168       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
 169                        2)
 170       (dns-write-bytes (dns-get 'ttl resource) 4)
 171       (dns-write-bytes (length (dns-get 'data resource)) 2)
 172       (insert (dns-get 'data resource))))
 173     (buffer-string)))
 174
 175 (defun dns-read (packet)
 176   (mm-with-unibyte-buffer
 177     (let ((spec nil)
 178           queries answers authorities additionals)
 179       (insert packet)
 180       (goto-char (point-min))
 181       (push (list 'id (dns-read-bytes 2)) spec)
 182       (let ((byte (dns-read-bytes 1)))
 183         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
 184               spec)
 185         (let ((opcode (logand byte (lsh 7 3))))
 186           (push (list 'opcode
 187                       (cond ((eq opcode 0) 'query)
 188                             ((eq opcode 1) 'inverse-query)
 189                             ((eq opcode 2) 'status)))
 190                 spec))
 191         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
 192                                          nil t)) spec)
 193         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
 194               spec)
 195         (push (list 'recursion-desired-p
 196                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
 197       (let ((rc (logand (dns-read-bytes 1) 15)))
 198         (push (list 'response-code
 199                     (cond
 200                      ((eq rc 0) 'no-error)
 201                      ((eq rc 1) 'format-error)
 202                      ((eq rc 2) 'server-failure)
 203                      ((eq rc 3) 'name-error)
 204                      ((eq rc 4) 'not-implemented)
 205                      ((eq rc 5) 'refused)))
 206               spec))
 207       (setq queries (dns-read-bytes 2))
 208       (setq answers (dns-read-bytes 2))
 209       (setq authorities (dns-read-bytes 2))
 210       (setq additionals (dns-read-bytes 2))
 211       (let ((qs nil))
 212         (dotimes (i queries)
 213           (push (list (dns-read-name)
 214                       (list 'type (dns-inverse-get (dns-read-bytes 2)
 215                                                    dns-query-types))
 216                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 217                                                     dns-classes)))
 218                 qs))
 219         (push (list 'queries qs) spec))
 220     (dolist (slot '(answers authorities additionals))
 221       (let ((qs nil)
 222             type)
 223         (dotimes (i (symbol-value slot))
 224           (push (list (dns-read-name)
 225                       (list 'type
 226                             (setq 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                       (list 'ttl (dns-read-bytes 4))
 231                       (let ((length (dns-read-bytes 2)))
 232                         (list 'data
 233                               (dns-read-type
 234                                (buffer-substring
 235                                 (point)
 236                                 (progn (forward-char length) (point)))
 237                                type))))
 238                 qs))
 239         (push (list slot qs) spec)))
 240     (nreverse spec))))
 241
 242 (defun dns-read-type (string type)
 243   (let ((buffer (current-buffer))
 244         (point (point)))
 245     (prog1
 246         (mm-with-unibyte-buffer
 247           (insert string)
 248           (goto-char (point-min))
 249           (cond
 250            ((eq type 'A)
 251             (let ((bytes nil))
 252               (dotimes (i 4)
 253                 (push (dns-read-bytes 1) bytes))
 254               (mapconcat 'number-to-string (nreverse bytes) ".")))
 255            ((eq type 'NS)
 256             (dns-read-string-name string buffer))
 257            (t string)))
 258       (goto-char point))))
 259
 260 ;;; Interface functions.
 261
 262 (defun query-dns (name &optional type)
 263   "Query a DNS server for NAME of TYPE."
 264   (setq type (or type 'A))
 265   (mm-with-unibyte-buffer
 266     (let ((coding-system-for-read 'binary)
 267           (coding-system-for-write 'binary))
 268       (let ((process
 269              (make-network-process
 270               :name "dns"
 271               :coding 'binary
 272               :buffer (current-buffer)
 273               :host "ns2.netfonds.no"
 274               :service "domain"
 275               :type 'datagram))
 276             (step 100)
 277             (times (* dns-timeout 1000)))
 278         (process-send-string
 279          process
 280          (dns-write `((id 4)
 281                       (opcode query)
 282                       (queries ((,name (type ,type))))
 283                       (recursion-desired-p t))))
 284         (while (and (zerop (buffer-size))
 285                     (> times 0))
 286           (accept-process-output process 0 step)
 287           (decf times step))
 288         (ignore-errors
 289           (delete-process process))
 290         (let ((answer (car (dns-get 'answers (dns-read (buffer-string))))))
 291           (when (eq type (dns-get 'type answer))
 292             (dns-get 'data answer)))))))
 293
 294 (provide 'dns)
 295
 296 ;;; dns.el ends here