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