fixed bugs related to invalid nameservers:

* added new error signal no-nameserver-given
* modified send-receive-message-* functions:
	- better error handling
	- timeout/maxtries functionality
	- try to contact all nameservers,
	  before error is signaled

scheme/lib/dns.scm

@@ -103,6 +103,9 @@
 (define-condition-type 'no-nameservers '(dns-error))
 (define no-nameservers? (condition-predicate 'no-nameservers))
 
+(define-condition-type 'no-nameserver-given '(dns-error))
+(define no-nameserver-given? (condition-predicate 'no-nameserver-given))
+
 (define-condition-type 'bad-nameserver '(dns-error))
 (define bad-nameserver? (condition-predicate 'bad-nameserver))
 
@@ -147,8 +150,10 @@
       "dns-get-information: bad address (in combination with query type)")
      ((no-nameservers)
       "dns-find-nameserver: no nameservers found in /etc/resolv.conf")
+     ((no-nameserver-given)
+      "dns-find-nameserver: no nameservers given")
      ((bad-nameserver)
-      "send-receive-message: nameserver refused connection")
+      "send-receive-message: could not establish connection to server (no valid nameserver given)")
      ((not-a-hostname)
       "no hostname given")
      ((not-a-ip)
@@ -767,46 +772,81 @@
     (if (not (eq? response-code 'dns-no-error))
 	(dns-error response-code))))
 
+
+(define *max-tries* 3)
+(define *timeout* 1)
+
 ;; connects to nameserver and sends and receives messages. returns the reply.
 ;; here: via TCP
 (define (send-receive-message-tcp nameservers query)
   (receive (reply hit-ns other-nss)
-      (let ((sockets (map (lambda (nameserver)
+	   (let ((sockets (filter
-			    (let ((sock (create-socket protocol-family/internet
+			   socket?
-						       socket-type/stream))
+			   (map
-				  (addr (internet-address->socket-address
+			   (lambda (nameserver)
-					 nameserver 53)))
+			     (let ((sock (create-socket protocol-family/internet
-			      ;; we ignore the return value and select
+							socket-type/stream))
-			      ;; unconditionally later
+				   (addr (internet-address->socket-address
-			      (connect-socket-no-wait sock addr)
+					  nameserver 53)))
-			      sock))
+			       ;; we ignore the return value and select
-			  nameservers)))
+			       ;; unconditionally later
+			       (call-with-current-continuation
+				(lambda (k)
+				  (with-handler (lambda (cond more)
+						  (k #f))
+						(lambda ()
+						  (connect-socket-no-wait sock addr)
+						  sock))))))
+			   nameservers))))
 	(let* ((ws (map socket:outport sockets))
 	       (wport-nameserver-alist (map cons ws nameservers))
 	       (wport-socket-alist (map cons ws sockets)))
 	  (dynamic-wind
-	   (lambda () #f)
+	   (lambda () 
+	     'nothing-to-be-done-before)
 	   (lambda ()
-	     (let* ((ready-ports (apply select-port-channels #f ws))
+	     (let loop-port-channels ((tried-channels '())
-		    (w (car ready-ports))
+				      (number-tries 1))
-		    (hit-ns (cdr (assoc w wport-nameserver-alist)))
+	       (letrec ((delete-list
-		    (sock (cdr (assoc w wport-socket-alist))))
+			 (lambda (elems list)
-	       (if (not (connect-socket-successful? sock))
+			   (cond
-		   (dns-error 'bad-nameserver hit-ns))
+			    ((null? elems) list)
-	       (let ((query-string  
+			    ((null? list) '())
-		      (list->string (add-size-tag (message-source query))))
+			    (else (delete-list (cdr elems) (delete (car elems) list))))))
-		     (r (socket:inport sock)))
+			(ws-new (delete-list tried-channels ws)))
-		 (display query-string w)
+		 (if (or (null? ws-new) (>= number-tries *max-tries*))
-		 (force-output w)
+		     (dns-error 'bad-nameserver)
-		 (let ((a (read-char r))
+		     (let ((ready (apply select-port-channels *timeout* ws)))
-		       (b (read-char r)))
+		       (if (= (length tried-channels) (length ws))
-		   (let ((len (octet-pair->number a b)))
+			   (dns-error 'bad-nameserver)
-		     (let ((s (read-string len r)))
+			   (let loop-ready-channels ((ready-channels ready))
-		       (if (not (= len (string-length s)))
+			     (if (null? ready-channels)
-			   (dns-error 'unexpected-eof-from-server))
+				 (loop-port-channels (append tried-channels ready) (+ number-tries 1))
-			 (values (parse (string->list s))
+				 (let* ((w (car ready-channels))
-				 hit-ns
+					(hit-ns (cdr (assoc w wport-nameserver-alist)))
-				 (delete hit-ns nameservers))))))))
+					(sock (cdr (assoc w wport-socket-alist))))
+				   (if (not (connect-socket-successful? sock))
+				       (loop-ready-channels (cdr ready-channels))
+				       (let ((query-string  
+					      (list->string (add-size-tag (message-source query))))
+					     (r (socket:inport sock)))
+					 (call-with-current-continuation
+					  (lambda (k)
+					    (with-handler (lambda (k)
+							    (k (loop-ready-channels (cdr ready-channels))))
+							  (lambda ()
+							    (display query-string w)
+							    (force-output w)
+							    (let ((a (read-char r))
+								  (b (read-char r)))
+							      (let ((len (octet-pair->number a b)))
+								(let ((s (read-string len r)))
+								  (if (and (not (= 0 (string-length s))) 
+									   (not (= len (string-length s))))
+								      (dns-error 'unexpected-eof-from-server))
+								  (values (parse (string->list s))
+									  hit-ns
+									  (delete hit-ns nameservers))))))))))))))))))))
 	   (lambda ()
 	     (for-each close-socket sockets)))))
     (reply-acceptable? reply query)
@@ -837,23 +877,42 @@
 		   (rport-socket-alist (map cons rs sockets)))
 	       (for-each (lambda (w) (display query-string w)) ws)
 	       (for-each force-output ws)
-	       (let* ((ready (apply select-port-channels #f rs))
+	       (let loop-port-channels ((tried-channels '())
-		      (r (car ready))
+					(number-tries 1))
-		      (hit-ns (cdr (assoc r rport-nameserver-alist))))
+		 (letrec ((delete-list
-		 (if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist))))
+			   (lambda (elems list)
-		     (dns-error 'bad-nameserver hit-ns))
+			     (cond
-		           ;;; 512 is the maximum udp-message size:
+			      ((null? elems) list)
-		 (values (parse (string->list (read-string/partial 512 r)))
+			      ((null? list) '())
-			 hit-ns
+			      (else (delete-list (cdr elems) (delete (car elems) list))))))
-			 (delete hit-ns nameservers)))))
+			  (rs-new (delete-list tried-channels rs)))
+		   (if (or (null? rs-new) (>= number-tries *max-tries*))
+		       (dns-error 'bad-nameserver)
+		       (let ((ready (apply select-port-channels *timeout* rs-new)))
+			 (if (= (length tried-channels) (length rs))
+			     (dns-error 'bad-nameserver)
+			     (let loop-ready-channels ((ready-channels ready))
+			       (if (null? ready-channels)
+				   (loop-port-channels (append tried-channels ready) (+ number-tries 1))
+				   (let* ((r (car ready-channels))
+					  (hit-ns (cdr (assoc r rport-nameserver-alist))))
+				     (if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist))))
+					 (loop-ready-channels (cdr ready-channels))
+					 ;; 512 is the maximum udp-message size:
+					 (let ((answer (string->list (read-string/partial 512 r))))
+					   (if (null? answer)
+					       (loop-ready-channels (cdr ready-channels))
+					       (values (parse answer)
+						       hit-ns
+						       (delete hit-ns nameservers)))))))))))))))
 	   (lambda ()
 	     (for-each close-socket sockets)))))
-    (reply-acceptable? reply query)
+      (reply-acceptable? reply query)
-    (if (flags-truncated? (header-flags (message-header reply)))
+      (if (flags-truncated? (header-flags (message-header reply)))
-	(send-receive-message-tcp nameservers query)
+	  (send-receive-message-tcp nameservers query)
-	(values reply
+	  (values reply
-		hit-ns
+		  hit-ns
-		other-nss))))
+		  other-nss))))
 
 
 ;;; -- cache
@@ -971,7 +1030,9 @@
   (receive (nameservers use-cache?) (lookup-optional-args args)
     (let lp ((tried '()) (nss nameservers))
       (if (null? nss)
-	  (dns-error 'bad-address)
+	  (if (null? tried)
+	      (dns-error 'no-nameserver-given)
+	      (dns-error 'bad-address))
 	  (receive (dns-msg hit-ns nss-with-no-reply)
 	      (dns-query/cache query use-cache? protocol nss tried)
 	    (if (check-answer dns-msg)