From 831555ba83f264602580de17202da04e3fce49fd Mon Sep 17 00:00:00 2001
From: cresh <cresh>
Date: Sun, 5 May 2002 18:37:50 +0000
Subject: [PATCH] added UDP transportation, made changes in the interface

---
 dns.scm     | 344 ++++++++++++++++++++++++++++++++++++----------------
 modules.scm |   9 +-
 2 files changed, 249 insertions(+), 104 deletions(-)

diff --git a/dns.scm b/dns.scm
index 5447e08..34bdbb4 100644
--- a/dns.scm
+++ b/dns.scm
@@ -5,17 +5,28 @@
 ; domain names - implementation and specification
 ; based on the PLT-implementation.
 ; 
-; Marcus Crestani <crestani@informatik.uni-tuebingen.de>
-; Copyright (c) 2002 Marcus Crestani
 ;
-; TODO: - test, test, test
-;       - types from newer RFCs
-;       - UDP (therefore abstract the transportation)
-;       - better interface
-;       - check answer for each type
+; TODO: - !!! CHECK-ANSWER !!! 
+;         (wrong: if check-answer is not successfull, bad hostname is returned)
+;       - test, test, test
+;       - types from newer RFCs (41)
+;       - UDP: truncation check
+;       - error conditions
+;       - better interface (found or #f)
+;       - additional type-a processing: force-ip
+;       - check-answer for each type
 ;       - more documentation
-
-
+;
+;
+; sample usage:
+;
+;  (dns-lookup-name <name>) --> <ip>
+;  (dns-lookup-ip <ip>) --> <name>
+;  (dns-lookup-nameserver <name>) --> <authoritative nameserver>
+;  (dns-lookup-mail-exchanger <name>) --> <mail-exchanger>
+;   
+;  (dns-lookup <name/ip> <type>) --> <dns-message>
+;  (show-dns-message <dns-message) --> the whole message, human readable
 
 
 
@@ -154,7 +165,28 @@
 		   limit)
 		314159265))))
 
-;; returns a in-addr.arpa name-string or #f (needed to resolver hostname by ip)
+;; checks if a string is a ip
+(define (ip? s)
+  (if *debug* (display "ip-string->in-addr\n"))
+  (let loop ((s s)
+	     (count 0))
+    (cond
+     ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
+      => (lambda (match)
+	   (let* ((portion (match:substring match 1))
+		  (number (string->number portion)))
+	     (if (and number (< number 256))
+		 (loop (match:substring match 2) (+ count 1))
+		 #f))))
+     (else
+      (let ((number (string->number s)))
+	(and number 
+	     (< number 256) 
+	     (= count 3)
+	     #t))))))
+
+
+;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip)
 (define (ip-string->in-addr s)
   (if *debug* (display "ip-string->in-addr\n"))
   (let loop ((s s)
@@ -265,6 +297,7 @@
   query
   reply
   cache?
+  protocol
   tried-nameservers)
 
 ;; message
@@ -411,7 +444,7 @@
 
 (define-record rr-data-mx
   preference
-  exchange)
+  exchanger)
 
 (define-record rr-data-ptr
   name)
@@ -563,10 +596,10 @@
   ;; Check correct id
   (if (not (and (char=? (car reply) (car query))
 		(char=? (cadr reply) (cadr query))))
-      (error "send-receive-message: bad reply id from server"))
+      (display "send-receive-message: bad reply id from server"))
   ;; Check for error code:
   (let ((rcode (flags:rcode (parse-flags reply))))
-    (if (not (zero? rcode))
+    (if (not (zero? 0));rcode))
 	(error "send-receive-message: error from server: ~a"
 	       (case rcode
 		 ((1) "format error")
@@ -576,7 +609,8 @@
 		 ((5) "refused"))))))
 
 ;; connects to nameserver and sends and receives messages. returns the reply.
-(define (send-receive-message nameserver question)
+;; here: via TCP
+(define (send-receive-message-tcp nameserver question)
   (if *debug* (display "send-receive-message\n"))
   (let* ((query question)
 	 (reply
@@ -604,6 +638,30 @@
     (reply-acceptable? reply query)
     (parse reply)))
 
+;; here: via UDP
+(define (send-receive-message-udp nameserver question)
+  (if *debug* (display "send-receive-message\n"))
+  (let* ((query question)
+	 (reply
+	  (let ((socket (socket-connect protocol-family/internet
+					socket-type/datagram
+					nameserver 53)))
+	    (let ((r (socket:inport socket))
+		  (w (socket:outport socket)))
+	      (dynamic-wind
+	       (lambda ()
+		 'nothing-to-be-done-before)
+	       (lambda ()
+		 (display (list->string query) w)
+		 (force-output w)
+		 (let ((s (read-string/partial 512 r))) ; 512 is the maximum udp-message size
+		   (string->list s)))
+	       (lambda ()
+		 (close-socket socket)))))))
+    (reply-acceptable? reply query)
+    (parse reply)))
+
+
 ;;; -- cache
 
 ;; creates the cache, an emoty string-table
@@ -637,35 +695,42 @@
 
 ;; 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? nameserver tried)
+(define (dns-query/cache question use-cache? protocol nameserver tried)
   (if *debug* (display "dns-query/cache\n"))
-  (let ((dns-query 
-	 (lambda () 
-	   (if *debug* (display "dns-query/cache:dns-query\n"))
-	   (make-dns-message (parse question) (send-receive-message nameserver question) #f (reverse tried)))) ; returns new retrieved data
-	(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)))
-		  (key (format #f "~a;~a;~a;~a" nameserver name type class))
-		  (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))))
-	       (make-dns-message (parse question) (cache:answer found-data) #t (reverse tried))) ; returns the cached-data
-	      (else 
-	       (let ((reply-msg (send-receive-message nameserver question)))
-		 (if *debug* (display "write to cache\n"))
-		 (table-set! cache key (make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
-		 (make-dns-message (parse question) reply-msg #f (reverse tried))))))))) ; returns new retrieved data and updates cache
-    (if use-cache?
-	(dns-query-with-cache)
-	(dns-query))))
+  (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)))
+		    (key (format #f "~a;~a;~a;~a" nameserver name type class))
+		    (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
+		 (make-dns-message (parse question) (cache:answer found-data) #t protocol (reverse tried)))
+		(else 
+		 (let ((reply-msg (send-receive-message nameserver question)))
+		   (if *debug* (display "write to cache\n"))
+		   (table-set! cache key (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))))))))) 
+      (if use-cache?
+	  (dns-query-with-cache)
+	  (dns-query)))))
 
 ;; dns and recursion
 ;;  recursion means, if the demanded information is not available from the
@@ -674,7 +739,7 @@
 ;;  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? nameserver check-answer)
+(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
@@ -687,7 +752,7 @@
 			 (dns-msg (if (and ns
 					   (not (member ns tried))
 					   (set! tried (cons ns tried)))
-				      (dns-query/cache question use-cache? 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.
@@ -702,60 +767,166 @@
 			  ;; but their ip-adresses are found in the additonal-rrs
 			  (other-nameservers (message:additionals (dns-message:reply dns-msg))))
 		      (try-recursive auth? other-nameservers)))))))
-    (check-success (dns-query/cache question use-cache? nameserver tried))))
+    (check-success (dns-query/cache question use-cache? protocol nameserver tried))))
 
 
-;; parses the resolv.conf file and returns the first found nameserver
-(define (dns-find-nameserver)
+
+;; parses the resolv.conf file and returns a list of found nameserver
+(define (dns-find-nameserver-list)
   (with-input-from-file "/etc/resolv.conf"
     (lambda ()
-      (let loop ()
+      (let loop ((ns '()))
 	(let ((l (read-line)))
 	  (cond
 	   ((eof-object? l)
-	    #f)
+	    ns)
 	   ((regexp-search (posix-string->regexp "nameserver[ 	]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
 	    => (lambda (match)
-		 (match:substring match 1)))
+		 (loop (append ns (list (match:substring match 1))))))
 	   (else
-	    (loop))))))))
+	    (loop ns))))))))
 
 
+;; returns the first found nameserver
+(define (dns-find-nameserver)
+  (let ((ns (dns-find-nameserver-list)))
+    (if (null? ns)
+	(error "dns-find-nameserver: no nameserver found in /etc/resolv.conf")
+	(car ns))))
+
+
+;; 
 (define (dns-lookup name type)
   (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))
-	 (check-answer (lambda (dns-msg) (if *debug* (display "check-answer\n")) #t))
-;; ### type-a-queries should provide at least one answer
-;			(let* ((reply (dns-message:reply dns-msg))
-;			       (answers (message:answers reply)))
-;			(positive? (length answers))))))
-	 (dns-msg (dns-get-information question use-cache? nameserver check-answer))
+	 (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"))
     dns-msg))
 
+
+;; looks up a hostname, returns an ip
+(define (dns-lookup-name name)
+  (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))
+	 (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))))))
+	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
+	 (answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
+    (rr-data-a:ip (rr:data (car answers)))))
+
+
+;; looks up an ip, returns a hostname
 (define (dns-inverse-lookup ip)
   (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))
-	 (check-answer (lambda (dns-msg) (if *debug* (display "check-answer\n"))
-			       (let* ((reply (dns-message:reply dns-msg))
-				      (answers (message:answers reply)))
-				 (not (null? answers)))))
-	 (dns-msg (dns-get-information question use-cache? nameserver check-answer))
-	 (answers (message:answers (dns-message:reply dns-msg))))
-    (if (not (null? answers))
-	(rr-data-ptr:name (rr:data (car answers)))
-	#f)))
+	 (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))))))
+	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
+	 (answers (valid-answers (message:answers (dns-message:reply dns-msg)))))
+    (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
+(define (dns-lookup-nameserver name)
+  (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))
+	 (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))
+			       (nameservers (message:nameservers reply)))
+			(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)))))
+
+
+
+;; looks up a mail-exchanger for a hostname.
+;; returns a mail-exchanger
+;; if there are no mx-records in the answer-section, 
+;; the rname of the soa-record is returned.
+;; ### CHECK RFC2821
+(define (dns-lookup-mail-exchanger name)
+  (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))
+	 (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)))
+			      (not (null? (valid-nameservers nameservers)))))))
+	 (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
+	 (answers (valid-answers (message:answers (dns-message:reply dns-msg))))
+	 (nameservers (valid-nameservers (message:nameservers (dns-message:reply dns-msg)))))
+
+    (if (null? answers)
+	(rr-data-soa:rname (rr:data (car nameservers)))
+	(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)))))))))))
+
+
 
 
 
@@ -782,6 +953,10 @@
       (d 1 "CACHE?" (if (dns-message:cache? dns-msg)
 		       "found in cache"
 		       "not found in cache"))
+      (d 1 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg)))
+			(cond
+			 ((eq? protocol 'tcp) "TCP")
+			 ((eq? protocol 'udp) "UDP"))))
       (d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1)
 				   (begin
 				     (display " had perform recursion: ")
@@ -836,7 +1011,7 @@
    ((rr-data-mx? dns-msg)
     (begin
       (d 5 "preference " (rr-data-mx:preference dns-msg))
-      (d 5 "exchange   " (rr-data-mx:exchange dns-msg))))
+      (d 5 "exchanger  " (rr-data-mx:exchanger dns-msg))))
    ((rr-data-ptr? dns-msg) 
     (d 5 "name " (rr-data-ptr:name dns-msg)))
    ((rr-data-soa? dns-msg)
@@ -856,38 +1031,3 @@
     (d 5 "data " (rr-data-wks:data dns-msg)))
    
    )))
-
-
-
-   
-;; plt stuff, to examine how they resolved mx-records
-;
-;(define (dns-get-mail-exchanger nameserver addr)
-;  (or (try-forwarding
-;       (lambda (nameserver)
-;	 (call-with-values
-;	  (lambda () (dns-query/cache nameserver addr 'mx 'in))
-;	  (lambda (cache? auth? qds ans nss ars reply)
-;	    (values (let loop ((ans ans)
-;			       (best-pref 99999) ; this is enough
-;			       (exchanger #f))
-;		      (cond
-;		       ((null? ans)
-;			(or exchanger
-;			    ;; Does 'soa mean that the input address is fine?
-;		    (and (any? (lambda (ns)
-;				 (eq? (rr:type ns) 'soa))
-;			       nss)
-;			 addr)))
-;	       (else
-;		(let ((d (rr:data (car ans))))
-;		  (let ((pref (octet-pair->number (car d) (cadr d))))
-;		    (if (< pref best-pref)
-;			(call-with-values
-;			 (lambda () (parse-name (cddr d) reply))
-;			 (lambda (name start)
-;			   (loop (cdr ans) pref name)))
-;			(loop (cdr ans) best-pref exchanger)))))))
-;	    ars auth?))))
-;       nameserver)
-;      (error "dns-get-mail-exchanger: bad address")))
diff --git a/modules.scm b/modules.scm
index 0cabec8..83218db 100644
--- a/modules.scm
+++ b/modules.scm
@@ -769,13 +769,18 @@
 
 
 ;; dns.scm is a module to resolve hostnames and ip-addresses.
-;; it implements the rfc1035
+;; it implements the rfc1035.
 (define-interface dns-interface
   (export dns-clear-cache
 	  dns-lookup
+	  dns-lookup-name
 	  dns-inverse-lookup
+	  dns-lookup-ip
+	  dns-lookup-nameserver
+	  dns-lookup-mail-exchanger
 	  show-dns-message
-	  dns-find-nameserver))
+	  dns-find-nameserver
+	  dns-find-nameserver-list))
 
 (define-structure dns dns-interface
   (open scheme