From 6f52781aa61a5dca1d19e5fd467cd4cb526d5ed9 Mon Sep 17 00:00:00 2001
From: cresh <cresh>
Date: Tue, 19 Aug 2003 14:36:08 +0000
Subject: [PATCH] * added dns-check-nameservers * fixed alists in
 send-receive-message-tcp * fixed and added documentation

---
 doc/latex/dns.tex   |   8 +++
 scheme/lib/dns.scm  | 135 +++++++++++++++++++++++++++++++++++++++-----
 scheme/packages.scm |   1 +
 3 files changed, 131 insertions(+), 13 deletions(-)

diff --git a/doc/latex/dns.tex b/doc/latex/dns.tex
index 0d2d970..5a48f50 100644
--- a/doc/latex/dns.tex
+++ b/doc/latex/dns.tex
@@ -149,6 +149,14 @@ accept. \var{Nameserver} is either a \ipaddr or a dotted IP string.
   resolve these FQDNs.
 \end{desc}
 
+\defun{dns-check-nameservers} {[nameserver list]} {\undefined}
+\begin{desc}
+  \ex{dns-check-namservers} checks if the given nameservers are reachable.
+  If no argument is given, the nameservers in \texttt{/etc/resolv.conf}
+  are checked. Information about the status of the nameservers is printed
+  to the current output port.
+\end{desc}
+
 \section{Low-level Interface}
 
 This section describes a set of data structures and procedures which
diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm
index 67c2c33..7fd6075 100644
--- a/scheme/lib/dns.scm
+++ b/scheme/lib/dns.scm
@@ -30,17 +30,25 @@
 ;  if it is a domainname, its ip is looked up on a nameserver listed in
 ;  /etc/resolv.conf.
 ;
-;  (dns-find-nameserver) --> <ip-address32>
-;  this parses the /etc/resolv.conf file and returns the first found 
-;  nameserver in address32 format.
+;  (dns-find-nameserver-list) --> <ip-string list>
+;  this parses the /etc/resolv.conf file and returns the found 
+;  nameserver in a list of dotted strings.
 ;
+;  (dns-find-nameserver) --> <ip-string>
+;  this parses the /etc/resolv.conf file and returns the first found 
+;  nameserver in dotted string notation.
+;
+;  (dns-check-namservers [nameserver list]) --> undefined
+;  checks if the given nameservers are reachable. If no argument is given,
+;  the nameservers in /etc/resolv.conf are checked.
 ;
 ;  
-;  (dns-lookup-name <name> [nameserver]) --> <ip-address32>
-;  (dns-lookup-ip <ip-string | ip-address32> [nameserver]) --> <name>
-;  (dns-lookup-nameserver <name> [nameserver]) 
+;  (dns-lookup-name <name> [nameserver list] [use-cache?]) --> <ip-address32>
+;  (dns-lookup-ip <ip-string | ip-address32> [nameserver list] [use-cache?]) 
+;                     --> <name>
+;  (dns-lookup-nameserver <name> [nameserver list] [use-cache?]) 
 ;                     --> <list of ip-address32s of authoritative nameservers>
-;  (dns-lookup-mail-exchanger <name> [nameserver]) 
+;  (dns-lookup-mail-exchanger <name> [nameserver list] [use-cache?]) 
 ;                     --> <list of names of mail-exchangers>
 ; 
 ;  dns-lookup-name, dns-lookup-ip, dns-lookup-nameserver and 
@@ -57,7 +65,7 @@
 ;           /etc/resolv.conf.
 ;
 ;
-;  (dns-lookup <name | ip-string | ip-address32> <type> [nameserver]) 
+;  (dns-lookup <name | ip-string | ip-address32> <type> [nameserver list]) 
 ;                     --> <dns-message>
 ;  (show-dns-message <dns-message) --> the whole message, human readable
 ;
@@ -780,9 +788,7 @@
 ;; here: via TCP
 (define (send-receive-message-tcp nameservers query)
   (receive (reply hit-ns other-nss)
-	   (let ((sockets (filter
-			   socket?
-			   (map
+	   (let ((sockets (map
 			   (lambda (nameserver)
 			     (let ((sock (create-socket protocol-family/internet
 							socket-type/stream))
@@ -797,8 +803,18 @@
 						(lambda ()
 						  (connect-socket-no-wait sock addr)
 						  sock))))))
-			   nameservers))))
-	(let* ((ws (map socket:outport sockets))
+			   nameservers)))
+	(let* ((nameservers
+		(let loop ((sockets sockets)
+			   (nss nameservers))
+		  (cond 
+		   ((or (null? sockets) (null? nss)) '())
+		   ((socket? (car sockets))
+		    (cons (car nss) (loop (cdr sockets) (cdr nss))))
+		   (else (loop (cdr sockets) (cdr nss))))))
+
+	       (sockets (filter socket? sockets))
+	       (ws (map socket:outport sockets))
 	       (wport-nameserver-alist (map cons ws nameservers))
 	       (wport-socket-alist (map cons ws sockets)))
 	  (dynamic-wind
@@ -1240,6 +1256,99 @@
 	(dns-error 'no-nameservers)
 	(car ns))))
 
+;; checks if the nameservers are working, prints a summary
+(define (dns-check-nameservers . args)
+  (let* ((print-summary
+	  (lambda (working-channels non-working-channels)
+	    (for-each (lambda (channel)
+		       (display "FAIL: ")(display channel)
+		       (display " - host not reachable.")(newline))
+		     non-working-channels)
+	    (for-each (lambda (channel)
+		       (display "PASS: ")(display channel)
+		       (display " - connection established.")(newline))
+		     working-channels)
+	    (if (null? working-channels)
+		(begin (display "ERROR: no working nameserver found.")(newline)))))
+
+	 (nameservers (if (null? args)
+			  (dns-find-nameserver-list)
+			  (car args)))
+	 (sockets  (map
+		    (lambda (nameserver)
+		      (let ((sock (create-socket protocol-family/internet
+						 socket-type/stream))
+			    (addr (internet-address->socket-address
+				   (ip-string->address32 nameserver) 53)))
+			(call-with-current-continuation
+			 (lambda (k)
+			   (with-handler (lambda (cond more)
+					   (display "FAIL: ")
+					   (display nameserver)
+					   (display " - no DNS Service available.")
+					   (newline)
+					   (k #f))
+					 (lambda ()
+					   (connect-socket-no-wait sock addr)
+					   sock))))))
+		    nameservers)))
+    
+    (let* ((nameservers
+	    (let loop ((sockets sockets)
+		       (nss nameservers))
+	      (cond 
+	       ((or (null? sockets) (null? nss)) '())
+	       ((socket? (car sockets))
+		(cons (car nss) (loop (cdr sockets) (cdr nss))))
+	       (else (loop (cdr sockets) (cdr nss))))))
+
+	   (sockets (filter socket? sockets))
+	   (ws (map socket:outport sockets))
+	   (wport-nameserver-alist (map cons ws nameservers))
+	   (wport-socket-alist (map cons ws sockets)))
+      (dynamic-wind
+       (lambda () 
+	 'nothing-to-be-done-before)
+       (lambda ()
+	 (let loop-port-channels ((working-channels '())
+				  (non-working-channels '())
+				  (tried-channels '())
+				  (number-tries 1))
+	   (letrec ((delete-list
+		     (lambda (elems list)
+		       (cond
+			((null? elems) list)
+			((null? list) '())
+			(else (delete-list (cdr elems) (delete (car elems) list))))))
+		    (ready (delete-list tried-channels
+				   (apply select-port-channels *timeout* ws))))
+
+	     (if (or (>= number-tries *max-tries*))
+		 (print-summary working-channels 
+				(delete-list working-channels 
+					     (delete-list non-working-channels 
+							  nameservers)))
+		 (let loop-ready-channels ((working-channels working-channels)
+					   (non-working-channels non-working-channels)
+					   (ready-channels ready))
+		   (if (null? ready-channels)
+		       (loop-port-channels working-channels
+					   non-working-channels
+					   (append tried-channels ready)
+					   (+ number-tries 1))
+		       (let* ((w (car ready-channels))
+			      (hit-ns (cdr (assoc w wport-nameserver-alist)))
+			      (sock (cdr (assoc w wport-socket-alist))))
+			 (if (connect-socket-successful? sock)
+			     (loop-ready-channels (append working-channels (list hit-ns))
+						  non-working-channels (cdr ready-channels))
+			     (loop-ready-channels working-channels
+						  (append non-working-channels 
+							  (list hit-ns))
+						  (cdr ready-channels))))))))))
+       (lambda ()
+	 (for-each close-socket sockets))))))
+
 
 ;; computes the nameservers argument of the lookup functions.
 ;; if a nameserver-name is given and not a nameserver-ip
diff --git a/scheme/packages.scm b/scheme/packages.scm
index b083ef3..326c0f2 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -155,6 +155,7 @@
 	  ip-string->address32		; converts a ip-string in an address32
 	  dns-find-nameserver		; returns a nameserver
 	  dns-find-nameserver-list	; returns a list of nameservers
+	  dns-check-nameservers         ; checks for working nameservers
 	  socket-address->fqdn
 	  host-fqdn
 	  system-fqdn))