complete revision of the PLT-dns-resolver.

it nearly fully implements the rfc1035:
  - resolver-side recursion
  - cache
  - following types: a, ns, cname, hinfo, mx, ptr, soa, txt
  - in-addr.arpa (get hostname by ip)
each dns-lookup returns a dns-message record.

dns.scm

@@ -1,100 +1,317 @@
-;; open string-table big-util(?) ascii format signals random
+; 
+; dns.scm
+;
+; Implementation of the RFC1035 
+; domain names - implementation and specification
+; based on the PLT-implementation.
+; 
+; Marcus Crestani <crestani@informatik.uni-tuebingen.de>
+; Copyright (c) 2002 Marcus Crestani
+;
 
+
+;;; should debug-msgs be printed out?
+(define *debug* #f)
+
+
+;;; -- globals and types
+
+;; off
 (define *nul* (ascii->char 0))
+
+;; on
 (define *on* (ascii->char 1))
 
+;; message types
 (define types
-  '((a 1)
+  '((a 1)      ; a host address 
-    (ns 2)
+    (ns 2)     ; an authoritative name server
-    (md 3)
+    (md 3)     ; (obsolete)
-    (mf 4)
+    (mf 4)     ; (obsolete)
-    (cname 5)
+    (cname 5)  ; the canonical name for an alias
-    (soa 6)
+    (soa 6)    ; marks the start of a zone of authority
-    (mb 7)
+    (mb 7)     ; (experimental)
-    (mg 8)
+    (mg 8)     ; (experimental)
-    (mr 9)
+    (mr 9)     ; (experimental)
-    (null 10)
+    (null 10)  ; (experimental)
-    (wks 11)
+    (wks 11)   ; a well known service description
-    (ptr 12)
+    (ptr 12)   ; a domain name pointer
-    (hinfo 13)
+    (hinfo 13) ; host information
-    (minfo 14)
+    (minfo 14) ; mailbox or mail list information
-    (mx 15)
+    (mx 15)    ; mail exchange
-    (txt 16)))
+    (txt 16))) ; text strings
 
+;; message classes
 (define classes
-  '((in 1)
+  '((in 1)     ; the Internet
-    (cs 2)
+    (cs 2)     ; (obsolete)
-    (ch 3)
+    (ch 3)     ; the CHAOS class
-    (hs 4)))
+    (hs 4)))   ; Hesoid
 
+
+;;; -- useful stuff
+
+;; assoc the other way round
 (define (cossa i l)
+  (if *debug* (display "cossa\n"))
   (cond
    ((null? l) #f)
    ((equal? (cadar l) i)
     (car l))
    (else (cossa i (cdr l)))))
 
+;; encodes numbers (16bit) to octets
 (define (number->octet-pair n)
+  (if *debug* (display "number->octet-pair\n"))
   (list (ascii->char (arithmetic-shift n -8))
 	(ascii->char (modulo n 256))))
 
+;; decodes octets to numbers (16bit)
 (define (octet-pair->number a b)
+  (if *debug* (display "octet-pair->number\n"))
   (+ (arithmetic-shift (char->ascii a) 8)
      (char->ascii b)))
 
+;; encodes numbers (32bit) to octets, needed for ttl
+(define (number->octet-quad n)
+  (if *debug* (display "number->octet-quad\n"))
+  (list (ascii->char (arithmetic-shift n -24))
+	(ascii->char (modulo (arithmetic-shift n -16) 256))
+	(ascii->char (modulo (arithmetic-shift n -8) 256))
+	(ascii->char (modulo n 256))))
+
+;; decodes octets to numbers, needed for 32bit ttl
 (define (octet-quad->number a b c d)
+  (if *debug* (display "octet-quad->number\n"))
   (+ (arithmetic-shift (char->ascii a) 24)
      (arithmetic-shift (char->ascii b) 16)
      (arithmetic-shift (char->ascii c) 8)
      (char->ascii d)))
 
+;; encodes a domain-name string to octets
 (define (name->octets s)
   (define (encode-portion s)
     (cons
      (ascii->char (string-length s))
      (string->list s)))
 
+  (if *debug* (display "name->octets\n"))
   (let loop ((s s))
     (cond
-     ((string-match "^([^.]*)\\.(.*)" s)
+     ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
       => (lambda (match)
 	   (append
 	    (encode-portion (match:substring match 1))
 	    (loop (match:substring match 2)))))
      (else
-      (append
+      (if (= 0 (string-length s))
-       (encode-portion s)
+	  (list *nul*)
-       (list *nul*))))))
+	  (append
-
+	   (encode-portion s)
-(define (make-std-query-header id question-count)
+	   (list *nul*)))))))
-  (append
-   (number->octet-pair id)
-   (list *on* *nul*)			; Opcode & flags (recusive flag set)
-   (number->octet-pair question-count)
-   (number->octet-pair 0)
-   (number->octet-pair 0)
-   (number->octet-pair 0)))
-
-(define (make-query id name type class)
-  (append
-   (make-std-query-header id 1)
-   (name->octets name)
-   (number->octet-pair (cadr (assoc type types)))
-   (number->octet-pair (cadr (assoc class classes)))))
 
+;; for tcp: message has to be tagged with its length
 (define (add-size-tag m)
+  (if *debug* (display "add-size-tag\n"))
   (append (number->octet-pair (length m)) m))
 
-(define (rr-data rr)
+;; converts an octeted-ip to an human readable ip-string
-  (cadddr (cdr rr)))
+(define (ip->string s)
+  (if *debug* (display "ip->string\n"))
+  (format #f
+	  "~a.~a.~a.~a" 
+	  (char->ascii (list-ref s 0))
+	  (char->ascii (list-ref s 1))
+	  (char->ascii (list-ref s 2))
+	  (char->ascii (list-ref s 3))))
 
-(define (rr-type rr)
+;; converts an ip-string to octets
-  (cadr rr))
+(define (string->ip s)
+  (if *debug* (display "string->ip\n"))
+  (let loop ((s s)
+	     (result '()))
+    (cond
+     ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
+      => (lambda (match)
+	   (loop (match:substring match 2) (append result (list (ascii->char (string->number (match:substring match 1))))))))
+     (else
+       (append result (list (ascii->char (string->number s))))))))
 
-(define (rr-name rr)
+;; calculates a "random" number, needed for message-ids
-  (car rr))
+(define random
+  (let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
+    (lambda (limit)
+      (quotient (* (modulo (crank) 314159265)
+		   limit)
+		314159265))))
 
-(define (parse-name start reply)
+;; returns a in-addr.arpa name-string or #f (needed to resolver hostname by ip)
+(define (ip-string->in-addr s)
+  (if *debug* (display "ip-string->in-addr\n"))
+  (let loop ((s s)
+	     (count 0)
+	     (result ""))
+    (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) (string-append portion "." result))
+		 #f))))
+     (else
+      (let ((number (string->number s)))
+	(and number 
+	     (< number 256) 
+	     (= count 3)
+	     (string-append s "." result "in-addr.arpa")))))))
+
+
+
+;;; -- message constructors: encode to octet-messages
+
+;; makes an message header
+(define (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount)
+  (if *debug* (display "make-octet-header\n"))
+  (let* ((header-id (number->octet-pair id))
+	 (header-flags (list 
+			(ascii->char (+ (arithmetic-shift qr 7)
+					(arithmetic-shift opcode 3)
+					(arithmetic-shift aa 2)
+					(arithmetic-shift tc 1)
+					rd))
+			(ascii->char (+ (arithmetic-shift ra 7)
+				        (arithmetic-shift z 4)
+					rcode))))
+	 (header-qdcount (number->octet-pair qdcount))
+	 (header-ancount (number->octet-pair ancount))
+	 (header-nscount (number->octet-pair nscount))
+	 (header-arcount (number->octet-pair arcount)))
+    (append header-id
+	    header-flags
+	    header-qdcount
+	    header-ancount
+	    header-nscount
+	    header-arcount)))
+
+
+;; a standard query header, usefull for most queries
+(define (make-std-octet-query-header id question-count)
+  (if *debug* (display "make-std-octet-query-header\n"))
+  (let* ((qr 0)        ; querytype: query 0, response 1
+	 (opcode 0)    ; opcode: query 0, iquery 1 (OBSOLETE), status 2
+	 (aa 0)        ; authorative answer (in answers only)
+	 (tc 0)        ; truncation (size matters only with UDP)
+	 (rd 1)        ; recursion desired: nameserver pursues the query recursivly (optional)
+	 (ra 0)        ; recursion available (in answers only)
+	 (z 0)         ; future use
+         (rcode 0)     ; response code: error conditions (in answers only)
+	 (qdcount question-count)
+	 (ancount 0)   ; answer count (in answers only)
+	 (nscount 0)   ; name server resources (in answers only)
+	 (arcount 0))  ; additional records (in answers only)
+
+    (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount)))
+
+
+;; makes a question (name, type, class)
+(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))
+  (if (not (assoc class classes))
+      (error "make-octet-question: invalid DNS query class ~a" class))
+
+  (let* ((qname   (name->octets name))
+	 (qtype   (number->octet-pair (cadr (assoc type types))))
+	 (qclass  (number->octet-pair (cadr (assoc class classes)))))
+    (append qname qtype qclass)))
+
+
+;; makes a query-message (header and question only)
+(define (make-octet-query-message id name type class)
+  (if *debug* (display "make-octet-query-message\n"))
+  (append
+   (make-std-octet-query-header id 1)
+   (make-octet-question name type class)))
+  
+
+;; makes a resource record for ans, nss, ars (name, type, class, ttl, data)
+(define (make-octet-rr name type class ttl rdata)
+  (if *debug* (display "make-octet-rr\n"))
+  (let* ((name (name->octets name))
+	 (type (number->octet-pair (cadr (assoc type types))))
+	 (class (number->octet-pair (cadr (assoc class classes))))
+	 (ttl (number->octet-quad ttl))
+	 (rdlength (number->octet-pair (length rdata)))
+	 (rdata rdata))
+    (append name type class ttl rdlength rdata)))
+
+
+
+;;; -- parsed message records
+
+;;; -- dns-message: complete data-structure of an dns-lookup
+(define-record dns-message
+  query
+  reply
+  cache?
+  tried-nameservers)
+
+;; message
+(define-record message
+  header
+  questions
+  answers
+  nameservers
+  additionals
+  source)
+
+;; header
+(define-record header
+  id
+  flags
+  qdc
+  anc
+  nsc
+  arc)
+
+;; flags
+(define-record flags
+  querytype
+  opcode
+  auth
+  trunc
+  recursiondesired
+  recursionavailable
+  z
+  rcode)
+
+;; question
+(define-record question
+  name
+  type
+  class)
+
+;; rr
+(define-record rr
+  name
+  type
+  class
+  ttl
+  data)
+
+;; cache
+(define-record cache
+  answer
+  ttl
+  time)
+
+;;; -- message parser
+
+;; parses a domain-name in an message. returns the name and the rest of the message.
+(define (parse-name start message)
+  (if *debug* (display "parse-name\n"))
   (let ((v (char->ascii (car start))))
     (cond
      ((zero? v)
@@ -108,7 +325,7 @@
 	(cond
 	 ((zero? len)
 	  (call-with-values
-	   (lambda () (parse-name start reply))
+	   (lambda () (parse-name start message))
 	   (lambda (s start)
 	     (let ((s0 (list->string (reverse! accum))))
 	       (values (if s
@@ -123,13 +340,27 @@
       (let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
 		       (char->ascii (cadr start)))))
 	(call-with-values
-	 (lambda () (parse-name (list-tail reply offset) reply))
+	 (lambda () (parse-name (list-tail message offset) message))
 	 (lambda (s ignore-start)
 	   (values s (cddr start)))))))))
 
-(define (parse-rr start reply)
+;; parses a question in a message. returns the question and the rest of the message.
+(define (parse-question start message)
+  (if *debug* (display "parse-question\n"))
   (call-with-values
-   (lambda () (parse-name start reply))
+   (lambda () (parse-name start message))
+   (lambda (name start)
+     (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
+	   (start (cddr start)))
+       (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
+	     (start (cddr start)))
+	 (values (make-question name type class) start))))))
+
+;; parses a resourcerecord in a message. returns the rr and the rest of the message.
+(define (parse-rr start message)
+  (if *debug* (display "parse-rr\n"))
+  (call-with-values
+   (lambda () (parse-name start message))
    (lambda (name start)
      (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
 	   (start (cddr start)))
@@ -140,50 +371,160 @@
 	       (start (cddddr start)))
 	   (let ((len (octet-pair->number (car start) (cadr start)))
 		 (start (cddr start)))
-					; Extract next len bytes for data:
+	     ;; Extract next len bytes of data:
 	     (let loop ((len len)
 			(start start)
 			(accum '()))
 	       (if (zero? len)
-		   (values (list name type class ttl (reverse! accum))
+		   (values (make-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start)
-			   start)
 		   (loop (- len 1)
 			 (cdr start)
 			 (cons (car start) accum)))))))))))
 
-(define (parse-ques start reply)
+(define (parse-rr-data type class data message)
-  (call-with-values
+  (if *debug* (display "parse-rr-data\n"))
-   (lambda () (parse-name start reply))
+  (cond
-   (lambda (name start)
+   ((eq? type 'a) 
-     (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
+    (list (ip->string data)))
-	   (start (cddr start)))
-       (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
-	     (start (cddr start)))
-	 (values (list name type class) start))))))
    
-(define (parse-n parse start reply n)
+   ((eq? type 'ns) 
+    (list (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)))
+
+   ((eq? type 'mx)
+    (list (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))))
+  
+   ((eq? type 'soa)
+    (call-with-values
+     (lambda () (parse-name data message))
+     (lambda (mname rest)
+       (call-with-values
+	(lambda () (parse-name rest message))
+	(lambda (rname rest)
+	  (let ((serial (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
+		(rest (cddddr rest)))
+	    (let ((refresh (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
+		  (rest (cddddr rest)))
+	      (let ((retry (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
+		    (rest (cddddr rest)))
+		(let ((expire (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest)))
+		      (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)))))))))))
+
+   ((eq? type 'txt)
+    (list (list->string data)))
+   
+   ((eq? type 'wks)
+    (list data))
+
+   (else (list data))))
+
+;; parses n-times a message with parse. returns a list of parse-returns.
+(define (parse-n parse start message n)
+  (if *debug* (display "parse-n\n"))
   (let loop ((n n) (start start) (accum '()))
     (if (zero? n)
 	(values (reverse! accum) start)
 	(call-with-values
-	 (lambda () (parse start reply))
+	 (lambda () (parse start message))
 	 (lambda (rr start)
 	   (loop (- n 1) start (cons rr accum)))))))
 
-(define random
+;; parses a message-headers flags. returns the flags.
-  (let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
+(define (parse-flags message)
-    (lambda (limit)
+  (if *debug* (display "parse-flags\n"))
-      (quotient (* (modulo (crank) 314159265)
+  (let ((v0 (list-ref message 2))
-		   limit)
+	(v1 (list-ref message 3)))
-		314159265))))
+      ;; Check for error code:
+      (let ((rcode  (bitwise-and #xf (char->ascii v1)))
+	    (z      (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4))
+	    (ra     (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7))
+	    (rd     (bitwise-and 1 (char->ascii v0)))
+	    (tc     (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1))
+	    (aa     (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2))
+	    (opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3))
+	    (qr     (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7))) 
+	(make-flags qr opcode aa tc rd ra z rcode))))
 
-(define (dns-query nameserver addr type class)
-  (if (not (assoc type types))
-      (error "dns-query: invalid DNS query type ~a" type))
-  (if (not (assoc class classes))
-      (error "dns-query: invalid DNS query class ~a" class))
 
-  (let* ((query (make-query (random 256) addr type class))
+;; parses a message-header. returns the header.
+(define (parse-header message)
+  (if *debug* (display "parse-header\n"))
+  (let ((id       (octet-pair->number (list-ref message 0) (list-ref message 1)))
+	(flags    (parse-flags message))
+	(qd-count (octet-pair->number (list-ref message 4) (list-ref message 5)))
+	(an-count (octet-pair->number (list-ref message 6) (list-ref message 7)))
+	(ns-count (octet-pair->number (list-ref message 8) (list-ref message 9)))
+	(ar-count (octet-pair->number (list-ref message 10) (list-ref message 11))))
+    (make-header id flags qd-count an-count ns-count ar-count)))
+  
+
+;; parses a message. returns the parsed message.
+(define (parse message)
+  (if *debug* (display "parse\n"))
+  (let* ((header (parse-header message))
+	 (start (list-tail message 12)))
+    (call-with-values
+     (lambda () (parse-n parse-question start message (header:qdc header)))
+     (lambda (qds start)
+       (call-with-values
+	(lambda () (parse-n parse-rr start message (header:anc header)))
+	(lambda (ans start)
+	  (call-with-values
+	   (lambda () (parse-n parse-rr start message (header:nsc header)))
+	   (lambda (nss start)
+	     (call-with-values
+	      (lambda () (parse-n parse-rr start message (header:arc header)))
+	      (lambda (ars start)
+		(if (not (null? start))
+		    (error "parse: error parsing server message"))
+		(make-message header qds ans nss ars message)))))))))))
+
+
+
+;;; -- send, receive and validate message
+
+;; checks if the received reply is valid. returns #t or error-msg.
+(define (reply-acceptable? reply query)
+  (if *debug* (display "reply-acceptable?\n"))
+  ;; 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"))
+  ;; Check for error code:
+  (let ((rcode (flags:rcode (parse-flags reply))))
+    (if (not (zero? rcode))
+	(error "send-receive-message: error from server: ~a"
+	       (case rcode
+		 ((1) "format error")
+		 ((2) "server failure")
+		 ((3) "name error")
+		 ((4) "not implemented")
+		 ((5) "refused"))))))
+
+;; connects to nameserver and sends and receives messages. returns the reply.
+(define (send-receive-message nameserver question)
+  (if *debug* (display "send-receive-message\n"))
+  (let* ((query question)
 	 (reply
 	  (let ((socket (socket-connect protocol-family/internet
 					socket-type/stream
@@ -192,7 +533,7 @@
 		  (w (socket:outport socket)))
 	      (dynamic-wind
 	       (lambda ()
-		 'fick-dich-ins-knie)
+		 'nothing-to-be-done-before)
 	       (lambda ()
 		 (display (list->string (add-size-tag query)) w)
 		 (force-output w)
@@ -202,135 +543,97 @@
 		   (let ((len (octet-pair->number a b)))
 		     (let ((s (read-string len r)))
 		       (if (not (= len (string-length s)))
-			   (error "dns-query: unexpected EOF from server"))
+			   (error "send-receive-message: unexpected EOF from server"))
 		       (string->list s)))))
 	       (lambda ()
 		 (close-socket socket)))))))
+    (reply-acceptable? reply query)
+    (parse reply)))
 
-    ;; First two bytes must match sent message id:
+;;; -- cache
-    (if (not (and (char=? (car reply) (car query))
-		  (char=? (cadr reply) (cadr query))))
-	(error "dns-query: bad reply id from server"))
-
-    (let ((v0 (caddr reply))
-	  (v1 (cadddr reply)))
-      ;; Check for error code:
-      (let ((rcode (bitwise-and #xf (char->ascii v1))))
-	(if (not (zero? rcode))
-	    (error "dns-query: error from server: ~a"
-		   (case rcode
-		     ((1) "format error")
-		     ((2) "server failure")
-		     ((3) "name error")
-		     ((4) "not implemented")
-		     ((5) "refused")))))
-	    
-      (let ((qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5)))
-	    (an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7)))
-	    (ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9)))
-	    (ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))))
-	      
-	(let ((start (list-tail reply 12)))
-	  (call-with-values
-	   (lambda () (parse-n parse-ques start reply qd-count))
-	   (lambda (qds start)
-	     (call-with-values
-	      (lambda () (parse-n parse-rr start reply an-count))
-	      (lambda (ans start)
-		(call-with-values
-		 (lambda () (parse-n parse-rr start reply ns-count))
-		 (lambda (nss start)
-		   (call-with-values
-		    (lambda () (parse-n parse-rr start reply ar-count))
-		    (lambda (ars start)
-		      (if (not (null? start))
-			  (error "dns-query: error parsing server reply"))
-		      (values (positive? (bitwise-and #x4 (char->ascii v0)))
-			      qds ans nss ars reply))))))))))))))
 
+;; creates the cache, an emoty string-table
 (define cache (make-string-table))
-(define (dns-query/cache nameserver addr type class)
-  (let ((key (format #f "~a;~a;~a;~a" nameserver addr type class)))
-    (cond
-     ((table-ref cache key)
-      => (lambda (v)
-	   (apply values v)))
-     (else
-      (call-with-values
-       (lambda () (dns-query nameserver addr type class))
-       (lambda (auth? qds ans nss ars reply)
-	 (table-set! cache key (list auth? qds ans nss ars reply))
-	 (values auth? qds ans nss ars reply)))))))
 
-(define (ip->string s)
+;; resets the cache
-  (format #f
+(define (dns-clear-cache)
-	  "~a.~a.~a.~a" 
+  (set! cache (make-string-table)))
-	  (char->ascii (list-ref s 0))
-	  (char->ascii (list-ref s 1))
-	  (char->ascii (list-ref s 2))
-	  (char->ascii (list-ref s 3))))
 
-(define (try-forwarding k nameserver)
+;; makes a dns-query. optional cache-check. 
-  (let loop ((nameserver nameserver)
+;; returns a dns-message with cache-flag and either cache-data or new received data.
-	     (tried (list nameserver)))
+(define (dns-query/cache question use-cache? nameserver tried)
-    ;; Normally the recursion is done for us, but it's technically optional
+  (if *debug* (display "dns-query/cache\n"))
-    (call-with-values
+  (let ((dns-query 
-     (lambda () (k nameserver))
+	 (lambda () 
-     (lambda (v ars auth?)
+	   (if *debug* (display "dns-query/cache:dns-query\n"))
-       (or v
+	   (make-dns-message (parse question) (send-receive-message nameserver question) #f (reverse tried)))) ; returns new retrieved data
-	   (and (not auth?)
+	(dns-query-with-cache 
-		(let* ((ns (any
+	 (lambda ()
-			    (lambda (ar)
+	   (if *debug* (display "dns-query/cache:dns-query-with-cache\n"))
-			      (and (eq? (rr-type ar) 'a)
+	   (let* ((qds (message:questions (parse question)))
-				   (ip->string (rr-data ar))))
+		  ;; cache-key relevant data
-			    ars)))
+		  (name (question:name (car qds)))
-		  (and ns
+		  (type (question:type (car qds)))
-		       (not (member ns tried))
+		  (class (question:class (car qds)))
-		       (loop ns (cons ns tried))))))))))
+		  (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 
+						   (if (null? (message:answers reply-msg))
+						       0
+						       (rr:ttl (car (message:answers 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))))
 
-(define (dns-get-address nameserver addr)
+;; dns and recursion
-  (or (try-forwarding
+;;  recursion means, if the demanded information is not available from the
-       (lambda (nameserver)
+;;  nameserver, another nameserver (usualy an authority) has to be contacted.
-	 (call-with-values
+;;  normally the recursion is done for us by the nameserver istself, but
-	  (lambda () (dns-query/cache nameserver addr 'a 'in))
+;;  this feature is technically optional (RFC 1035).
-	  (lambda (auth? qds ans nss ars reply)
+;;  dns-get-information implements the resovler-side recursion.
-	    (values (and (positive? (length ans))
+;;  it returns a dns-message
-			 (let ((s (rr-data (car ans))))
+(define (dns-get-information question use-cache? nameserver check-answer)
-			   (ip->string s)))
+  (if *debug* (display "dns-get-information\n"))
-		    ars auth?))))
+  (letrec ((tried (list nameserver))
-       nameserver)
+	   ;; with every (also unanswerd) requests authoritative nameservers are send back
-      (error "dns-get-address: bad address ~a" addr)))
+	   ;; try-recursive tries to get information from these nameservers
+	   (try-recursive
+	    (lambda (auth? nss)
+	      (if (or auth? (null? nss))
+		  (error "dns-get-information: bad address ~a" (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))
+					   (set! tried (cons ns tried)))
+				      (dns-query/cache question use-cache? 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 useful-answer?
+		    dns-msg
+		    (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))))
+		      (try-recursive auth? other-nameservers)))))))
+    (check-success (dns-query/cache question use-cache? nameserver tried))))
 
-(define (dns-get-mail-exchanger nameserver addr)
-  (or (try-forwarding
-       (lambda (nameserver)
-	 (call-with-values
-	  (lambda () (dns-query/cache nameserver addr 'mx 'in))
-	  (lambda (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")))
 
+;; parses the resolv.conf file and returns the first found nameserver
 (define (dns-find-nameserver)
   (with-input-from-file "/etc/resolv.conf"
     (lambda ()
@@ -339,11 +642,136 @@
 	  (cond
 	   ((eof-object? l)
 	    #f)
-	   ((string-match "nameserver[ 	]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)"
+	   ((regexp-search (posix-string->regexp "nameserver[ 	]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
-			  l)
 	    => (lambda (match)
 		 (match:substring match 1)))
 	   (else
 	    (loop))))))))
 
 
+(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)
+	 (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))
+	 (answers (message:answers (dns-message:reply dns-msg))))
+    (if (not (null? answers))
+	(show-dns-message (car answers))
+	(display "sorry, no answers received\n"))
+    dns-msg))
+
+
+
+
+
+;;; pretty-prints a dns-msg
+(define (show-dns-message dns-msg)
+  (let* ((d 
+	  (lambda (n s1 s2)
+	    (letrec ((loop (lambda (n)
+			  (if (zero? n)
+			      ""
+			      (string-append " " (loop (- n 1)))))))
+	      (display (loop n))
+	      (display s1)
+	      (display ": ")
+	      (display s2)
+	      (newline)))))
+	  
+  (cond
+   ((dns-message? dns-msg) 
+    (begin
+      (d 0 "DNS-MESSAGE" "")
+      (d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline)
+      (d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline)
+      (d 1 "CACHE?" (if (dns-message:cache? dns-msg)
+		       "found in cache"
+		       "not found in cache"))
+      (d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1)
+				   (begin
+				     (display " had perform recursion: ")
+				     (dns-message:tried-nameservers dns-msg))
+				   (begin
+				     (display " without recursion: ")
+				     (dns-message:tried-nameservers dns-msg))))))
+   ((message? dns-msg)
+    (begin
+      (d 2 "MESSAGE" "")
+      (d 3 "Header     " "")(show-dns-message (message:header dns-msg))
+      (d 3 "Questions  " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg))
+      (d 3 "Answers    " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg))
+      (d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg))
+      (d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg))))
+   ((header? dns-msg)
+    (begin
+      (d 4 "id" (header:id dns-msg))
+      (d 4 "Flags" "")(show-dns-message (header:flags dns-msg))
+      (d 4 "question-count    " (header:qdc dns-msg))
+      (d 4 "answer-count      " (header:anc dns-msg))
+      (d 4 "nameserver-count  " (header:nsc dns-msg))
+      (d 4 "additional-count  " (header:arc dns-msg))))
+   ((flags? dns-msg)
+    (begin 
+      (d 5 "querytype" (flags:querytype dns-msg))
+      (d 5 "opcode" (flags:opcode dns-msg))
+      (d 5 "auth" (flags:auth dns-msg))
+      (d 5 "trunc" (flags:trunc dns-msg))
+      (d 5 "recursiondesired" (flags:recursiondesired dns-msg))
+      (d 5 "recursionavailable" (flags:recursionavailable dns-msg))
+      (d 5 "z" (flags:z dns-msg))
+      (d 5 "rcode" (flags:rcode dns-msg))))
+   ((question? dns-msg)
+    (begin
+      (d 4 "name " (question:name dns-msg))
+      (d 4 "type " (question:type dns-msg))
+      (d 4 "class" (question:class dns-msg))))
+   ((rr? dns-msg)
+    (begin
+      (d 4 "name " (rr:name dns-msg))
+      (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)))))))
+
+
+
+   
+;; 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")))