X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fdns.el;h=e5acf4e880c51ed54e57b7c15690a9b02bca4b9a;hb=8b87e18f7b6e6fced757c12428271a9433d335bd;hp=6586b9ac5608a4e0dafbbdafc08ccf6c14ce18e5;hpb=bf0958c7448a834ab4aa815a4e660a913742b2f4;p=gnus diff --git a/lisp/dns.el b/lisp/dns.el index 6586b9ac5..e5acf4e88 100644 --- a/lisp/dns.el +++ b/lisp/dns.el @@ -1,5 +1,5 @@ ;;; dns.el --- Domain Name Service lookups -;; Copyright (C) 2002 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2003 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: network @@ -25,11 +25,17 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (require 'mm-util) (defvar dns-timeout 5 "How many seconds to wait when doing DNS queries.") +(defvar dns-servers nil + "Which DNS servers to query. +If nil, /etc/resolv.conf will be consulted.") + ;;; Internal code: (defvar dns-query-types @@ -44,11 +50,12 @@ (MR 9) (NULL 10) (WKS 11) - (PRT 12) + (PTR 12) (HINFO 13) (MINFO 14) (MX 15) (TXT 16) + (AAAA 28) ; RFC3596 (AXFR 252) (MAILB 253) (MAILA 254) @@ -121,11 +128,14 @@ (progn (forward-char length) (point))) name)))) (if (stringp ended) - (concat (mapconcat 'identity (nreverse name) ".") "." ended) + (if (null name) + ended + (concat (mapconcat 'identity (nreverse name) ".") "." ended)) (mapconcat 'identity (nreverse name) ".")))) -(defun dns-write (spec) - "Write a DNS packet according to SPEC." +(defun dns-write (spec &optional tcp-p) + "Write a DNS packet according to SPEC. +If TCP-P, the first two bytes of the package with be the length field." (with-temp-buffer (dns-write-bytes (dns-get 'id spec) 2) (dns-write-bytes @@ -170,6 +180,9 @@ (dns-write-bytes (dns-get 'ttl resource) 4) (dns-write-bytes (length (dns-get 'data resource)) 2) (insert (dns-get 'data resource)))) + (when tcp-p + (goto-char (point-min)) + (dns-write-bytes (buffer-size) 2)) (buffer-string))) (defun dns-read (packet) @@ -239,6 +252,12 @@ (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))) @@ -252,45 +271,108 @@ (dotimes (i 4) (push (dns-read-bytes 1) bytes)) (mapconcat 'number-to-string (nreverse bytes) "."))) - ((eq type 'NS) + ((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 '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 () + (when (file-exists-p "/etc/resolv.conf") + (with-temp-buffer + (insert-file-contents "/etc/resolv.conf") + (goto-char (point-min)) + (while (re-search-forward "^nameserver[\t ]+\\([^ \t\n]+\\)" nil t) + (push (match-string 1) dns-servers)) + (setq dns-servers (nreverse dns-servers))))) + ;;; Interface functions. +(eval-when-compile + (when (featurep 'xemacs) + (require 'gnus-xmas))) + +(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"))))) -(defun query-dns (name &optional type) - "Query a DNS server for NAME of TYPE." +(defun query-dns (name &optional type fullp) + "Query a DNS server for NAME of TYPE. +If FULLP, return the entire record returned." (setq type (or type 'A)) - (mm-with-unibyte-buffer - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (let ((process - (make-network-process - :name "dns" - :coding 'binary - :buffer (current-buffer) - :host "ns2.netfonds.no" - :service "domain" - :type 'datagram)) + (unless dns-servers + (dns-parse-resolv-conf)) + + (if (not dns-servers) + (message "No DNS server configuration found") + (mm-with-unibyte-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))) - (process-send-string - process - (dns-write `((id 4) - (opcode query) - (queries ((,name (type ,type)))) - (recursion-desired-p t)))) - (while (and (zerop (buffer-size)) - (> times 0)) - (accept-process-output process 0 step) - (decf times step)) - (ignore-errors - (delete-process process)) - (let ((answer (car (dns-get 'answers (dns-read (buffer-string)))))) - (when (eq type (dns-get 'type answer)) - (dns-get 'data answer))))))) - + (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)) + (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))))))))))) + (provide 'dns) ;;; dns.el ends here