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