X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fdns.el;h=f8f46173fe4870efe89f7d44cedf4c1596ba4a01;hb=c358f44b1670d12d5eff5fe5a447a19afd34a252;hp=a2010f97e1e2d13d3e0bb5d66172291fe6762865;hpb=98975e0e7a4bccf5ada9614e2fb8ccec10f90f34;p=gnus diff --git a/lisp/dns.el b/lisp/dns.el index a2010f97e..f8f46173f 100644 --- a/lisp/dns.el +++ b/lisp/dns.el @@ -1,5 +1,7 @@ ;;; dns.el --- Domain Name Service lookups -;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: network @@ -8,7 +10,7 @@ ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -18,15 +20,13 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: -(require 'mm-util) - (defvar dns-timeout 5 "How many seconds to wait when doing DNS queries.") @@ -48,11 +48,13 @@ If nil, /etc/resolv.conf will be consulted.") (MR 9) (NULL 10) (WKS 11) - (PRT 12) + (PTR 12) (HINFO 13) (MINFO 14) (MX 15) (TXT 16) + (AAAA 28) ; RFC3596 + (SRV 33) ; RFC2782 (AXFR 252) (MAILB 253) (MAILA 254) @@ -100,10 +102,11 @@ If nil, /etc/resolv.conf will be consulted.") (dns-write-bytes 0)) (defun dns-read-string-name (string buffer) - (mm-with-unibyte-buffer - (insert string) - (goto-char (point-min)) - (dns-read-name buffer))) + (let (default-enable-multibyte-characters) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (dns-read-name buffer)))) (defun dns-read-name (&optional buffer) (let ((ended nil) @@ -183,90 +186,117 @@ If TCP-P, the first two bytes of the package with be the length field." (buffer-string))) (defun dns-read (packet) - (mm-with-unibyte-buffer - (let ((spec nil) - queries answers authorities additionals) - (insert packet) - (goto-char (point-min)) - (push (list 'id (dns-read-bytes 2)) spec) - (let ((byte (dns-read-bytes 1))) - (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) - spec) - (let ((opcode (logand byte (lsh 7 3)))) - (push (list 'opcode - (cond ((eq opcode 0) 'query) - ((eq opcode 1) 'inverse-query) - ((eq opcode 2) 'status))) - spec)) - (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) - nil t)) spec) - (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) - spec) - (push (list 'recursion-desired-p - (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) - (let ((rc (logand (dns-read-bytes 1) 15))) - (push (list 'response-code - (cond - ((eq rc 0) 'no-error) - ((eq rc 1) 'format-error) - ((eq rc 2) 'server-failure) - ((eq rc 3) 'name-error) - ((eq rc 4) 'not-implemented) - ((eq rc 5) 'refused))) - spec)) - (setq queries (dns-read-bytes 2)) - (setq answers (dns-read-bytes 2)) - (setq authorities (dns-read-bytes 2)) - (setq additionals (dns-read-bytes 2)) - (let ((qs nil)) - (dotimes (i queries) - (push (list (dns-read-name) - (list 'type (dns-inverse-get (dns-read-bytes 2) - dns-query-types)) - (list 'class (dns-inverse-get (dns-read-bytes 2) - dns-classes))) - qs)) - (push (list 'queries qs) spec)) - (dolist (slot '(answers authorities additionals)) - (let ((qs nil) - type) - (dotimes (i (symbol-value slot)) - (push (list (dns-read-name) - (list 'type - (setq type (dns-inverse-get (dns-read-bytes 2) - dns-query-types))) - (list 'class (dns-inverse-get (dns-read-bytes 2) - dns-classes)) - (list 'ttl (dns-read-bytes 4)) - (let ((length (dns-read-bytes 2))) - (list 'data - (dns-read-type - (buffer-substring - (point) - (progn (forward-char length) (point))) - type)))) - qs)) - (push (list slot qs) spec))) - (nreverse spec)))) + (let (default-enable-multibyte-characters) + (with-temp-buffer + (let ((spec nil) + queries answers authorities additionals) + (insert packet) + (goto-char (point-min)) + (push (list 'id (dns-read-bytes 2)) spec) + (let ((byte (dns-read-bytes 1))) + (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) + spec) + (let ((opcode (logand byte (lsh 7 3)))) + (push (list 'opcode + (cond ((eq opcode 0) 'query) + ((eq opcode 1) 'inverse-query) + ((eq opcode 2) 'status))) + spec)) + (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) + nil t)) spec) + (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) + spec) + (push (list 'recursion-desired-p + (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) + (let ((rc (logand (dns-read-bytes 1) 15))) + (push (list 'response-code + (cond + ((eq rc 0) 'no-error) + ((eq rc 1) 'format-error) + ((eq rc 2) 'server-failure) + ((eq rc 3) 'name-error) + ((eq rc 4) 'not-implemented) + ((eq rc 5) 'refused))) + spec)) + (setq queries (dns-read-bytes 2)) + (setq answers (dns-read-bytes 2)) + (setq authorities (dns-read-bytes 2)) + (setq additionals (dns-read-bytes 2)) + (let ((qs nil)) + (dotimes (i queries) + (push (list (dns-read-name) + (list 'type (dns-inverse-get (dns-read-bytes 2) + dns-query-types)) + (list 'class (dns-inverse-get (dns-read-bytes 2) + dns-classes))) + qs)) + (push (list 'queries qs) spec)) + (dolist (slot '(answers authorities additionals)) + (let ((qs nil) + type) + (dotimes (i (symbol-value slot)) + (push (list (dns-read-name) + (list 'type + (setq type (dns-inverse-get (dns-read-bytes 2) + dns-query-types))) + (list 'class (dns-inverse-get (dns-read-bytes 2) + dns-classes)) + (list 'ttl (dns-read-bytes 4)) + (let ((length (dns-read-bytes 2))) + (list 'data + (dns-read-type + (buffer-substring + (point) + (progn (forward-char length) (point))) + type)))) + qs)) + (push (list slot qs) spec))) + (nreverse spec))))) + +(defun dns-read-int32 () + ;; Full 32 bit Integers can't be handled by Emacs. If we use + ;; floats, it works. + (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) + (dns-read-bytes 3)))) (defun dns-read-type (string type) (let ((buffer (current-buffer)) (point (point))) (prog1 - (mm-with-unibyte-buffer - (insert string) - (goto-char (point-min)) - (cond - ((eq type 'A) - (let ((bytes nil)) - (dotimes (i 4) - (push (dns-read-bytes 1) bytes)) - (mapconcat 'number-to-string (nreverse bytes) "."))) - ((eq type 'NS) - (dns-read-string-name string buffer)) - ((eq type 'CNAME) - (dns-read-string-name string buffer)) - (t string))) + (let (default-enable-multibyte-characters) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (cond + ((eq type 'A) + (let ((bytes nil)) + (dotimes (i 4) + (push (dns-read-bytes 1) bytes)) + (mapconcat 'number-to-string (nreverse bytes) "."))) + ((eq type 'AAAA) + (let (hextets) + (dotimes (i 8) + (push (dns-read-bytes 2) hextets)) + (mapconcat (lambda (n) (format "%x" n)) + (nreverse hextets) ":"))) + ((eq type 'SOA) + (list (list 'mname (dns-read-name buffer)) + (list 'rname (dns-read-name buffer)) + (list 'serial (dns-read-int32)) + (list 'refresh (dns-read-int32)) + (list 'retry (dns-read-int32)) + (list 'expire (dns-read-int32)) + (list 'minimum (dns-read-int32)))) + ((eq type 'SRV) + (list (list 'priority (dns-read-bytes 2)) + (list 'weight (dns-read-bytes 2)) + (list 'port (dns-read-bytes 2)) + (list 'target (dns-read-name buffer)))) + ((eq type 'MX) + (cons (dns-read-bytes 2) (dns-read-name buffer))) + ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR)) + (dns-read-string-name string buffer)) + (t string)))) (goto-char point)))) (defun dns-parse-resolv-conf () @@ -278,59 +308,123 @@ If TCP-P, the first two bytes of the package with be the length field." (push (match-string 1) dns-servers)) (setq dns-servers (nreverse dns-servers))))) +(defun dns-read-txt (string) + (if (> (length string) 1) + (substring string 1) + string)) + +(defun dns-get-txt-answer (answers) + (let ((result "") + (do-next nil)) + (dolist (answer answers) + (dolist (elem answer) + (when (consp elem) + (cond + ((eq (car elem) 'type) + (setq do-next (eq (cadr elem) 'TXT))) + ((eq (car elem) 'data) + (when do-next + (setq result (concat result (dns-read-txt (cadr elem)))))))))) + result)) + ;;; Interface functions. +(defmacro dns-make-network-process (server) + (if (featurep 'xemacs) + `(let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (open-network-stream "dns" (current-buffer) + ,server "domain" 'udp)) + `(let ((server ,server) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (if (fboundp 'make-network-process) + (make-network-process + :name "dns" + :coding 'binary + :buffer (current-buffer) + :host server + :service "domain" + :type 'datagram) + ;; Older versions of Emacs doesn't have + ;; `make-network-process', so we fall back on opening a TCP + ;; connection to the DNS server. + (open-network-stream "dns" (current-buffer) server "domain"))))) + +(defvar dns-cache (make-vector 4096 0)) -(defun query-dns (name &optional type fullp) +(defun query-dns-cached (name &optional type fullp reversep) + (let* ((key (format "%s:%s:%s:%s" name type fullp reversep)) + (sym (intern-soft key dns-cache))) + (if (and sym + (boundp sym)) + (symbol-value sym) + (let ((result (query-dns name type fullp reversep))) + (set (intern key dns-cache) result) + result)))) + +(defun query-dns (name &optional type fullp reversep) "Query a DNS server for NAME of TYPE. -If FULLP, return the entire record returned." +If FULLP, return the entire record returned. +If REVERSEP, look up an IP address." (setq type (or type 'A)) (unless dns-servers - (dns-parse-resolv-conf) - (unless dns-servers - (error "No DNS server configuration found"))) - (mm-with-unibyte-buffer - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (tcp-p (not (fboundp 'open-network-stream)))) - (let ((process - (if tcp-p - (open-network-stream - "dns" (current-buffer) - (car dns-servers) "domain") - (make-network-process - :name "dns" - :coding 'binary - :buffer (current-buffer) - :host (car dns-servers) - :service "domain" - :type 'datagram))) - (step 100) - (times (* dns-timeout 1000)) - (id (random 65000))) - (process-send-string - process - (dns-write `((id ,id) - (opcode query) - (queries ((,name (type ,type)))) - (recursion-desired-p t)) - tcp-p)) - (while (and (zerop (buffer-size)) - (> times 0)) - (accept-process-output process 0 step) - (decf times step)) - (ignore-errors - (delete-process process)) - (when tcp-p - (goto-char (point-min)) - (delete-region (point) (+ (point) 2))) - (unless (zerop (buffer-size)) - (let ((result (dns-read (buffer-string)))) - (if fullp - result - (let ((answer (car (dns-get 'answers result)))) - (when (eq type (dns-get 'type answer)) - (dns-get 'data answer)))))))))) - + (dns-parse-resolv-conf)) + + (when reversep + (setq name (concat + (mapconcat 'identity (nreverse (split-string name "\\.")) ".") + ".in-addr.arpa") + type 'PTR)) + + (if (not dns-servers) + (message "No DNS server configuration found") + (let (default-enable-multibyte-characters) + (with-temp-buffer + (let ((process (condition-case () + (dns-make-network-process (car dns-servers)) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) + (tcp-p (and (not (fboundp 'make-network-process)) + (not (featurep 'xemacs)))) + (step 100) + (times (* dns-timeout 1000)) + (id (random 65000))) + (when process + (process-send-string + process + (dns-write `((id ,id) + (opcode query) + (queries ((,name (type ,type)))) + (recursion-desired-p t)) + tcp-p)) + (while (and (zerop (buffer-size)) + (> times 0)) + (sit-for (/ step 1000.0)) + (accept-process-output process 0 step) + (setq times (- times step))) + (condition-case nil + (delete-process process) + (error nil)) + (when (and tcp-p + (>= (buffer-size) 2)) + (goto-char (point-min)) + (delete-region (point) (+ (point) 2))) + (when (and (>= (buffer-size) 2) + ;; We had a time-out. + (> times 0)) + (let ((result (dns-read (buffer-string)))) + (if fullp + result + (let ((answer (car (dns-get 'answers result)))) + (when (eq type (dns-get 'type answer)) + (if (eq type 'TXT) + (dns-get-txt-answer (dns-get 'answers result)) + (dns-get 'data answer))))))))))))) + (provide 'dns) +;;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a ;;; dns.el ends here