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         (if (null name)
 125             ended
 126           (concat (mapconcat 'identity (nreverse name) ".") "." ended))
 127       (mapconcat 'identity (nreverse name) "."))))
 128
 129 (defun dns-write (spec)
 130   "Write a DNS packet according to SPEC."
 131   (with-temp-buffer
 132     (dns-write-bytes (dns-get 'id spec) 2)
 133     (dns-write-bytes
 134      (logior
 135       (lsh (if (dns-get 'response-p spec) 1 0) -7)
 136       (lsh
 137        (cond
 138         ((eq (dns-get 'opcode spec) 'query) 0)
 139         ((eq (dns-get 'opcode spec) 'inverse-query) 1)
 140         ((eq (dns-get 'opcode spec) 'status) 2)
 141         (t (error "No such opcode: %s" (dns-get 'opcode spec))))
 142        -3)
 143       (lsh (if (dns-get 'authoritative-p spec) 1 0) -2)
 144       (lsh (if (dns-get 'truncated-p spec) 1 0) -1)
 145       (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0)))
 146     (dns-write-bytes
 147      (cond
 148       ((eq (dns-get 'response-code spec) 'no-error) 0)
 149       ((eq (dns-get 'response-code spec) 'format-error) 1)
 150       ((eq (dns-get 'response-code spec) 'server-failure) 2)
 151       ((eq (dns-get 'response-code spec) 'name-error) 3)
 152       ((eq (dns-get 'response-code spec) 'not-implemented) 4)
 153       ((eq (dns-get 'response-code spec) 'refused) 5)
 154       (t 0)))
 155     (dns-write-bytes (length (dns-get 'queries spec)) 2)
 156     (dns-write-bytes (length (dns-get 'answers spec)) 2)
 157     (dns-write-bytes (length (dns-get 'authorities spec)) 2)
 158     (dns-write-bytes (length (dns-get 'additionals spec)) 2)
 159     (dolist (query (dns-get 'queries spec))
 160       (dns-write-name (car query))
 161       (dns-write-bytes (cadr (assq (or (dns-get 'type query) 'A)
 162                                    dns-query-types)) 2)
 163       (dns-write-bytes (cadr (assq (or (dns-get 'class query) 'IN)
 164                                    dns-classes)) 2))
 165     (dolist (slot '(answers authorities additionals))
 166       (dolist (resource (dns-get slot spec))
 167         (dns-write-name (car resource))
 168       (dns-write-bytes (cadr (assq (dns-get 'type resource) dns-query-types))
 169                        2)
 170       (dns-write-bytes (cadr (assq (dns-get 'class resource) dns-classes))
 171                        2)
 172       (dns-write-bytes (dns-get 'ttl resource) 4)
 173       (dns-write-bytes (length (dns-get 'data resource)) 2)
 174       (insert (dns-get 'data resource))))
 175     (buffer-string)))
 176
 177 (defun dns-read (packet)
 178   (mm-with-unibyte-buffer
 179     (let ((spec nil)
 180           queries answers authorities additionals)
 181       (insert packet)
 182       (goto-char (point-min))
 183       (push (list 'id (dns-read-bytes 2)) spec)
 184       (let ((byte (dns-read-bytes 1)))
 185         (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t))
 186               spec)
 187         (let ((opcode (logand byte (lsh 7 3))))
 188           (push (list 'opcode
 189                       (cond ((eq opcode 0) 'query)
 190                             ((eq opcode 1) 'inverse-query)
 191                             ((eq opcode 2) 'status)))
 192                 spec))
 193         (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2)))
 194                                          nil t)) spec)
 195         (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t))
 196               spec)
 197         (push (list 'recursion-desired-p
 198                     (if (zerop (logand byte (lsh 1 0))) nil t)) spec))
 199       (let ((rc (logand (dns-read-bytes 1) 15)))
 200         (push (list 'response-code
 201                     (cond
 202                      ((eq rc 0) 'no-error)
 203                      ((eq rc 1) 'format-error)
 204                      ((eq rc 2) 'server-failure)
 205                      ((eq rc 3) 'name-error)
 206                      ((eq rc 4) 'not-implemented)
 207                      ((eq rc 5) 'refused)))
 208               spec))
 209       (setq queries (dns-read-bytes 2))
 210       (setq answers (dns-read-bytes 2))
 211       (setq authorities (dns-read-bytes 2))
 212       (setq additionals (dns-read-bytes 2))
 213       (let ((qs nil))
 214         (dotimes (i queries)
 215           (push (list (dns-read-name)
 216                       (list 'type (dns-inverse-get (dns-read-bytes 2)
 217                                                    dns-query-types))
 218                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 219                                                     dns-classes)))
 220                 qs))
 221         (push (list 'queries qs) spec))
 222     (dolist (slot '(answers authorities additionals))
 223       (let ((qs nil)
 224             type)
 225         (dotimes (i (symbol-value slot))
 226           (push (list (dns-read-name)
 227                       (list 'type
 228                             (setq type (dns-inverse-get (dns-read-bytes 2)
 229                                                         dns-query-types)))
 230                       (list 'class (dns-inverse-get (dns-read-bytes 2)
 231                                                     dns-classes))
 232                       (list 'ttl (dns-read-bytes 4))
 233                       (let ((length (dns-read-bytes 2)))
 234                         (list 'data
 235                               (dns-read-type
 236                                (buffer-substring
 237                                 (point)
 238                                 (progn (forward-char length) (point)))
 239                                type))))
 240                 qs))
 241         (push (list slot qs) spec)))
 242     (nreverse spec))))
 243
 244 (defun dns-read-type (string type)
 245   (let ((buffer (current-buffer))
 246         (point (point)))
 247     (prog1
 248         (mm-with-unibyte-buffer
 249           (insert string)
 250           (goto-char (point-min))
 251           (cond
 252            ((eq type 'A)
 253             (let ((bytes nil))
 254               (dotimes (i 4)
 255                 (push (dns-read-bytes 1) bytes))
 256               (mapconcat 'number-to-string (nreverse bytes) ".")))
 257            ((eq type 'NS)
 258             (dns-read-string-name string buffer))
 259            ((eq type 'CNAME)
 260             (dns-read-string-name string buffer))
 261            (t string)))
 262       (goto-char point))))
 263
 264 ;;; Interface functions.
 265
 266 (defun query-dns (name &optional type fullp)
 267   "Query a DNS server for NAME of TYPE.
 268 If FULLP, return the entire record returned."
 269   (setq type (or type 'A))
 270   (mm-with-unibyte-buffer
 271     (let ((coding-system-for-read 'binary)
 272           (coding-system-for-write 'binary))
 273       (let ((process
 274              (make-network-process
 275               :name "dns"
 276               :coding 'binary
 277               :buffer (current-buffer)
 278               :host "ns2.netfonds.no"
 279               :service "domain"
 280               :type 'datagram))
 281             (step 100)
 282             (times (* dns-timeout 1000))
 283             (id (random 65000)))
 284         (process-send-string
 285          process
 286          (dns-write `((id ,id)
 287                       (opcode query)
 288                       (queries ((,name (type ,type))))
 289                       (recursion-desired-p t))))
 290         (while (and (zerop (buffer-size))
 291                     (> times 0))
 292           (accept-process-output process 0 step)
 293           (decf times step))
 294         (ignore-errors
 295           (delete-process process))
 296         (let ((result (dns-read (buffer-string))))
 297           (if fullp
 298               result
 299             (let ((answer (car (dns-get 'answers result))))
 300               (when (eq type (dns-get 'type answer))
 301                 (dns-get 'data answer)))))))))
 302
 303 (provide 'dns)
 304
 305 ;;; dns.el ends here