Start of rewrite using select.

scheme/lib/dns.scm

@@ -805,12 +805,13 @@
 ;; #t if message is truncated (could happen via UDP)
 (define (truncated? reply)
   (let ((trunc (flags:trunc (parse-flags reply))))
-    trunc))
+    (= trunc 1)))
 
 
 ;; connects to nameserver and sends and receives messages. returns the reply.
 ;; here: via TCP
 (define (send-receive-message-tcp nameserver question)
+  (error "tcp doesn't work yet")
   (if *debug* (display "send-receive-message\n"))
   (let* ((query question)
 	 (reply
@@ -839,29 +840,37 @@
     (parse reply)))
 
 ;; here: via UDP
-(define (send-receive-message-udp nameserver question)
+(define (send-receive-message-udp nameservers question)
   (if *debug* (display "send-receive-message\n"))
   (let* ((query question)
 	 (reply
-	  (let ((socket (socket-connect protocol-family/internet
+	  (let ((sockets (map (lambda (nameserver)
+				(socket-connect protocol-family/internet
 						socket-type/datagram
-					nameserver 53)))
+						nameserver 53))
-	    (let ((r (socket:inport socket))
+			      nameservers)))
-		  (w (socket:outport socket)))
+	    (let ((rs (map socket:inport sockets))
+		  (ws (map socket:outport sockets)))
 	      (dynamic-wind
 	       (lambda ()
 		 'nothing-to-be-done-before)
 	       (lambda ()
-		 (display (list->string query) w)
+		 (let ((query-string (list->string query))
-		 (force-output w)
+		       (rsv (list->vector rs)))
-		 (let ((s (read-string/partial 512 r))) ; 512 is the maximum udp-message size
+		   (for-each (lambda (w) (display query-string w)) ws)
-		   (string->list s)))
+		   (for-each force-output ws)
+		   (receive (read-ready ignore-w ignore-e)
+		       (select rsv '#() '#())
+		     (let ((r (vector-ref read-ready 0)))
+		       (string->list (read-string/partial 512 r)))))) ; 512 is the maximum udp-message size
 	       (lambda ()
-		 (close-socket socket)))))))
+		 (for-each close-socket sockets)))))))
 	  (reply-acceptable? reply query)
 	  (if (truncated? reply)
-	(send-receive-message-tcp nameserver question)
+	      (send-receive-message-tcp nameservers question)
-	(parse reply))))
+	      (values (parse reply)
+		      (car nameservers); kludge
+		      '(kludge)))))
 
 
 ;;; -- cache
@@ -895,44 +904,67 @@
 		      (set! minimum (rr:ttl dns-msg))))))))))
     (find-shortest-ttl-1 dns-msg)))
 
-;; makes a dns-query. optional cache-check. 
+
-;; returns a dns-message with cache-flag and either cache-data or new received data.
+(define (make-key qds nameserver)
-(define (dns-query/cache question use-cache? protocol nameserver tried)
+  (let*;; cache-key relevant data
-  (if *debug* (display "dns-query/cache\n"))
+      ((name (question:name (car qds)))
-  (let ((send-receive-message 
-	 (cond 
-	  ((eq? protocol 'tcp) send-receive-message-tcp)
-	  ((eq? protocol 'udp) send-receive-message-udp))))
-    (let ((dns-query 
-	   (lambda () 
-	     (if *debug* (display "dns-query/cache:dns-query\n"))
-	     ;; returns new retrieved data
-	     (make-dns-message (parse question) (send-receive-message nameserver question) #f protocol (reverse tried)))) 
-	  (dns-query-with-cache 
-	   (lambda ()
-	     (if *debug* (display "dns-query/cache:dns-query-with-cache\n"))
-	     (let* ((qds (message:questions (parse question)))
-		    ;; cache-key relevant data
-		    (name (question:name (car qds)))
        (type (question:type (car qds)))
-		    (class (question:class (car qds)))
+       (class (question:class (car qds))))
-		    (key (format #f "~a;~a;~a;~a" nameserver name type class))
+    (format #f "~a;~a;~a;~a" nameserver name type class)))
+
+(define (lookup-cache qds nameserver)
+  (let* ((key (make-key qds nameserver))
 	 (found-data (table-ref cache key)))
     (cond
      ((and found-data
 	   ;; checks if cached-data is still valid
 	   (< (time) (+ (cache:time found-data) (cache:ttl found-data))))
-		 ;; returns cached data
+      found-data)
-		 (make-dns-message (parse question) (cache:answer found-data) #t protocol (reverse tried)))
+     (else #f))))
-		(else 
+
-		 (let ((reply-msg (send-receive-message nameserver question)))
+(define (update-cache! key entry)
-		   (if *debug* (display "write to cache\n"))
+  (table-set! cache key entry))
-		   (table-set! cache key (make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
+
+(define (dns-query-no-cache question protocol nameservers tried)
+	 ;; returns new retrieved data
+	 (receive (dns-msg hit-ns nss-with-no-reply)
+	     (send-receive-message nameservers question protocol)
+	   (values 
+	    (make-dns-message (parse question) dns-msg  #f protocol (reverse tried))
+	    hit-ns
+	    nss-with-no-reply))))
+
+(define (dns-query-with-cache question protocol nameservers tried)
+  (let ((qds (message:questions (parse question))))
+    (let lp ((ns nameservers))
+      (if (null? ns)
+	  (receive (reply-msg hit-ns nss-with-no-reply)
+	      (send-receive-message nameservers question protocol)
+	    (update-cache! (make-key qds hit-ns) (make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
 	    ;; returns new retrieved data and updates cache
-		   (make-dns-message (parse question) reply-msg #f protocol (reverse tried))))))))) 
+	    (values (make-dns-message (parse question) reply-msg #f protocol (reverse tried))
+		    hit-ns
+		    nss-with-no-reply))
+	  (cond ((lookup-cache qds (car ns))
+		 => (lambda (found-data)
+		      ;; returns cached data
+		      (values (make-dns-message (parse question) (cache:answer found-data) #t protocol '())
+			      #f
+			      nameservers)))
+		(else (lp (cdr ns))))))))
+
+(define (send-receive-message nameservers question protocol)
+  ((cond 
+    ((eq? protocol 'tcp) send-receive-message-tcp)
+    ((eq? protocol 'udp) send-receive-message-udp))
+   nameservers question))
+  
+;; makes a dns-query. optional cache-check. 
+;; returns a dns-message with cache-flag and either cache-data or new received data.
+(define (dns-query/cache question use-cache? protocol nameservers tried)
       (if use-cache?
-	  (dns-query-with-cache)
+	  (dns-query-with-cache question protocol nameservers tried)
-	  (dns-query)))))
+	  (dns-query-no-cache question protocol nameservers tried)))
 
 ;; dns and recursion
 ;;  recursion means, if the demanded information is not available from the
@@ -941,38 +973,29 @@
 ;;  this feature is technically optional (RFC 1035).
 ;;  dns-get-information implements the resovler-side recursion.
 ;;  it returns a dns-message
-(define (dns-get-information question use-cache? protocol nameserver check-answer)
+(define (dns-get-information question use-cache? protocol nameservers check-answer)
   (if *debug* (display "dns-get-information\n"))
-  (letrec ((tried (list nameserver))
+  (let lp ((tried '()) (nss nameservers))
-	   ;; with every (even unanswerd) requests authoritative nameservers are sent back
+    (if (null? nss)
-	   ;; try-recursive tries to get information from these nameservers
-	   (try-recursive
-	    (lambda (auth? nss)
-	      (if (or auth? (null? nss)) 
 	(signal 'bad-address)
-		  (let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss)))))
+	(receive (dns-msg hit-ns nss-with-no-reply)
-			 (dns-msg (if (and ns
+	    (dns-query/cache question use-cache? protocol nss tried)
-					   (not (member ns tried))
-					   (set! tried (cons ns tried)))
-				      (dns-query/cache question use-cache? protocol ns tried)
-				      (try-recursive auth? (cdr nss)))))
-		    (check-success dns-msg)))))
-	   ;; checks if the answer is useful. returns a dns-message.
-	   (check-success
-	    (lambda (dns-msg)
 	  (if *debug* (display "dns-get-information:check-success\n"))
-	      (let ((useful-answer? (check-answer dns-msg)))
+	  (if (check-answer dns-msg)
-		(if useful-answer?
 	      dns-msg
-		    (let ((auth? (not (zero? (flags:auth (header:flags (message:header (dns-message:reply dns-msg)))))))
+	      (let ((auth? (not (zero? (flags:auth (header:flags 
+						    (message:header (dns-message:reply dns-msg))))))))
+		(if auth?
+		    (signal 'bad-address)
 		    ;; other nameservers names are found in the nameserver-part,
 		    ;; but their ip-adresses are found in the additonal-rrs
-			  (other-nameservers (filter (lambda (elem) (eq? (rr:type elem) 'a))
+		    (let ((other-nameservers 
+			   (filter (lambda (elem) (eq? (rr:type elem) 'a))
 				   (message:additionals (dns-message:reply dns-msg)))))
-		      (try-recursive auth? other-nameservers)))))))
+		      (lp (if (not (member hit-ns tried)) (cons hit-ns tried) tried)
-    (check-success (dns-query/cache question use-cache? protocol nameserver tried))))
+			  (lset-union equal?
-
+				      nss-with-no-reply
-
+				      (lset-difference equal? other-nameservers tried)))))))))))
 
 ;; parses the resolv.conf file and returns a list of found nameserver
 (define (dns-find-nameserver-list)
@@ -1085,8 +1108,8 @@
 	    (simple-lookup-function name (car args))))))
 
 ;; looks up a hostname, returns an ip.
-;; (dns-lookup-name <name> [nameserver])
+;; (dns-lookup-name <name> nameservers)
-(define (dns-simple-lookup-name name . args)
+(define (dns-simple-lookup-name name nameservers)
   (call-with-current-continuation
    (lambda (exit)
      (with-handler
@@ -1102,12 +1125,11 @@
 			     (make-octet-query-message (random 256) name 'a 'in)))
 	       (use-cache? #t)
 	       (protocol 'udp)
-	       (nameserver (check-args args))
 	       (check-answer (lambda (dns-msg) 
 			       (let* ((reply (dns-message:reply dns-msg))
 				      (answers (message:answers reply)))
 				 (not (null? (filter-type answers 'a))))))
-	       (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
+	       (dns-msg (dns-get-information question use-cache? protocol nameservers check-answer))
 	       (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
 	  (rr-data-a:ip (rr:data (car answers)))))))))