From 48a0a95a4a187f289a4798a5533588f1908fe865 Mon Sep 17 00:00:00 2001
From: cresh <cresh>
Date: Wed, 17 Apr 2002 12:12:58 +0000
Subject: [PATCH] added better multiple answers processing and rr-data-types

---
 dns.scm | 157 ++++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 129 insertions(+), 28 deletions(-)

diff --git a/dns.scm b/dns.scm
index db7459b..a21eab2 100644
--- a/dns.scm
+++ b/dns.scm
@@ -8,6 +8,15 @@
 ; 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
+;       - more documentation
+
+
+
 
 
 ;;; should debug-msgs be printed out?
@@ -55,7 +64,7 @@
 (define (cossa i l)
   (if *debug* (display "cossa\n"))
   (cond
-   ((null? l) #f)
+   ((null? l) (error "dns-message: type not implemented: " i))
    ((equal? (cadar l) i)
     (car l))
    (else (cossa i (cdr l)))))
@@ -381,35 +390,77 @@
 			 (cdr start)
 			 (cons (car start) accum)))))))))))
 
+;;; -- rr-data-type records
+
+(define-record rr-data-a
+  ip)
+
+(define-record rr-data-ns
+  name)
+
+(define-record rr-data-cname
+  name)
+
+;; ###
+;; hinfo not correctly implemented: 
+;; 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)                       
+
+(define-record rr-data-mx
+  preference
+  exchange)
+
+(define-record rr-data-ptr
+  name)
+
+(define-record rr-data-soa
+  mname
+  rname
+  serial
+  refresh
+  retry
+  expire
+  minimum)
+
+;; ### same as hinfo
+(define-record rr-data-txt
+  text)
+
+;; ### same as hinfo and txt
+(define-record rr-data-wks
+  data)
+
+;;
+
 (define (parse-rr-data type class data message)
   (if *debug* (display "parse-rr-data\n"))
   (cond
    ((eq? type 'a) 
-    (list (ip->string data)))
+    (make-rr-data-a (ip->string data)))
    
    ((eq? type 'ns) 
-    (list (call-with-values 
-	   (lambda () (parse-name data message))
-	   (lambda (name rest) name))))
+    (make-rr-data-ns (call-with-values 
+		      (lambda () (parse-name data message))
+		      (lambda (name rest) name))))
 
    ((eq? type 'cname) 
-    (list (call-with-values
-	   (lambda () (parse-name data message))
-	   (lambda (name rest) name))))
-
-   ((eq? type 'hinfo)
-    (list (list->string data)))
+    (make-rr-data-cname (call-with-values
+			 (lambda () (parse-name data message))
+			 (lambda (name rest) name))))
 
    ((eq? type 'mx)
-    (list (octet-pair->number (car data) (cadr data))
-	  (call-with-values
-	   (lambda ()(parse-name (cddr data) message))
-	   (lambda (name rest) name))))
+    (make-rr-data-mx (octet-pair->number (car data) (cadr data))
+		(call-with-values
+		 (lambda ()(parse-name (cddr data) message))
+		 (lambda (name rest) name))))
 
    ((eq? type 'ptr)
-    (list (call-with-values
-	   (lambda () (parse-name data message))
-	   (lambda (name rest) name))))
+    (make-rr-data-ptr (call-with-values
+		  (lambda () (parse-name data message))
+		  (lambda (name rest) name))))
   
    ((eq? type 'soa)
     (call-with-values
@@ -428,13 +479,16 @@
 		      (rest (cddddr rest)))
 		  (let ((minimum (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
 			(rest (cddddr rest)))
-		    (list mname rname serial refresh retry expire minimum)))))))))))
+		    (make-rr-data-soa mname rname serial refresh retry expire minimum)))))))))))
+
+   ((eq? type 'hinfo)
+    (make-rr-data-hinfo (list->string data)))
 
    ((eq? type 'txt)
-    (list (list->string data)))
+    (make-rr-data-txt (list->string data)))
    
    ((eq? type 'wks)
-    (list data))
+    (make-rr-data-wks data))
 
    (else (list data))))
 
@@ -559,6 +613,28 @@
 (define (dns-clear-cache)
   (set! cache (make-string-table)))
 
+;; searches in a dns-msg for the shortest ttl. this is needed for cache-management.
+(define (find-shortest-ttl dns-msg)
+  (if *debug* (display "find-shortest-ttl\n"))
+  (letrec ((minimum #f)
+	   (find-shortest-ttl-1
+	    (lambda (dns-msg)
+	      (cond
+	       ((dns-message? dns-msg) 
+		(find-shortest-ttl-1 (dns-message:reply dns-msg)))
+	       ((message? dns-msg)
+		(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:answers dns-msg))
+		(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:nameservers dns-msg))
+		(for-each (lambda (x) (find-shortest-ttl-1 x)) (message:additionals dns-msg))
+		minimum)
+	       ((rr? dns-msg)
+		(cond
+		 ((not minimum)  (set! minimum (rr:ttl dns-msg)))
+		 (else
+		  (if (and (not minimum) (> minimum (rr:ttl dns-msg)))
+		      (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 (dns-query/cache question use-cache? nameserver tried)
@@ -585,11 +661,7 @@
 	      (else 
 	       (let ((reply-msg (send-receive-message nameserver question)))
 		 (if *debug* (display "write to cache\n"))
-		 (table-set! cache key (make-cache reply-msg 
-						   (if (null? (message:answers reply-msg))
-						       0
-						       (rr:ttl (car (message:answers reply-msg))))
-						   (time)))
+		 (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)
@@ -664,7 +736,7 @@
 	 (dns-msg (dns-get-information question use-cache? nameserver check-answer))
 	 (answers (message:answers (dns-message:reply dns-msg))))
     (if (not (null? answers))
-	(show-dns-message (car answers))
+	(for-each (lambda (x) (show-dns-message x)(newline)) answers)
 	(display "sorry, no answers received\n"))
     dns-msg))
 
@@ -739,7 +811,36 @@
       (d 4 "type " (rr:type dns-msg))
       (d 4 "class" (rr:class dns-msg))
       (d 4 "ttl  " (rr:ttl dns-msg))
-      (d 4 "data " (rr:data dns-msg)))))))
+      (d 4 "data " "") (show-dns-message (rr:data dns-msg))))
+   ((rr-data-a? dns-msg)
+    (d 5 "ip " (rr-data-a:ip dns-msg)))
+   ((rr-data-ns? dns-msg)
+    (d 5 "name " (rr-data-ns:name dns-msg)))
+   ((rr-data-cname? dns-msg)
+    (d 5 "name " (rr-data-cname:name dns-msg)))
+   ((rr-data-mx? dns-msg)
+    (begin
+      (d 5 "preference " (rr-data-mx:preference dns-msg))
+      (d 5 "exchange   " (rr-data-mx:exchange dns-msg))))
+   ((rr-data-ptr? dns-msg) 
+    (d 5 "name " (rr-data-ptr:name dns-msg)))
+   ((rr-data-soa? dns-msg)
+    (begin
+      (d 5 "mname   " (rr-data-soa:mname dns-msg))
+      (d 5 "rname   " (rr-data-soa:rname dns-msg))
+      (d 5 "serial  " (rr-data-soa:serial dns-msg))
+      (d 5 "refresh " (rr-data-soa:refresh dns-msg))
+      (d 5 "expire  " (rr-data-soa:expire dns-msg))
+      (d 5 "minimum " (rr-data-soa:expire dns-msg))))
+;; ###
+   ((rr-data-hinfo? dns-msg)
+    (d 5 "data " (rr-data-hinfo:data dns-msg)))
+   ((rr-data-txt? dns-msg)
+    (d 5 "text " (rr-data-txt:text dns-msg)))
+   ((rr-data-wks? dns-msg)
+    (d 5 "data " (rr-data-wks:data dns-msg)))
+   
+   )))