sunet/dns.scm

; 
; dns.scm
;
; Implementation of the RFC1035 
; domain names - implementation and specification
; based on the PLT-implementation.
; 
;
; TODO: -*!!! CHECK-ANSWER !!! 
;        *(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
;       -*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> [nameserver]) --> <ip>
;  (dns-lookup-ip <ip> [nameserver]) --> <name>
;  (dns-lookup-nameserver <name> [nameserver]) --> <ip of authoritative nameserver>
;  (dns-lookup-mail-exchanger <name> [nameserver]) --> <mail-exchanger>
;   
;  (dns-lookup <name/ip> <type> [nameserver]) --> <dns-message>
;  (show-dns-message <dns-message) --> the whole message, human readable
;
;  (concurrent-lookup <dns-lookup-*> <name>)



;;; 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 host address 
    (ns 2)     ; an authoritative name server
    (md 3)     ; (obsolete)
    (mf 4)     ; (obsolete)
    (cname 5)  ; the canonical name for an alias
    (soa 6)    ; marks the start of a zone of authority
    (mb 7)     ; (experimental)
    (mg 8)     ; (experimental)
    (mr 9)     ; (experimental)
    (null 10)  ; (experimental)
    (wks 11)   ; a well known service description
    (ptr 12)   ; a domain name pointer
    (hinfo 13) ; host information
    (minfo 14) ; mailbox or mail list information
    (mx 15)    ; mail exchange
    (txt 16))) ; text strings

;; message classes
(define classes
  '((in 1)     ; the Internet
    (cs 2)     ; (obsolete)
    (ch 3)     ; the CHAOS class
    (hs 4)))   ; Hesoid


;;; -- useful stuff

;; assoc the other way round
(define (cossa i l)
  (if *debug* (display "cossa\n"))
  (cond
   ((null? l) (error "dns-message: type not implemented: " i))
   ((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
     ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s)
      => (lambda (match)
	   (append
	    (encode-portion (match:substring match 1))
	    (loop (match:substring match 2)))))
     (else
      (if (= 0 (string-length s))
	  (list *nul*)
	  (append
	   (encode-portion s)
	   (list *nul*)))))))

;; 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))

;; converts an octeted-ip to an human readable ip-string
(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))))

;; converts an ip-string to octets
(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))))))))

;; calculates a "random" number, needed for message-ids
(define random
  (let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
    (lambda (limit)
      (quotient (* (modulo (crank) 314159265)
		   limit)
		314159265))))

;; 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)
	     (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?
  protocol
  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)
      ;; End of name
      (values #f (cdr start)))
     ((zero? (bitwise-and #xc0 v))
      ;; Normal label
      (let loop ((len v)
		 (start (cdr start))
		 (accum '()))
	(cond
	 ((zero? len)
	  (call-with-values
	   (lambda () (parse-name start message))
	   (lambda (s start)
	     (let ((s0 (list->string (reverse! accum))))
	       (values (if s
			   (string-append s0 "." s)
			   s0)
		       start)))))
	 (else (loop (- len 1)
		     (cdr start)
		     (cons (car start) accum))))))
     (else
      ;; Compression offset
      (let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
		       (char->ascii (cadr start)))))
	(call-with-values
	 (lambda () (parse-name (list-tail message offset) message))
	 (lambda (s ignore-start)
	   (values s (cddr start)))))))))

;; 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 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)))
       (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
	     (start (cddr start)))
	 (let ((ttl (octet-quad->number (car start) (cadr start)
					(caddr start) (cadddr start)))
	       (start (cddddr start)))
	   (let ((len (octet-pair->number (car start) (cadr start)))
		 (start (cddr start)))
	     ;; Extract next len bytes of data:
	     (let loop ((len len)
			(start start)
			(accum '()))
	       (if (zero? len)
		   (values (make-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start)
		   (loop (- len 1)
			 (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
  exchanger)

(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) 
    (make-rr-data-a (ip->string data)))
   
   ((eq? type 'ns) 
    (make-rr-data-ns (call-with-values 
		      (lambda () (parse-name data message))
		      (lambda (name rest) name))))

   ((eq? type 'cname) 
    (make-rr-data-cname (call-with-values
			 (lambda () (parse-name data message))
			 (lambda (name rest) name))))

   ((eq? type 'mx)
    (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)
    (make-rr-data-ptr (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)))
		    (make-rr-data-soa mname rname serial refresh retry expire minimum)))))))))))

   ((eq? type 'hinfo)
    (make-rr-data-hinfo (list->string data)))

   ((eq? type 'txt)
    (make-rr-data-txt (list->string data)))
   
   ((eq? type 'wks)
    (make-rr-data-wks 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 message))
	 (lambda (rr start)
	   (loop (- n 1) start (cons rr accum)))))))

;; parses a message-headers flags. returns the flags.
(define (parse-flags message)
  (if *debug* (display "parse-flags\n"))
  (let ((v0 (list-ref message 2))
	(v1 (list-ref message 3)))
      ;; 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))))


;; 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))))
      (display "send-receive-message: bad reply id from server"))
  ;; Check for error code:
  (let ((rcode (flags:rcode (parse-flags reply))))
    (if (not (zero? 0));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.
;; here: via TCP
(define (send-receive-message-tcp nameserver question)
  (if *debug* (display "send-receive-message\n"))
  (let* ((query question)
	 (reply
	  (let ((socket (socket-connect protocol-family/internet
					socket-type/stream
					nameserver 53)))
	    (let ((r (socket:inport socket))
		  (w (socket:outport socket)))
	      (dynamic-wind
	       (lambda ()
		 'nothing-to-be-done-before)
	       (lambda ()
		 (display (list->string (add-size-tag query)) w)
		 (force-output w)
	       
		 (let ((a (read-char r))
		       (b (read-char r)))
		   (let ((len (octet-pair->number a b)))
		     (let ((s (read-string len r)))
		       (if (not (= len (string-length s)))
			   (error "send-receive-message: unexpected EOF from server"))
		       (string->list s)))))
	       (lambda ()
		 (close-socket socket)))))))
    (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
(define cache (make-string-table))

;; resets the cache
(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? protocol nameserver tried)
  (if *debug* (display "dns-query/cache\n"))
  (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
;;  nameserver, another nameserver (usualy an authority) has to be contacted.
;;  normally the recursion is done for us by the nameserver istself, but
;;  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? protocol nameserver check-answer)
  (if *debug* (display "dns-get-information\n"))
  (letrec ((tried (list nameserver))
	   ;; 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)) 
		  (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))
					   (set! tried (cons 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.
	   (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 (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))))



;; 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 ((ns '()))
	(let ((l (read-line)))
	  (cond
	   ((eof-object? l)
	    (if (null? ns)
		(error "dns-find-nameserver-list: no nameserver(s) found in /etc/resolv.conf")
		ns))
	   ((regexp-search (posix-string->regexp "nameserver[ 	]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
	    => (lambda (match)
		 (loop (append ns (list (match:substring match 1))))))
	   (else
	    (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))))



;; concurrent-lookup
;; starts a <lookup>-lookup to all nameservers in (dns-find-nameserver-list)
(define (concurrent-lookup lookup name)
  (let* ((return 'no-value)
	 (lock (make-lock))
	 (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")
			    (let* ((result (apply lookup (list name nameserver))))
			      (enqueue! queue result)
			      (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)))
	(if (or result (= 1 (length nameserver-list)))
	    result
	    (loop (- count 1)))))))
		       
;; 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 (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 "no answers received - but resolved information in other sections.\n"))
    dns-msg))



;; 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 (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))))))
	 (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
;; (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 (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))))))
	 (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
;; (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 (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))
			       (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)))))
    (dns-lookup-name (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.
;; (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
		       (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 (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)))
			      (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)))))))))))





;;; 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 "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: ")
				     (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 " "") (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 "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)
    (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)))
   
   )))