dns-lookup-nameserver revised,

dns-lookup-mailexchanger now implements RFC 2821,
added force-ip and force-ip-list.

dns.scm

@@ -10,13 +10,9 @@
 ;        *(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)
+;       - types from newer RFCs (41, unknown)
-;       - UDP: truncation check
 ;       -*error conditions
 ;       -*better interface (found or #f)
-;       - additional type-a processing: force-ip
-;       - check-answer for each type
-;               mx: rfc2821
 ;       - more documentation
 ;
 ;
@@ -24,13 +20,21 @@
 ;
 ;  (dns-lookup-name <name> [nameserver]) --> <ip>
 ;  (dns-lookup-ip <ip> [nameserver]) --> <name>
-;  (dns-lookup-nameserver <name> [nameserver]) --> <ip of authoritative nameserver>
+;  (dns-lookup-nameserver <name> [nameserver]) --> <list of ips of authoritative nameservers>
-;  (dns-lookup-mail-exchanger <name> [nameserver]) --> <mail-exchanger>
+;  (dns-lookup-mail-exchanger <name> [nameserver]) --> <list of names of mail-exchangers>
 ;   
 ;  (dns-lookup <name/ip> <type> [nameserver]) --> <dns-message>
 ;  (show-dns-message <dns-message) --> the whole message, human readable
 ;
 ;  (concurrent-lookup <dns-lookup-*> <name>)
+;
+;  some lookups return a hostname (e.g. mx). 
+;  many applications need instead of a hostname a ip address.
+;  force-ip and force-ip-list guarantee that a ip address is
+;  returned.
+;
+;  (force-ip <name>) --> <ip>
+;  (force-ip-list <list of names>) --> <list of ips>
 
 
 
@@ -48,7 +52,8 @@
 
 ;; message types
 (define types
-  '((a 1)      ; a host address 
+  '((unknown 0); types, which are not yet implemented
+    (a 1)      ; a host address 
     (ns 2)     ; an authoritative name server
     (md 3)     ; (obsolete)
     (mf 4)     ; (obsolete)
@@ -61,7 +66,7 @@
     (wks 11)   ; a well known service description
     (ptr 12)   ; a domain name pointer
     (hinfo 13) ; host information
-    (minfo 14) ; mailbox or mail list information
+    (minfo 14) ; (experimental)
     (mx 15)    ; mail exchange
     (txt 16))) ; text strings
 
@@ -79,7 +84,7 @@
 (define (cossa i l)
   (if *debug* (display "cossa\n"))
   (cond
-   ((null? l) (error "dns-message: type not implemented: " i))
+   ((null? l) 'unknown) ;;(error "dns-message: type not implemented: " i))
    ((equal? (cadar l) i)
     (car l))
    (else (cossa i (cdr l)))))
@@ -211,6 +216,30 @@
 	     (= count 3)
 	     (string-append s "." result "in-addr.arpa")))))))
 
+;; filters types in a list of rrs 
+(define (filter-type list type)
+  (if *debug* (display "ip-string->in-addr\n"))
+  (filter (lambda (rr) 
+	    (eq? (rr:type rr) type))
+	  list))
+
+;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger.
+(define (sort-by-preference mx-list)
+  (sort-list mx-list 
+	     (lambda (a b) 
+	       (< (rr-data-mx:preference (rr:data a)) (rr-data-mx:preference (rr:data b))))))
+
+
+;; returns a IP if available (additonal type-a processing)
+(define (force-ip name)
+  (let loop ((result (dns-lookup-name name)))
+    (if (ip? result)
+	result
+	(loop (dns-lookup-name result)))))
+
+;; returns a list of IPs (additional type-a processing)
+(define (force-ip-list names)
+  (map (lambda (elem) (force-ip elem)) names))
 
 
 ;;; -- message constructors: encode to octet-messages
@@ -439,10 +468,7 @@
   name)
 
 ;; ###
-;; hinfo not correctly implemented: 
+;; hinfo not correctly implemented, trying to find examples 
-;; don't know how the fields in this record, haven't found any example yet
-;; try (dns-lookup <name> 'hinfo) with several names, if you find a name
-;; which delivers a hinfo-answer, please tell me :-) 
 (define-record rr-data-hinfo  
   data)                       
 
@@ -612,6 +638,12 @@
 		 ((4) "not implemented")
 		 ((5) "refused"))))))
 
+;; #t if message is truncated (could happen via UDP)
+(define (truncated? reply)
+  (let ((trunc (flags:trunc (parse-flags reply))))
+    trunc))
+
+
 ;; connects to nameserver and sends and receives messages. returns the reply.
 ;; here: via TCP
 (define (send-receive-message-tcp nameserver question)
@@ -663,7 +695,9 @@
 	       (lambda ()
 		 (close-socket socket)))))))
     (reply-acceptable? reply query)
-    (parse reply)))
+    (if (truncated? reply)
+	(send-receive-message-tcp nameserver question)
+	(parse reply))))
 
 
 ;;; -- cache
@@ -753,7 +787,7 @@
 	      (if (or auth? (null? nss)) 
 		  (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)))))
+		  (let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss)))))
 			 (dns-msg (if (and ns
 					   (not (member ns tried))
 					   (set! tried (cons ns tried)))
@@ -812,21 +846,19 @@
 	 (queue (make-queue))
 	 (nameserver-list (dns-find-nameserver-list)))
 
-
     (obtain-lock lock)
 
     (spawn (lambda ()
 	     (for-each (lambda (nameserver)
 			 (spawn
 			  (lambda ()
-			    (display nameserver)(display "  started\n")
+			    (display "query sent to ")(display nameserver)(display " \n")
 			    (let* ((result (apply lookup (list name nameserver))))
 			      (enqueue! queue result)
-			      (display nameserver)(display "  ")(display result)(newline)
+			      (display "received reply from ")(display nameserver)(display ": ")(display result)(newline)
 			      (release-lock lock)))))
 	     (dns-find-nameserver-list))))
 
-    (display "Consumer started\n")
     (let loop ((count (length nameserver-list)))
       (obtain-lock lock)
       (let ((result (dequeue! queue)))
@@ -876,16 +908,12 @@
 	 (use-cache? #t)
 	 (protocol 'udp)
 	 (nameserver (check-args args))
-	 (valid-answers (lambda (answer)
-			  (filter (lambda (ans)
-				    (eq? (rr:type ans) 'a))
-				  answer)))
 	 (check-answer (lambda (dns-msg) 
 			(let* ((reply (dns-message:reply dns-msg))
 			       (answers (message:answers reply)))
-			(not (null? (valid-answers answers))))))
+			(not (null? (filter-type answers 'a))))))
 	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
-	 (answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
+	 (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
     (rr-data-a:ip (rr:data (car answers)))))
 
 
@@ -899,23 +927,19 @@
 	 (use-cache? #t)
 	 (protocol 'udp)
 	 (nameserver (check-args args))
-	 (valid-answers (lambda (answers) 
-			  (filter (lambda (ans) 
-				    (eq? (rr:type ans) 'ptr))
-				  answers)))
 	 (check-answer (lambda (dns-msg) 
 			 (let* ((reply (dns-message:reply dns-msg))
 				(answers (message:answers reply)))
-			   (not (null? (valid-answers answers))))))
+			   (not (null? (filter-type answers 'ptr))))))
 	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
-	 (answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
+	 (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
     (rr-data-ptr:name (rr:data (car answers)))))
 
 (define dns-lookup-ip dns-inverse-lookup)
 
 
 ;; looks up an authoritative nameserver for a hostname
-;; returns a nameserver
+;; returns a list of nameservers
 ;; (dns-lookup-nameserver <name> [nameserver])
 (define (dns-lookup-nameserver name . args)
   (let* ((ip-string (ip-string->in-addr name))
@@ -923,28 +947,29 @@
 		       (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)
+	 (protocol 'udp)
 	 (nameserver (check-args args))
-	 (valid-nameservers (lambda (nameservers)
-			  (filter (lambda (ns)
-				    (eq? (rr:type ns) 'soa))
-				  nameservers)))
 	 (check-answer (lambda (dns-msg) 
 			(let* ((reply (dns-message:reply dns-msg))
+			       (answers (message:answers reply))
 			       (nameservers (message:nameservers reply)))
-			(not (null? (valid-nameservers nameservers))))))
+			  (or (not (null? (filter-type nameservers 'soa)))
+			      (not (null? (filter-type answers 'ns)))))))
 	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
-	 (nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg)))))
+	 (reply (dns-message:reply dns-msg))
-    (dns-lookup-name (rr-data-soa:mname (rr:data (car nameservers))))))
+	 (soa (filter-type (message:nameservers reply) 'soa))
-
+	 (nss (filter-type (message:answers reply) 'ns))
+	 (add (filter-type (message:additionals reply) 'a)))
+    (if (null? nss)
+	(list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa)))))
+	(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))
 
 
 ;; looks up a mail-exchanger for a hostname.
-;; returns a mail-exchanger
+;; returns a list of mail-exchanger, sorted by their preference
 ;; if there are no mx-records in the answer-section, 
-;; the rname of the soa-record is returned.
+;; implementation based on RFC2821
 ;; (dns-lookup-mail-exchanger <name> [nameserver])
-;; ### CHECK RFC2821
 (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
@@ -953,36 +978,29 @@
 	 (use-cache? #t)
 	 (protocol 'tcp)
 	 (nameserver (check-args args))
-	 (valid-answers (lambda (answers)
-			  (filter (lambda (answer)
-				    (eq? (rr:type answer) 'mx))
-				  answers)))
-	 (valid-nameservers (lambda (nameservers)
-			      (filter (lambda (ns)
-					(eq? (rr:type ns) 'soa))
-				      nameservers)))
 	 (check-answer (lambda (dns-msg) 
 			(let* ((reply (dns-message:reply dns-msg))
 			       (answers (message:answers reply))
 			       (nameservers (message:nameservers reply)))
-			  (or (not (null? (valid-answers answers)))
+			  (or (not (null? (filter-type answers 'mx)))
-			      (not (null? (valid-nameservers nameservers)))))))
+			      (not (null? (filter-type answers 'cname)))
+			      (not (null? (filter-type answers 'a)))))))
 	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
-	 (answers (valid-answers (message:answers (dns-message:reply dns-msg))))
+	 (reply (dns-message:reply dns-msg))
-	 (nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg)))))
+	 (mx (filter-type (message:answers reply) 'mx))
-
+	 (soa (filter-type (message:nameservers reply) 'soa))
-    (if (null? answers)
+	 (cname (filter-type (message:answers reply) 'cname))
-	(rr-data-soa:rname (rr:data (car nameservers)))
+	 (a (filter-type (message:answers reply) 'a)))
-	(let loop ((answers (cdr answers))
-		   (preference (rr-data-mx:preference (rr:data (car answers))))
-		   (exchanger (rr-data-mx:exchanger (rr:data (car answers)))))
-	  (if (null? answers)
-	      exchanger
-	      (let ((new-preference (rr-data-mx:preference (rr:data (car answers)))))
-		(if (<= preference new-preference)
-		    (loop (cdr answers) preference exchanger)
-		    (loop (cdr answers) new-preference (rr-data-mx:exchanger (rr:data (car answers)))))))))))
 
+    (cond
+     ((not (null? a)) 
+      (list (rr-data-a:ip (rr:data (car a)))))
+     ((not (null? cname))
+      (dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname)))))
+     ((null? mx) 
+      (list (rr-data-soa:rname (rr:data (car soa)))))
+     (else
+      (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))
 
 
 

modules.scm

@@ -469,6 +469,8 @@
 	  dns-lookup-mail-exchanger
 	  concurrent-lookup
 	  show-dns-message
+	  force-ip
+	  force-ip-list
 	  dns-find-nameserver
 	  dns-find-nameserver-list))
 
@@ -483,6 +485,7 @@
 	defrec-package
 	random
 	queues
+	sort
 	threads
 	locks)
   (files dns))