added concurrent-lookup, made some minor changes

dns.scm

@@ -6,27 +6,31 @@
 ; based on the PLT-implementation.
 ; 
 ;
-; TODO: - !!! CHECK-ANSWER !!! 
+; TODO: -*!!! CHECK-ANSWER !!! 
-;         (wrong: if check-answer is not successfull, bad hostname is returned)
+;        *(wrong: if check-answer is not successfull, bad hostname is returned)
+;        *solution: error conditions -> if thrown, return #f
 ;       - test, test, test
 ;       - types from newer RFCs (41)
 ;       - UDP: truncation check
-;       - error conditions
+;       -*error conditions
-;       - better interface (found or #f)
+;       -*better interface (found or #f)
 ;       - additional type-a processing: force-ip
 ;       - check-answer for each type
+;               mx: rfc2821
 ;       - more documentation
 ;
 ;
 ; sample usage:
 ;
-;  (dns-lookup-name <name>) --> <ip>
+;  (dns-lookup-name <name> [nameserver]) --> <ip>
-;  (dns-lookup-ip <ip>) --> <name>
+;  (dns-lookup-ip <ip> [nameserver]) --> <name>
-;  (dns-lookup-nameserver <name>) --> <authoritative nameserver>
+;  (dns-lookup-nameserver <name> [nameserver]) --> <ip of authoritative nameserver>
-;  (dns-lookup-mail-exchanger <name>) --> <mail-exchanger>
+;  (dns-lookup-mail-exchanger <name> [nameserver]) --> <mail-exchanger>
 ;   
-;  (dns-lookup <name/ip> <type>) --> <dns-message>
+;  (dns-lookup <name/ip> <type> [nameserver]) --> <dns-message>
 ;  (show-dns-message <dns-message) --> the whole message, human readable
+;
+;  (concurrent-lookup <dns-lookup-*> <name>)
 
 
 
@@ -259,9 +263,9 @@
 (define (make-octet-question name type class)
   (if *debug* (display "make-octet-question\n"))
   (if (not (assoc type types))
-      (error "make-octet-question: invalid DNS query type ~a" type))
+      (error "make-octet-question: invalid DNS query type ~A" type))
   (if (not (assoc class classes))
-      (error "make-octet-question: invalid DNS query class ~a" class))
+      (error "make-octet-question: invalid DNS query class ~A" class))
 
   (let* ((qname   (name->octets name))
 	 (qtype   (number->octet-pair (cadr (assoc type types))))
@@ -600,7 +604,7 @@
   ;; Check for error code:
   (let ((rcode (flags:rcode (parse-flags reply))))
     (if (not (zero? 0));rcode))
-	(error "send-receive-message: error from server: ~a"
+	(error "send-receive-message: error from server: ~A"
 	       (case rcode
 		 ((1) "format error")
 		 ((2) "server failure")
@@ -742,12 +746,13 @@
 (define (dns-get-information question use-cache? protocol nameserver check-answer)
   (if *debug* (display "dns-get-information\n"))
   (letrec ((tried (list nameserver))
-	   ;; with every (also unanswerd) requests authoritative nameservers are send back
+	   ;; with every (even unanswerd) requests authoritative nameservers are sent back
 	   ;; try-recursive tries to get information from these nameservers
 	   (try-recursive
 	    (lambda (auth? nss)
-	      (if (or auth? (null? nss))
+	      (if (or auth? (null? nss)) 
-		  (error "dns-get-information: bad address ~a" (question:name (car (message:questions (parse question)))))
+		  (error "dns-get-information: bad address (in combination with query-type)" 
+			 (question:name (car (message:questions (parse question)))))
 		  (let* ((ns (and (eq? (rr:type (car nss)) 'a) (ip->string (rr:data (car nss)))))
 			 (dns-msg (if (and ns
 					   (not (member ns tried))
@@ -765,7 +770,8 @@
 		    (let ((auth? (not (zero? (flags:auth (header:flags (message:header (dns-message:reply dns-msg)))))))
 			  ;; other nameservers names are found in the nameserver-part,
 			  ;; but their ip-adresses are found in the additonal-rrs
-			  (other-nameservers (message:additionals (dns-message:reply dns-msg))))
+			  (other-nameservers (filter (lambda (elem) (eq? (rr:type elem) 'a))
+						     (message:additionals (dns-message:reply dns-msg)))))
 		      (try-recursive auth? other-nameservers)))))))
     (check-success (dns-query/cache question use-cache? protocol nameserver tried))))
 
@@ -795,33 +801,137 @@
 	(car ns))))
 
 
-;; 
+
-(define (dns-lookup name type)
+;; lookup-queue record for concurrent-lookup
+(define-record lookup-queue
+  lock
+  cond-lock
+  queue)
+
+;; Lock-Conditions
+(define-record lock-condition
+  lock
+  waiting-locks)
+
+(define (wait-lock-condition lock-cond)
+  (let ((waiting-lock (make-lock)))
+    (obtain-lock waiting-lock)
+    (set-lock-condition:waiting-locks
+     lock-cond
+     (cons waiting-lock
+	   (lock-condition:waiting-locks lock-cond)))
+    (let ((lock (lock-condition:lock lock-cond)))
+      (release-lock lock)
+      (obtain-lock waiting-lock)
+      (obtain-lock lock))))
+
+(define (signal-lock-condition lock-cond)
+  (let ((waiting-locks (lock-condition:waiting-locks lock-cond)))
+    (if (not (null? waiting-locks))
+	(begin
+	  (set-lock-condition:waiting-locks lock-cond
+					     (cdr waiting-locks))
+	  (release-lock (car waiting-locks))))))
+
+(define (broadcast-lock-condition lock-cond)
+  (let ((waiting-locks (lock-condition:waiting-locks lock-cond)))
+    (set-lock-condition:waiting-locks lock-cond '())
+    (let loop ((waiting-locks waiting-locks))
+      (if (not (null? waiting-locks))
+	  (begin
+	    (release-lock (car waiting-locks))
+	    (loop (cdr waiting-locks)))))))
+
+;; with-lock
+(define (with-lock lock thunk)
+  (obtain-lock lock)
+  (let ((value (thunk)))
+    (release-lock lock)
+    value))
+
+
+;; concurrent-lookup
+;; starts a <lookup>-lookup to all nameservers in (dns-find-nameserver-list)
+(define (concurrent-lookup lookup name)
+  (let* ((return 'not-terminated-yet)
+	 (lock (make-lock))
+	 (ccl (make-lookup-queue lock (make-lock-condition lock '()) (make-queue))))
+
+    (spawn
+     (lambda ()
+       (display "consumer started \n")
+       (with-lock lock 
+		  (lambda ()
+		    (let loop ()
+		      (let ((queue (lookup-queue:queue ccl)))
+			(if (queue-empty? queue)
+			    (begin
+			      (wait-lock-condition (lookup-queue:cond-lock ccl))
+			      (loop))
+			    (let ((value (dequeue! queue)))
+			      (set! return value)
+			      value))))))))
+    (spawn (lambda ()
+    (for-each (lambda (nameserver)
+		(spawn
+		 (lambda ()
+		   (display nameserver)(display "  started\n")
+		   (with-lock lock
+			      (lambda ()
+				(let* ((result (apply lookup (list name nameserver))))
+				  (enqueue! (lookup-queue:queue ccl) result)
+				  (display nameserver)(display "  ")(display result)(newline)
+				  (broadcast-lock-condition (lookup-queue:cond-lock ccl))))))))
+	      (dns-find-nameserver-list))))
+
+;; ### active waiting ?
+    (let loop ()
+      (if (not (eq? return 'not-terminated-yet))
+	  return
+	  (loop)))))
+		       
+;; checks the arguments of the dns-lookup-* functions.
+;; if a nameserver-name is given and not a nameserver-ip
+;; (dns-lookup-name nameserver) is called.
+(define (check-args args)
+  (if (null? args) 
+      (dns-find-nameserver) 
+      (let ((nameserver (car args)))
+	(if (ip? nameserver)
+	    nameserver
+	    (dns-lookup-name nameserver)))))
+
+
+;; dns-lookup with more options than dns-lookup-*
+;; optional: nameserver could be passed to the function.
+(define (dns-lookup name type . args)
   (let* ((ip-string (ip-string->in-addr name))
 	 (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 		       (make-octet-query-message (random 256) ip-string type 'in)
 		       (make-octet-query-message (random 256) name type 'in)))
 	 (use-cache? #t)
 	 (protocol 'udp)
-	 (nameserver (dns-find-nameserver))
+	 (nameserver (check-args args))
 	 (check-answer (lambda (dns-msg) #t))
 	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
 	 (answers (message:answers (dns-message:reply dns-msg))))
     (if (not (null? answers))
 	(for-each (lambda (x) (show-dns-message x)(newline)) answers)
-	(display "sorry, no answers received\n"))
+	(display "no answers received - but resolved information in other sections.\n"))
     dns-msg))
 
 
-;; looks up a hostname, returns an ip
+
-(define (dns-lookup-name name)
+;; looks up a hostname, returns an ip.
+;; (dns-lookup-name <name> [nameserver])
+(define (dns-lookup-name name . args)
   (let* ((ip-string (ip-string->in-addr name))
 	 (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 		       (error "dns-lookup-name: no valid hostname, suppose it is an ip")
 		       (make-octet-query-message (random 256) name 'a 'in)))
 	 (use-cache? #t)
 	 (protocol 'udp)
-	 (nameserver (dns-find-nameserver))
+	 (nameserver (check-args args))
 	 (valid-answers (lambda (answer)
 			  (filter (lambda (ans)
 				    (eq? (rr:type ans) 'a))
@@ -836,14 +946,15 @@
 
 
 ;; looks up an ip, returns a hostname
-(define (dns-inverse-lookup ip)
+;; (dns-inverse-lookup <name> [nameserver])
+(define (dns-inverse-lookup ip . args)
   (let* ((ip-string (ip-string->in-addr ip))
 	 (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 		       (make-octet-query-message (random 256) ip-string 'ptr 'in)
 		       (error "dns-inverse-lookup: no valid ip")))
 	 (use-cache? #t)
 	 (protocol 'udp)
-	 (nameserver (dns-find-nameserver))
+	 (nameserver (check-args args))
 	 (valid-answers (lambda (answers) 
 			  (filter (lambda (ans) 
 				    (eq? (rr:type ans) 'ptr))
@@ -861,14 +972,15 @@
 
 ;; looks up an authoritative nameserver for a hostname
 ;; returns a nameserver
-(define (dns-lookup-nameserver name)
+;; (dns-lookup-nameserver <name> [nameserver])
+(define (dns-lookup-nameserver name . args)
   (let* ((ip-string (ip-string->in-addr name))
 	 (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 		       (error "dns-lookup-name: no valid hostname, suppose it is an ip")
 		       (make-octet-query-message (random 256) name 'ns 'in)))
 	 (use-cache? #t)
 	 (protocol 'tcp)
-	 (nameserver (dns-find-nameserver))
+	 (nameserver (check-args args))
 	 (valid-nameservers (lambda (nameservers)
 			  (filter (lambda (ns)
 				    (eq? (rr:type ns) 'soa))
@@ -879,7 +991,7 @@
 			(not (null? (valid-nameservers nameservers))))))
 	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
 	 (nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg)))))
-    (rr-data-soa:mname (rr:data (car nameservers)))))
+    (dns-lookup-name (rr-data-soa:mname (rr:data (car nameservers))))))
 
 
 
@@ -887,15 +999,16 @@
 ;; returns a mail-exchanger
 ;; if there are no mx-records in the answer-section, 
 ;; the rname of the soa-record is returned.
+;; (dns-lookup-mail-exchanger <name> [nameserver])
 ;; ### CHECK RFC2821
-(define (dns-lookup-mail-exchanger name)
+(define (dns-lookup-mail-exchanger name . args)
   (let* ((ip-string (ip-string->in-addr name))
 	 (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 		       (error "dns-lookup-name: no valid hostname, suppose it is an ip")
 		       (make-octet-query-message (random 256) name 'mx 'in)))
 	 (use-cache? #t)
 	 (protocol 'tcp)
-	 (nameserver (dns-find-nameserver))
+	 (nameserver (check-args args))
 	 (valid-answers (lambda (answers)
 			  (filter (lambda (answer)
 				    (eq? (rr:type answer) 'mx))

modules.scm

@@ -778,6 +778,7 @@
 	  dns-lookup-ip
 	  dns-lookup-nameserver
 	  dns-lookup-mail-exchanger
+	  concurrent-lookup
 	  show-dns-message
 	  dns-find-nameserver
 	  dns-find-nameserver-list))
@@ -791,5 +792,8 @@
 	formats
 	signals
 	defrec-package
-	random)
+	random
+	queues
+	threads
+	locks)
   (files dns))