sunet/scheme/lib/dns.scm

; 
; dns.scm
;
; Client-Implementation of the RFC 1035 

;;; This file is part of the Scheme Untergrund Networking package.

;;; Copyright (c) 2002 by Marcus Crestani.
;;; Copyright (c) 2002-2003 by Martin Gasbichler
;;; Copyright (c) 2005-2006 by Norbert Freudemann
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.

; domain names - implementation and specification
; based on the PLT-implementation.
; 
;
; TODO: 
;       - test, test, test
;       - could be a good thing to merge dns.scm with the dnsd/resolver.scm?
;       - types from newer RFCs (41, unknown)
;       - more documentation
;
;
; ---
; sample usage & documentation:
;
;  <ip-address32> is a 32bit integer internet->address, shortly address32.
;  <ip-string> is a string in standard dot notation "xxx.xxx.xxx.xxx".
;  <name> is a string
;
;  <nameserver> can either be a domainname, an ip-string or an ip-address32.
;  if it is a domainname, its ip is looked up on a nameserver listed in
;  /etc/resolv.conf.
;
;  (dns-find-nameserver-list) --> <ip-string list>
;  this parses the /etc/resolv.conf file and returns the found 
;  nameserver in a list of dotted strings.
;
;  (dns-find-nameserver) --> <ip-string>
;  this parses the /etc/resolv.conf file and returns the first found 
;  nameserver in dotted string notation.
;
;  (dns-check-namservers [nameserver list]) --> undefined
;  checks if the given nameservers are reachable. If no argument is given,
;  the nameservers in /etc/resolv.conf are checked.
;
;  
;  (dns-lookup-name <name> [nameserver list] [use-cache?]) --> <ip-address32>
;  (dns-lookup-ip <ip-string | ip-address32> [nameserver list] [use-cache?]) 
;                     --> <name>
;  (dns-lookup-nameserver <name> [nameserver list] [use-cache?]) 
;                     --> <list of ip-address32s of authoritative nameservers>
;  (dns-lookup-mail-exchanger <name> [nameserver list] [use-cache?]) 
;                     --> <list of names of mail-exchangers>
; 
;  dns-lookup-name, dns-lookup-ip, dns-lookup-nameserver and 
;  dns-lookup-mail-exchanger are "simple lookup functions",
;  they return the wanted information or #f.
;  dns-lookup-ip can either be given an ip-string or an ip-address32.
;   
;  concurrent dns lookup:
;  if a list of nameservers is given to the optional <nameserver> argument,
;  a concurrent lookup to all nameservers in this list is started.
;  The nameservers in this list could either be ip-strings or ip-address32s.
;  example: (dns-lookup-name "www.uni-tuebingen.de" (dns-find-nameserver-list))
;           starts an concurrent lookup which contacts all nameservers in 
;           /etc/resolv.conf.
;
;
;  (dns-lookup <name | ip-string | ip-address32> <type> [nameserver list]) 
;                     --> <dns-message>
;  (show-dns-message <dns-message) --> the whole message, human readable
;
;  a <dns-message> is a record, with several entries, which holds the whole
;  query/response dialog. the simplest way to get detailed information about
;  the record structure is to view the result of show-dns-message.
;
;  dns-lookup returns much more information than the simple lookup functions, 
;  only useful in very special cases.
;  
;
;  some lookups return a hostname (e.g. mx). 
;  many applications need instead of a hostname a ip address.
;  force-ip and force-ip-list guarantee that a ip address is
;  returned.
;
;  (force-ip <name>) --> <ip>
;  (force-ip-list <list of names>) --> <list of ips>
;
;
;  useful converters:
;
;  (address32->ip-string <ip-address32>) -> <ip-string>
;  (ip-string->address32 <ip-string>) -> <ip-address32>



;; --- error conditions

;; supertype of all errors signaled by this library
(define-condition-type 'dns-error '(error))
(define dns-error? (condition-predicate 'dns-error))

(define-condition-type 'parse-error '(dns-error))
(define parse-error? (condition-predicate 'parse))

(define-condition-type 'unexpected-eof-from-server '(dns-error))
(define unexpected-eof-from-server? 
  (condition-predicate 'unexpected-eof-from-server))

(define-condition-type 'bad-address '(dns-error))
(define bad-address? (condition-predicate 'bad-address))

(define-condition-type 'no-nameservers '(dns-error))
(define no-nameservers? (condition-predicate 'no-nameservers))

(define-condition-type 'no-nameserver-given '(dns-error))
(define no-nameserver-given? (condition-predicate 'no-nameserver-given))

(define-condition-type 'bad-nameserver '(dns-error))
(define bad-nameserver? (condition-predicate 'bad-nameserver))

(define-condition-type 'not-a-hostname '(dns-error))
(define not-a-hostname? (condition-predicate 'not-a-hostname))

(define-condition-type 'not-a-ip '(dns-error))
(define not-a-ip? (condition-predicate 'not-a-ip))

;; supertype of all errors signaled if the dns server returned a non-sero
;; reply code
(define-condition-type 'dns-server-error '(dns-error))
(define dns-server-error? (condition-predicate 'dns-server-error))

(define-condition-type 'dns-format-error '(dns-server-error))
(define dns-format-error? (condition-predicate 'dns-format-error))

(define-condition-type 'dns-server-failure '(dns-server-error))
(define dns-server-failure? (condition-predicate 'dns-server-failure))

(define-condition-type 'dns-name-error '(dns-server-error))
(define dns-name-error? (condition-predicate 'dns-name-error))

(define-condition-type 'dns-not-implemented '(dns-server-error))
(define dns-not-implemented? (condition-predicate 'dns-not-implemented))

(define-condition-type 'dns-refused '(dns-server-error))
(define dns-refused? (condition-predicate 'dns-refused))

(define (dns-error condition . stuff)
  (apply signal condition (dns-error->string condition) stuff))

(define (dns-error->string condition)
  (string-append 
   "dns-error: "
   (case condition
     ((parse-error)
      "parse: error parsing server message")
     ((unexpected-eof-from-server)
      "send-receive-message: unexpected EOF from server")
     ((bad-address)
      "dns-get-information: bad address (in combination with query type)")
     ((no-nameservers)
      "dns-find-nameserver: no nameservers found in /etc/resolv.conf")
     ((no-nameserver-given)
      "dns-find-nameserver: no nameservers given")
     ((bad-nameserver)
      "send-receive-message: could not establish connection to server(s)")
     ((not-a-hostname)
      "no hostname given")
     ((not-a-ip)
      "no ip given")
     ((dns-format-error)
      "error from server: (1) format error")
     ((dns-server-failure) 
      "error from server: (2) server failure")
     ((dns-name-error) 
      "error from server: (3) name error")
     ((dns-not-implemented) 
      "error from server: (4) not implemented")
     ((dns-refused) 
      "error from server: (5) refused")
     (else (error "Unknown dns-error" condition)))))
  

;; --- (Q)Type and (Q)Class of a Message: ---

;; Message Type:
;; The IANA assigned type-values as in RFC 1035 and 3596 (IPv6) including the
;; super-set QTYPE starting at value 252+ that are needed for some queries.
(define-finite-type message-type :message-type
  (value)
  message-type?
  the-message-type
  message-type-name
  message-type-index
  (value message-type-number)
  ((unknown 0)      ; Types which are not yet implemented
   (a 1)            ; A host address 
   (ns 2)           ; An authoritative name server
   (md 3)           ; Obsolete
   (mf 4)           ; Obsolete
   (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 (deprecated in RFC 1123)
   (ptr 12)         ; A domain name pointer
   (hinfo 13)       ; Host information
   (minfo 14)       ; Experimental
   (mx 15)          ; Mail exchange
   (txt 16)         ; Text strings
   (aaaa 28)        ; An IPv6 host address
   (axfr 252)       ; A request for a zone-transfer
   (mailb 253)      ; A request for mailbox-related records
   (maila 254)      ; Obsolete
   (* 255)))        ; A request for all records


;; Search for a message type, given the IANA-assigned value.
;; TYPE: number -> message-type or #f
(define (message-type-number->type number)
  (let loop ((n (vector-length the-message-type)))
    (if (= n 0)
	#f
	(let ((m (- n 1)))
	  (if (= number (message-type-number (vector-ref the-message-type m)))
	      (vector-ref the-message-type m)
	      (loop m))))))


;; Returns the message-type for a symbol
;; TYPE: symbol -> message-type or #f
(define (message-type-symbol->type symbol)
  (let loop ((n (vector-length the-message-type)))
    (if (= n 0)
	#f
	(let ((m (- n 1)))
	  (if (eq? symbol (message-type-name (vector-ref the-message-type m)))
	      (vector-ref the-message-type m)
	      (loop m))))))


;; Message Classes:
;; The resource-record class-values including the super-set QCLASS
;; (* 255)...
(define-finite-type message-class :message-class
  (value)
  message-class?
  the-message-class
  message-class-name
  message-class-index
  (value message-class-number)
  ((in 1)             ; Internet
   (cs 2)             ; Obsolete
   (ch 3)             ; CHAOS
   (hs 4)             ; Hesiod
   (* 255)))          ; A QCLASS value: search for any class-entries.


;; Search for a message class, given the IANA-assigned value.  
;; TYPE: number -> message-class or #f
(define (message-class-number->type number)
  (let loop ((n (vector-length the-message-class)))
    (if (= n 0)
	#f
	(let ((m (- n 1)))
	  (if (= number (message-class-number (vector-ref the-message-class m)))
	      (vector-ref the-message-class m)
	      (loop m))))))


;; Returns the message-class for a symbol
;; TYPE: symbol -> message-class or #f
(define (message-class-symbol->type symbol)
  (let loop ((n (vector-length the-message-class)))
    (if (= n 0)
	#f
	(let ((m (- n 1)))
	  (if (eq? symbol (message-class-name (vector-ref the-message-class m)))
	      (vector-ref the-message-class m)
	      (loop m))))))



;;; -- useful stuff

;; number: 0<= x < 256
;; octet-pair: (char char)
;; octet-quad: (char char char char)
;; name: string *{"." string}
;; octets: *{(char *char)} nullchar
;; octet-ip: (char char char char)
;; address32: 0 <= x < 2^32-1
;; ip-string: "www.xxx.yyy.zzz"
;; ip-string-arpa: "zzz.yyy.xxx.www.in-addr.arpa"

;; encodes numbers (16bit) to octets
(define (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)
  (+ (arithmetic-shift (char->ascii a) 8)
     (char->ascii b)))

;; encodes numbers (32bit) to octets, needed for ttl
(define (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)
  (+ (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)))
  
  (define *nul* (ascii->char 0))

  (let loop ((s s))
    (cond
     ((regexp-search (rx (: bos (submatch (* (~ "."))) "." (submatch (* any))))
		     s)
      => (lambda (match)
	   (append
	    (encode-portion (match:substring match 1))
	    (loop (match:substring match 2)))))
     (else
      (if (= 0 (string-length s))
	  (list *nul*)
	  ;;; TODO isn't this case an error?
	  (append
	   (encode-portion s)
	   (list *nul*)))))))


;; for tcp: message has to be tagged with its length
(define (add-size-tag m)
  (append (number->octet-pair (length m)) m))

;; checks if v is an address32
(define (address32? v)
  (and (number? v) (<= 0 v #xffffffff)))
      
;; filters types in a list of rrs 
(define (filter-type list type)
  (filter (lambda (rr) 
	    (eq? (resource-record-type rr) type))
	  list))

;; sorts a mx-resource-record-list by preference. needed for dns-lookup-mail-exchanger.
(define (sort-by-preference mx-list)
  (sort-list mx-list 
	     (lambda (a b) 
	       (< (resource-record-data-mx-preference (resource-record-data a))
		  (resource-record-data-mx-preference (resource-record-data b))))))


;; returns an IP if available (additonal type-a processing)
(define (force-ip name)
  (let loop ((result (dns-lookup-name name)))
    (if (ip-string? result)
	result
	(loop (dns-lookup-name result)))))

;; returns a list of IPs (additional type-a processing)
(define (force-ip-list names)
  (map (lambda (elem) (force-ip elem)) names))


;; ----------------------------------
;; --- Dealing with domain names: ---
;; ----------------------------------

;; Regexp matching a label of a name
(define label-regexp
  (rx (: (| (: bos "." eos)
	    (:
	     bos
	     (submatch (| "*" (: alphanumeric (* (| alphanumeric "-")))))
	     "."
	     (submatch (| "" (: alphanumeric (* any))))
	     eos)))))


;; Splits a name in its first label an the rest
;; Note: (dn-split? "de." will be ("de" . "")
;; TYPE: string -> (string . string) or #f
(define (dn-split? name)
  (cond
   ((string=? name ".") #f)
   ((regexp-search label-regexp name)
    => (lambda (match)
	 (cons (match:substring match 1)
	       (match:substring match 2))))
   (else #f)))


;; Look if a string is a FQDN
;; TYPE: string -> boolean
(define (fqdn? name)
  (let loop ((name name))
    (cond
     ((dn-split? name)
      => (lambda (p)
	   (let ((cp (cdr p)))
	     (if (string=? cp "")
		 #t
		 (loop (cdr p))))))
     (else #f))))


;; Cuts the first label from a FQDN and returns the rest of the name.
;; TYPE: string -> string
(define (cut-name name)
  (cond
   ((regexp-search label-regexp name)
    => (lambda (match)
	 (let ((m (match:substring match 2)))
	   (if (string=? m "") "." m))))
   (else #f)))


; Adds an ending dot to a string if neccessary.
; TYPE: string -> string
(define (make-fqdn-name name)
  (let ((last-char (string-ref name (- (string-length name) 1))))
    (if (not (char=? #\. last-char))
	(string-append name ".")
	name)))


; --- Message Constructors: ---

; A standard query header, usefull for most queries.
; See RFC 1035 (4.1.1) for details.
(define (make-std-query-header id question-count)
  (let* ((qr 'query)    ; querytype: query 0, response 1
	 (opcode 0)     ; opcode: query 0, iquery 1 (OBSOLETE: see RFC 3425), status 2
	 (aa #f)        ; authorative answer (in answers only)
	 (tc #f)        ; truncation (size matters only with UDP)
	 (rd #t)        ; recursion desired: nameserver pursues the query recursivly (optional)
	 (ra #f)        ; recursion available (in answers only)
	 (zero 0)       ; future use
         (response-code 0)      ; response code: error conditions (in answers only)
	 (question-count question-count)
	 (answer-count 0)       ; answer count (in answers only)
	 (nameserver-count 0)   ; name server resources (in answers only)
	 (additional-count 0))  ; additional records (in answers only)
    
    (make-header 
     id 
     (make-flags qr opcode aa tc rd ra zero response-code)
     question-count answer-count nameserver-count additional-count)))


;; makes a query-message (header and question only)
;; TODO does this really work for several questions as well?
(define (make-query-message header question . questions)
  (let ((questions (cons question questions)))
    (make-message header questions '() '() '()
		  (apply 
		   append
		   (header->octets header)
		   (map question->octets questions)))))

(define (make-simple-query-message name type class)
  (make-query-message (make-std-query-header (random-integer 65536) 1)
		      (make-question name type class)))


;;; -- parsed message records

;; dns-message: complete data-structure of an dns-lookup
(define-record-type dns-message :dns-message
  (make-dns-message query reply cache? protocol tried-nameservers)
  dns-message?
  (query dns-message-query)
  (reply dns-message-reply)
  (cache? dns-message-cache?)
  (protocol dns-message-protocol)
  (tried-nameservers dns-message-tried-nameservers))

;; message
(define-record-type message :message
  (make-message header questions answers nameservers additionals source)
  message?
  (header message-header)
  (questions message-questions)
  (answers message-answers)
  (nameservers message-nameservers)
  (additionals message-additionals)
  (source message-source set-message-source!)) ; The bite-encoded message

;; header
(define-record-type header :header
  (make-header id flags question-count answer-count nameserver-count 
	       additional-count)
  header?
  (id header-id)
  (flags header-flags)
  (question-count header-question-count)
  (answer-count header-answer-count set-header-answer-count!)
  (nameserver-count header-nameserver-count set-header-nameserver-count!)
  (additional-count header-additional-count set-header-additional-count!))

;;; -- message constructors: encode to octet-messages

;; makes an message header
(define (header->octets header)
  (let* ((header-id (number->octet-pair (header-id header)))
	 (header-question-count (number->octet-pair (header-question-count header)))
	 (header-answer-count (number->octet-pair (header-answer-count header)))
	 (header-nameserver-count (number->octet-pair 
				   (header-nameserver-count header)))
	 (header-additional-count (number->octet-pair 
				   (header-additional-count header))))
    (append header-id
	    (flags->octets (header-flags header))
	    header-question-count
	    header-answer-count
	    header-nameserver-count
	    header-additional-count)))

;; flags
(define-record-type flags :flags
  (make-flags query-type opcode authoritative? truncated? recursion-desired? 
	      recursion-available? zero response-code)
  flags?
  (query-type            flags-query-type)
  (opcode                flags-opcode)
  (authoritative?        flags-authoritative? set-flags-authoritative!)
  (truncated?            flags-truncated? set-flags-truncated!)
  (recursion-desired?    flags-recursion-desired?)
  (recursion-available?  flags-recursion-available? set-flags-recursion-available!)
  (zero                  flags-zero)
  (response-code         flags-response-code set-flags-response-code!))

(define (make-flags-from-numbers 
	 querytype opcode authoritative? truncated? recursion-desired? 
	 recursion-available? zero response-code)
  (make-flags
   (if (zero? querytype) 'query 'response)
   opcode
   (not (zero? authoritative?))
   (not (zero? truncated?))
   (not (zero? recursion-desired?))
   (not (zero? recursion-available?))
   zero
   (case response-code
     ((0) 'dns-no-error)
     ((1) 'dns-format-error)
     ((2) 'dns-server-failure)
     ((3) 'dns-name-error)
     ((4) 'dns-not-implemented)
     ((5) 'dns-refused))))
   
(define (flags->octets flags)
  (define (boolean->0/1 bool)
    (if bool 1 0))
  (list 
   (ascii->char 
    (+ (arithmetic-shift 
	(if (eq? (flags-query-type flags) 'query) 0 1) 7)
       (arithmetic-shift (flags-opcode flags) 3)
       (arithmetic-shift 
	(boolean->0/1 (flags-authoritative? flags)) 2)
       (arithmetic-shift 
	(boolean->0/1 (flags-truncated? flags)) 1)
       (boolean->0/1 (flags-recursion-desired? flags))))
   (ascii->char 
    (+ (arithmetic-shift 
	(boolean->0/1 (flags-recursion-available? flags)) 7)
       (arithmetic-shift (flags-zero flags) 4)
       (let ((response-code (flags-response-code flags)))
	 (if (number? response-code)
	     response-code
	     (if (symbol? response-code)
		 (case response-code
		   ((dns-no-error) 0)
		   ((dns-format-error) 1)
		   ((dns-server-failure) 2)
		   ((dns-name-error) 3)
		   ((dns-not-implemented) 4)
		   ((dns-refused) 5)))))))))
		     

;; question
(define-record-type question :question
  (really-make-question name type class)
  question?
  (name question-name)
  (type question-type)
  (class question-class))

; Ensures the internal representation of a domain-name:
(define (make-question name type class)
  (really-make-question (make-fqdn-name name) type class))
   

;; makes a question (name, type, class)
(define (question->octets q)
  (let* ((qname   (name->octets (question-name q)))
	 (qtype   (number->octet-pair 
		   (message-type-number (question-type q))))
	 (qclass  (number->octet-pair 
		   (message-class-number (question-class q)))))
    (append qname qtype qclass)))

;;type  resource-record
(define-record-type resource-record :resource-record
  (make-resource-record name type class ttl data)
  resource-record?
  (name  resource-record-name)
  (type  resource-record-type)
  (class resource-record-class)
  (ttl   resource-record-ttl)
  (data  resource-record-data))

;; cache
(define-record-type cache :cache
  (make-cache answer ttl time)
  cache?
  (answer cache-answer)
  (ttl cache-ttl)
  (time cache-time))

;;; -- message parser

;; parses a domain-name in an message.
;; returns the name and the rest of the message.
(define (parse-name start message)
  (let ((v (char->ascii (car start))))
    (cond
     ((zero? v)
      ;; End of name
      (values "." (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 (string-ci=? s ".")
			   (string-append s0 ".")
			   (string-append s0 "." s))
		       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)
  (call-with-values
   (lambda () (parse-name start message))
   (lambda (name start)
     (let ((type (message-type-number->type 
		  (octet-pair->number (car start) (cadr start))))
	   (start (cddr start)))
       (let ((class (message-class-number->type
		      (octet-pair->number (car start) (cadr start))))
	     (start (cddr start)))
	 (values (make-question name type class) start))))))


;; parses a resource-record in a message. returns the rr and the
;; rest of the message.
(define (parse-rr start message)
  
  (define (type-number->type type-number)
    (let ((type (message-type-number->type type-number)))
      (if type
	  type
	  'unsupported-message-type)))
 
  (define (class-number->class class-number)
    (let ((class (message-class-number->type class-number)))
      (if class
	  class
	  'unsupported-message-class)))
  
  (call-with-values
      (lambda () (parse-name start message))
    (lambda (name start)
      (let ((type  (type-number->type
		    (octet-pair->number (car start) (cadr start))))
	    (start (cddr start)))
	(let ((class (class-number->class
		      (octet-pair->number (car start) (cadr start))))
	      (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-resource-record 
			     name type class ttl 
			     (parse-resource-record-data 
			      type class (reverse! accum) message)) start)
		    (loop (- len 1)
			  (cdr start)
			  (cons (car start) accum)))))))))))


;; -- Resource-Record records: ---

;; Data-Fields for the supported types of resource records:

(define-record-type resource-record-data-a :resource-record-data-a
  (make-resource-record-data-a ip)
  resource-record-data-a?
  (ip resource-record-data-a-ip))

(define-record-type resource-record-data-aaaa :resource-record-data-aaaa
  (make-resource-record-data-aaaa ipv6)
  resource-record-data-aaaa?
  (ipv6 resource-record-data-aaaa-ipv6))

 (define-record-type resource-record-data-ns :resource-record-data-ns
  (make-resource-record-data-ns name)
  resource-record-data-ns?
  (name resource-record-data-ns-name))

(define-record-type resource-record-data-cname :resource-record-data-cname
  (make-resource-record-data-cname name)
  resource-record-data-cname?
  (name resource-record-data-cname-name))

(define-record-type resource-record-data-hinfo :resource-record-data-hinfo
  (make-resource-record-data-hinfo data)
  resource-record-data-hinfo?
  (data resource-record-data-hinfo-data))

(define-record-type resource-record-data-mx :resource-record-data-mx
  (make-resource-record-data-mx preference exchanger)
  resource-record-data-mx?
  (preference resource-record-data-mx-preference)
  (exchanger resource-record-data-mx-exchanger))

(define-record-type resource-record-data-ptr :resource-record-data-ptr
  (make-resource-record-data-ptr name)
  resource-record-data-ptr?
  (name resource-record-data-ptr-name))

(define-record-type resource-record-data-soa :resource-record-data-soa
  (make-resource-record-data-soa mname rname serial refresh retry expire minimum)
  resource-record-data-soa?
  (mname resource-record-data-soa-mname)
  (rname resource-record-data-soa-rname)
  (serial resource-record-data-soa-serial)
  (refresh resource-record-data-soa-refresh)
  (retry resource-record-data-soa-retry)
  (expire resource-record-data-soa-expire)
  (minimum resource-record-data-soa-minimum))

(define-record-type resource-record-data-txt :resource-record-data-txt
  (make-resource-record-data-txt text)
  resource-record-data-txt?
  (text resource-record-data-txt-text))

;; ## not corretly implemented (deprecated in RFC 1123)
(define-record-type resource-record-data-wks :resource-record-data-wks
  (make-resource-record-data-wks data)
  resource-record-data-wks?
  (data resource-record-data-wks-data))


;; --------------------------------------------------
;; ---  Message-(Un)-Parser / message-compression ---
;; --------------------------------------------------

;; FQDNs are stored together with the assiciated pointer-number in
;; an association-list (a-list)
;; The octet-message is stored in the o-list


;; Returns an (if possible) compressed octet-name
;; TYPE: string x l-of-octets x l-of-names-> l-of-octets x l-of-names
(define (mc-name->octets name o-list a-list)
  ;; TYPE: string -> octets
  (define (encode-label s)
    (cons (ascii->char (string-length s)) (string->list s)))
  ;; Returns elements from the list-of-names who matches name
  (define (lookup? name a-list)
    (let ((res
	   (fold-right
	    (lambda (e l)
	      (if (string-ci=? name (car e))
		  (cons e l)
		  l))
	    '()
	    a-list)))
      (if (null? res) #f res)))
  ;; Create a pointer to another byte of an octet-message
  (define (make-name-pointer number)
    (if (<= number #x3FFF)
	(number->octet-pair (bitwise-ior #xC000 number))
	(error "This must be a very long message... .")))

  (cond
   ;; Nothing left?
   ((or (string=? name "") (string=? name "."))
    (values (append o-list (list (ascii->char 0))) a-list))
   ;; Matching FQDN?
   ((lookup? name a-list)
    => (lambda (e)
	 (values (append o-list (make-name-pointer (cdar e)))
		 a-list)))
   ;; Cut-and-retry:
   (else
    (let ((dn-pair (dn-split? name)))
      (if dn-pair
	  (mc-name->octets (cdr dn-pair)
			   (append o-list (encode-label (car dn-pair)))
			   (cons (cons name (length o-list)) a-list))
	  (error "mc-name->octets: Not a FQDN!"))))))
    

;; Converts a message-question-record-type into octets
;; TYPE: msg-question x l-of-octets x l-of-names -> l-of-octets x l-of-names
(define (mc-question->octets q o-list a-list)
  (receive (o-list a-list)
	   (mc-name->octets (question-name q) o-list a-list)
	   (values (append o-list
			   (number->octet-pair 
			    (message-type-number (question-type q)))
			   (number->octet-pair 
			    (message-class-number (question-class q))))
		   a-list)))


;; Translate the resource-record-data-*-content into octets.
;; TYPE: RR x list-of-octets x list-of-names -> list-of-octets x list-of-names 
(define (mc-rdata->octets rr o-list a-list)
  ;; TXT and HINFO strings
  (define (string-list->char-string-list l)
    (let loop ((l l)
	       (r '()))
      (if (null? l)
	  r
	  (let ((len (string-length (car l))))
	    (loop (cdr l)
		  (append
		   r
		   (list (ascii->char len))
		   (string->list (car l))))))))
  
  (let ((rr-data (resource-record-data rr)))
    (cond
     ;; Parser fallback:
     ((list? rr-data)
      (values (append o-list rr-data) a-list))
     ;; Only IN supported...
     ((eq? (message-class in) (resource-record-class rr))
      (cond
       ((resource-record-data-a? rr-data)
	(values (append o-list
			(address32->octet-ip 
			 (resource-record-data-a-ip rr-data)))
		a-list))
       ((resource-record-data-aaaa? rr-data) ;; TODO!
	(values (append o-list (resource-record-data-aaaa-ipv6 rr-data))
		a-list))
       ((resource-record-data-ns? rr-data)
	(mc-name->octets (resource-record-data-ns-name rr-data) o-list a-list))
       ((resource-record-data-cname? rr-data)
	(mc-name->octets (resource-record-data-cname-name rr-data) 
			 o-list a-list))
       ((resource-record-data-mx? rr-data)
	(mc-name->octets (resource-record-data-mx-exchanger rr-data)
			 (append o-list
				 (number->octet-pair 
				  (resource-record-data-mx-preference rr-data)))
			 a-list))
       ((resource-record-data-ptr? rr-data)
	(mc-name->octets (resource-record-data-ptr-name rr-data) o-list a-list))
       ((resource-record-data-soa? rr-data)
	(receive (o-list a-list)
		 (mc-name->octets (resource-record-data-soa-mname rr-data) 
				  o-list a-list)
		 (receive (o-list a-list)
			  (mc-name->octets 
			   (resource-record-data-soa-rname rr-data)
			   o-list a-list)
			  (values
			   (append o-list
				   (number->octet-quad
				    (resource-record-data-soa-serial rr-data))
				   (number->octet-quad
				    (resource-record-data-soa-refresh rr-data))
				   (number->octet-quad
				    (resource-record-data-soa-retry rr-data))
				   (number->octet-quad
				    (resource-record-data-soa-expire rr-data))
				   (number->octet-quad
				    (resource-record-data-soa-minimum rr-data)))
			   a-list))))
       ((resource-record-data-txt? rr-data)
	(values (append o-list (string-list->char-string-list 
				(resource-record-data-txt-text rr-data)))
		a-list))
       ((resource-record-data-hinfo? rr-data)
	(values (append o-list (string-list->char-string-list 
				(resource-record-data-hinfo-data rr-data))
			a-list)))
       ((resource-record-data-wks? rr-data) ;; Deprecated
	(values (append o-list (resource-record-data-wks-data rr-data) a-list)))
       (else (error "unknown-resource-record"))))
     (else (error "class not supported")))))


;; Handle the conversion of a RR into octets:
;; TYPE: RR x list-of-octets x list-of-names -> list-of-octets x list-of-names
(define (mc-resource-record->octets r o-list a-list)
  (receive (o-list a-list)
	   (mc-name->octets (resource-record-name r) o-list a-list)
	   (let* ((o-list
		   (append o-list
			   (number->octet-pair
			    (message-type-number (resource-record-type r)))
			   (number->octet-pair
			    (message-class-number (resource-record-class r)))
			   (number->octet-quad (resource-record-ttl r))))
		  ;; A placeholder value for RDLENGTH:
		  (o-list-w (append o-list (number->octet-pair 0))))
	     (receive (o-list-1 a-list-1)
		      (mc-rdata->octets r o-list-w a-list)
		      (let* ((l-ol (length o-list-w))
			     (oc-data (list-tail o-list-1 l-ol)))
			(values (append o-list
					(number->octet-pair (length oc-data))
					oc-data)
				a-list-1))))))


;; Converts a message-record-type into octets:
;; TYPE: message -> octet-message
(define (mc-message->octets m)
  ;; Convert the RRs:
  (define fold-proc-for-rrs
    (lambda (e p)
      (receive (o-list a-list)
	       (mc-resource-record->octets e (car p) (cdr p))
	       (cons o-list a-list))))

  ;;(pretty-print-dns-message m)
  (let* ((oct-header (header->octets (message-header m)))
	 (oct-q-pair
	  (fold ;; this is fold-left (srfi-1)
	   (lambda (e p)
	     (receive (o-list a-list)
		      (mc-question->octets e (car p) (cdr p))
		      (cons o-list a-list)))
	   (cons oct-header '())
	   (message-questions m)))
	 (oct-answ-pair
	  (fold fold-proc-for-rrs oct-q-pair (message-answers m)))
	 (oct-auth-pair
	  (fold fold-proc-for-rrs oct-answ-pair (message-nameservers m)))
	 (oct-addi-pair
	  (fold fold-proc-for-rrs oct-auth-pair (message-additionals m))))
    (car oct-addi-pair)))



;; ---

;; Parse the resource records data-field:

(define (parse-resource-record-data type class data message)

  (define (list-head l k)
    (if (<= k (length l))
	(let loop ((k k)
		   (l l)
		   (r '()))
	  (if (= 0 k)
	      r
	      (loop (- k 1)
		    (cdr l)
		    (append r (list (car l))))))
	(error "list-head")))

  (define (parse-char-strings data)
    (let loop ((len (char->ascii (car data)))
		(l (cdr data))
		(res '()))
       (let ((str (list->string (list-head l len))))
	 (if (> (length l) len)
	     (let ((tail (list-tail l len)))
	       (loop (char->ascii (car tail))
		     (cdr tail)
		     (append res (list str))))
	     (append res (list str))))))

  (cond
   ((eq? type (message-type a))
    (make-resource-record-data-a (octet-ip->address32 data)))
   
   ((eq? type (message-type aaaa))
    (make-resource-record-data-aaaa data)) ; TODO ...

   
   ((eq? type (message-type ns))
    (make-resource-record-data-ns (call-with-values 
		      (lambda () (parse-name data message))
		      (lambda (name rest) name))))

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

   ((eq? type (message-type mx))
    (make-resource-record-data-mx (octet-pair->number (car data) (cadr data))
		     (call-with-values
		      (lambda ()(parse-name (cddr data) message))
		      (lambda (name rest) name))))

   ((eq? type (message-type ptr))
    (make-resource-record-data-ptr (call-with-values
		       (lambda () (parse-name data message))
		       (lambda (name rest) name))))
   
   ((eq? type (message-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-resource-record-data-soa mname rname serial refresh retry expire minimum)))))))))))

   ;; The TXT&Hinfo-Type contains one or more <character-strings> 
   ;; (see. Ch.3.3// RFC 1035
   ((eq? type (message-type txt))
    (make-resource-record-data-txt
     (parse-char-strings data)))

   ((eq? type (message-type hinfo))
    (parse-char-strings data))
   
   ((eq? type (message-type wks))
    (make-resource-record-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)
  (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)
  (let ((v0 (list-ref message 2))
	(v1 (list-ref message 3)))
    ;; Check for error code:
    (let ((response-code  (bitwise-and #xf (char->ascii v1)))
	  (zero      (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-from-numbers qr opcode aa tc rd ra zero response-code))))


;; parses a message-header. returns the header.
(define (parse-header message)
  (let ((id       (octet-pair->number (list-ref message 0) (list-ref message 1)))
	(flags    (parse-flags message))
	(question-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 question-count an-count ns-count ar-count)))


;; parses a message. returns the parsed message.
(define (parse message)
  (let* ((header (parse-header message))
	 (start (list-tail message 12)))
    (call-with-values
     (lambda () (parse-n parse-question start message (header-question-count header)))
     (lambda (qds start)
       (call-with-values
	(lambda () (parse-n parse-rr start message (header-answer-count header)))
	(lambda (ans start)
	  (call-with-values
	   (lambda () (parse-n parse-rr start message (header-nameserver-count header)))
	   (lambda (nss start)
	     (call-with-values
	      (lambda () (parse-n parse-rr start message (header-additional-count header)))
	      (lambda (ars start)
		(if (not (null? start))
		    (dns-error 'parse-error))
		(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)
  ;; Check correct id
  (if (not (= (header-id (message-header reply))
	      (header-id (message-header query))))
      ;; TODO replace error
      (error "send-receive-message: bad reply id from server"))
  ;; Check for error code:
  (let ((response-code (flags-response-code 
			(header-flags (message-header reply)))))
    (if (not (eq? response-code 'dns-no-error))
	(dns-error response-code))))

(define *max-tries* 3)
(define *timeout* 1)

;; connects to nameserver and sends and receives messages. returns the reply.
;; here: via TCP
(define (send-receive-message-tcp nameserver query)
  (send-receive-message-tcp-int nameserver query reply-acceptable?))

(define (send-receive-message-tcp-int nameservers query accept?)
  (receive (reply hit-ns other-nss)
	   (let ((sockets (map
			   (lambda (nameserver)
			     (let ((sock (create-socket protocol-family/internet
							socket-type/stream))
				   (addr (internet-address->socket-address
					  nameserver 53)))
			       ;; we ignore the return value and select
			       ;; unconditionally later
			       (call-with-current-continuation
				(lambda (k)
				  (with-handler (lambda (cond more)
						  (k #f))
						(lambda ()
						  (connect-socket-no-wait sock addr)
						  sock))))))
			   nameservers)))
	(let* ((nameservers
		(let loop ((sockets sockets)
			   (nss nameservers))
		  (cond 
		   ((or (null? sockets) (null? nss)) '())
		   ((socket? (car sockets))
		    (cons (car nss) (loop (cdr sockets) (cdr nss))))
		   (else (loop (cdr sockets) (cdr nss))))))

	       (sockets (filter socket? sockets))
	       (ws (map socket:outport sockets))
	       (wport-nameserver-alist (map cons ws nameservers))
	       (wport-socket-alist (map cons ws sockets)))
	  (dynamic-wind
	   (lambda () 
	     'nothing-to-be-done-before)
	   (lambda ()
	     (let loop-port-channels ((tried-channels '())
				      (number-tries 1))
	       (letrec ((delete-list
			 (lambda (elems list)
			   (cond
			    ((null? elems) list)
			    ((null? list) '())
			    (else (delete-list (cdr elems) (delete (car elems) list))))))
			(ws-new (delete-list tried-channels ws)))
		 (if (or (null? ws-new) (>= number-tries *max-tries*))
		     (dns-error 'bad-nameserver)
		     (let ((ready (apply select-ports *timeout* ws)))
;;		     (let ((ready (apply select-port-channels *timeout* ws)))
		       (if (= (length tried-channels) (length ws))
			   (dns-error 'bad-nameserver)
			   (let loop-ready-channels ((ready-channels ready))
			     (if (null? ready-channels)
				 (loop-port-channels (append tried-channels ready) (+ number-tries 1))
				 (let* ((w (car ready-channels))
					(hit-ns (cdr (assoc w wport-nameserver-alist)))
					(sock (cdr (assoc w wport-socket-alist))))
				   (if (not (connect-socket-successful? sock))
				       (loop-ready-channels (cdr ready-channels))
				       (let ((query-string  
					      (list->string (add-size-tag (message-source query))))
					     (r (socket:inport sock)))
					 (call-with-current-continuation
					  (lambda (k)
					    (with-handler (lambda (cond more)
							    (k (loop-ready-channels (cdr ready-channels))))
							  (lambda ()
							    (display query-string 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 (and (not (= 0 (string-length s))) 
									   (not (= len (string-length s))))
								      (dns-error 'unexpected-eof-from-server))
								  (values (parse (string->list s))
									  hit-ns
									  (delete hit-ns nameservers))))))))))))))))))))
	   (lambda ()
	     (for-each close-socket sockets)))))
    (accept? reply query)
    (values reply hit-ns other-nss)))

;; here: via UDP
(define (send-receive-message-udp nameserver query)
  (send-receive-message-udp-int nameserver query reply-acceptable?))

(define (send-receive-message-udp-int nameservers query accept?)
  (receive (reply hit-ns other-nss)
      (let ((sockets (map (lambda (nameserver)
			    (let ((sock (create-socket protocol-family/internet
						       socket-type/datagram))
				  (addr (internet-address->socket-address
					 nameserver 53)))
			      (connect-socket sock addr)
			      sock))
			  nameservers)))
	(let ((rs (map socket:inport sockets))
	      (ws (map socket:outport sockets)))
	  (dynamic-wind
	   (lambda ()
	     'nothing-to-be-done-before)
	   (lambda ()
	     (let ((query-string (list->string (message-source query)))
		   (rsv (list->vector rs))
		   (rport-nameserver-alist (map cons rs nameservers))
		   (rport-socket-alist (map cons rs sockets)))
	       (for-each (lambda (w) (display query-string w)) ws)
	       (for-each force-output ws)
	       (let loop-port-channels ((tried-channels '())
					(number-tries 1))
		 (letrec ((delete-list
			   (lambda (elems list)
			     (cond
			      ((null? elems) list)
			      ((null? list) '())
			      (else (delete-list (cdr elems) (delete (car elems) list))))))
			  (rs-new (delete-list tried-channels rs)))
		   (if (or (null? rs-new) (>= number-tries *max-tries*))
		       (dns-error 'bad-nameserver)
		       (let ((ready (apply select-ports *timeout* rs-new))) 
;;		       (let ((ready (apply select-port-channels *timeout* rs-new))) 
			 (if (= (length tried-channels) (length rs))
			     (dns-error 'bad-nameserver)
			     (let loop-ready-channels ((ready-channels ready))
			       (if (null? ready-channels)
				   (loop-port-channels (append tried-channels ready) (+ number-tries 1))
				   (let* ((r (car ready-channels))
					  (hit-ns (cdr (assoc r rport-nameserver-alist))))
				     (if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist))))
					 (loop-ready-channels (cdr ready-channels))
					 ;; 512 is the maximum udp-message size:
					 (let ((answer (string->list (read-string/partial 512 r))))
					   (if (null? answer)
					       (loop-ready-channels (cdr ready-channels))
					       (values (parse answer)
						       hit-ns
						       (delete hit-ns nameservers)))))))))))))))
	   (lambda ()
	     (for-each close-socket sockets)))))
      (accept? reply query)
      (if (flags-truncated? (header-flags (message-header reply)))
	  (send-receive-message-tcp-int nameservers query accept?)
	  (values reply hit-ns other-nss))))



;;; -- cache

;; creates the cache, an empty 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)
  (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)
	       ((resource-record? dns-msg)
		(cond
		 ((not minimum)  (set! minimum (resource-record-ttl dns-msg)))
		 (else
		  (if (and (not minimum) (> minimum (resource-record-ttl dns-msg)))
		      (set! minimum (resource-record-ttl dns-msg))))))))))
    (find-shortest-ttl-1 dns-msg)))


(define (make-key qds nameserver)
  (let*;; cache-key relevant data
      ((name (question-name (car qds)))
       (type (question-type (car qds)))
       (class (question-class (car qds))))
    (format #f "~a;~a;~a;~a" 
	    nameserver 
	    name 
	    (message-type-name type)
	    (message-class-name class))))

(define (lookup-cache qds nameserver)
  (let* ((key (make-key qds nameserver))
	 (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))))
      found-data)
     (else #f))))

(define (update-cache! key entry)
  (table-set! *cache* key entry))

(define (dns-query-no-cache query protocol nameservers tried)
	 ;; returns new retrieved data
	 (receive (dns-msg hit-ns nss-with-no-reply)
	     (send-receive-message nameservers query protocol)
	   (values 
	    (make-dns-message query dns-msg  #f protocol (reverse tried))
	    hit-ns
	    nss-with-no-reply)))

(define (dns-query-with-cache query protocol nameservers tried)
  (let ((qds (message-questions query)))
    (let lp ((ns nameservers))
      (if (null? ns)
	  (receive 
	   (reply-msg hit-ns nss-with-no-reply)
	   (send-receive-message nameservers query protocol)
	   (update-cache! (make-key qds hit-ns) 
			  (make-cache reply-msg (find-shortest-ttl reply-msg) (time)))
	   ;; returns new retrieved data and updates cache
	   (values (make-dns-message query reply-msg #f protocol (reverse tried))
		   hit-ns
		   nss-with-no-reply))
	  (cond ((lookup-cache qds (car ns))
		 => (lambda (found-data)
		      ;; returns cached data
		      (values (make-dns-message query (cache-answer found-data) #t protocol '())
			      #f
			      nameservers)))
		(else (lp (cdr ns))))))))

(define-enumerated-type network-protocol :network-protocol
  network-protocol?
  network-protocols
  network-protocol-name
  network-protocol-index
  (udp tcp))

(define (send-receive-message nameservers query protocol)
  ((cond 
    ((eq? protocol (network-protocol tcp)) send-receive-message-tcp)
    ((eq? protocol (network-protocol udp)) send-receive-message-udp))
   nameservers query))
  
;; 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 query use-cache? protocol nameservers tried)
      (if use-cache?
	  (dns-query-with-cache query protocol nameservers tried)
	  (dns-query-no-cache query protocol nameservers tried)))

;; 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. 
;   (The means of trying recursion are given by the check-answer proc)


(define (dns-get-information query protocol check-answer . args)
  (receive (nameservers use-cache?) (lookup-optional-args args)
    (let lp ((tried '()) (nss nameservers))
      (display "Tried nameservers: ")
      (map (lambda (x) (display (address32->ip-string x)) (display " ")) tried)(newline)
      (display "Nameserver list: ")
      (map (lambda (x) (display (address32->ip-string x)) (display " ")) nss)(newline)
      (if (null? nss)
	  (if (null? tried)
	      (dns-error 'no-nameserver-given)
	      (dns-error 'bad-address))
	  (receive 
	   (dns-msg hit-ns nss-with-no-reply)
	   (dns-query/cache query use-cache? protocol nss tried)
	   (if (check-answer dns-msg)
	       dns-msg
	       (let ((auth? (flags-authoritative? 
			     (header-flags
			      (message-header
			       (dns-message-reply dns-msg))))))
		 (if auth?
		     (dns-error 'bad-address)
		     ;; other nameservers names are found in the nameserver-part,
		     ;; but their ip-adresses are found in the additonal-rrs
		     (let* ((other-nameservers-rr
			     (filter (lambda (elem) 
				       (eq? (resource-record-type elem) 
					    (message-type a)))
				     (message-additionals 
				      (dns-message-reply dns-msg))))
			    (other-nameservers
			     (map (lambda (e)
				    (resource-record-data-a-ip
				     (resource-record-data e)))
				  other-nameservers-rr)))
		       (lp (if (not (member hit-ns tried)) 
			       (cons hit-ns tried) 
			       tried)
			   (lset-union equal?
				       nss-with-no-reply
				       (lset-difference equal?
							other-nameservers 
							tried))))))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parsing of /etc/resolv.conf

(define-condition-type 'resolv.conf-parse-error '(dns-error))
(define resolv.conf-parse-error? (condition-predicate 'resolv.conf-parse-error))

(define (parse-nameserver rest-of-line)
  (let ((match (regexp-search
		(rx (: (submatch (** 1 3 digit) "."
				 (** 1 3 digit) "."
				 (** 1 3 digit) "."
				 (** 1 3 digit))
		       (* white))); don't complain about tailing white space
		rest-of-line)))
    (if match
	(cons 'nameserver (match:substring match 1))
	(signal 'resolv.conf-parse-error))))

; could be more restrictive...
(define domain-name-regexp (rx (+ (| alphanum #\. #\-))))

(define (parse-domain rest-of-line)
  (let ((match (regexp-search
		(rx (: (submatch ,domain-name-regexp)
		       (* white))); don't complain about tailing white space
		rest-of-line)))
    (if match
	(cons 'domain (match:substring match 1))
	(signal 'resolv.conf-parse-error))))
(define (parse-search rest-of-line)
  (let ((domains (regexp-fold-right domain-name-regexp 
				    (lambda (match junk accu)
				      (cons (match:substring match 0) accu))
				    '()
				    rest-of-line)))
    (if (null? domains)
	(signal 'resolv.conf-parse-error)
	(cons 'search domains))))

(define (parse-sortlist rest-of-line)
  (let ((netmask-pairs (regexp-fold-right (rx (+ (| digit #\. #\/)))
				    (lambda (match junk accu)
				      (cons (match:substring match 0) accu))
				    '()
				    rest-of-line)))
    (if (null? netmask-pairs)
	(signal 'resolv.conf-parse-error)
	(cons 'sortlist netmask-pairs))))

(define (parse-options rest-of-line)
  (regexp-fold-right 
   (rx (| "debug" "no_tld_query" (: "ndots:" (submatch digit))))
   (lambda (match junk accu)
     (let ((str (match:substring match 0)))
       (cond ((string=? str "debug")
	      (cons 'debug accu))
	     ((string=? str "no_tld_query")
	      (cons 'no_tld_query accu))
	     (else (cons (cons 'ndots 
			       (string->number (match:substring match 1))) accu)))))
   '()
   rest-of-line))

(define *resolv.conf-cache*)
(define *resolv.conf-cache-date* 0)
(define *resolv.conf-file* "/etc/resolv.conf")

(define (resolv.conf)
  (let ((actual-m-time (file-info:mtime (file-info *resolv.conf-file*))))
    (if (> actual-m-time *resolv.conf-cache-date*)
	(parse-resolv.conf!))
    *resolv.conf-cache*))

(define (parse-resolv.conf!)
  (let ((actual-m-time (file-info:mtime (file-info *resolv.conf-file*)))
	(contents (really-parse-resolv.conf *resolv.conf-file*)))
    (set! *resolv.conf-cache* contents)
    (set! *resolv.conf-cache-date* actual-m-time)))
  
(define (really-parse-resolv.conf file-name)

  ;; accumulate nameserver entries
  ;; domain and search are mutual exclusive, take the last
  (define (adjust-result rev-result have-search-or-domain? nameservers)
    (cond ((null? rev-result)
	   (if (null? nameservers)
	       '()
	       (list (cons 'nameserver nameservers))))
	  ((eq? (caar rev-result) 'domain)
	   (if have-search-or-domain?
	       (adjust-result (cdr rev-result) have-search-or-domain? nameservers)
	       (cons (car rev-result) 
		     (adjust-result (cdr rev-result) 
				    #t 
				    nameservers))))
	  ((eq? (caar rev-result) 'search)
	   (if have-search-or-domain?
	       (adjust-result (cdr rev-result) have-search-or-domain? nameservers)
	       (cons (car rev-result) 
		     (adjust-result (cdr rev-result) 
				    #t 
				    nameservers))))
	  ((eq? (caar rev-result) 'nameserver)
	   (adjust-result (cdr rev-result) 
			  have-search-or-domain? 
			  (cons (cdar rev-result)
				nameservers)))
	  (else (cons (car rev-result)
		      (adjust-result (cdr rev-result) 
				     have-search-or-domain? 
				     nameservers)))))

  (with-input-from-file file-name
    (lambda ()
      (let loop ((rev-result '()))
	(let ((l (read-line)))
	  (cond
	   ((eof-object? l)
	    (adjust-result rev-result #f '()))
	   ((regexp-search
	     (rx (: bos (| "#" ";")))
	     l)
	    (loop rev-result))
	   ((regexp-search
	     (rx (: bos "nameserver" (+ (| " " "\t")
				    (submatch (* any))
				    eos)))
	     l)
	    => (lambda (match)
		 (loop (cons (parse-nameserver (match:substring match 1))
			     rev-result))))
	   ((regexp-search
	     (rx (: bos "domain" (+ (| " " "\t")
				(submatch (* any))
				eos)))
	     l)
	    => (lambda (match)
		 (loop (cons (parse-domain (match:substring match 1))
			     rev-result))))
	   ((regexp-search
	     (rx (: bos "search" (+ (| " " "\t")
				(submatch (* any))
				eos)))
	     l)
	    => (lambda (match)
		 (loop (cons (parse-search (match:substring match 1))
			     rev-result))))
	     
	   ((regexp-search
	     (rx (: bos "sortlist" (+ (| " " "\t")
				  (submatch (* any))
				  eos)))
	     l)
	    => (lambda (match)
		 (loop (cons (parse-sortlist (match:substring match 1))
			     rev-result))))


	   ((regexp-search
	     (rx (: bos "options" (+ (| " " "\t")
				 (submatch (* any))
				 eos)))
	     l)
	    => (lambda (match)
		 (loop (cons (parse-options (match:substring match 1))
			     rev-result))))
	   ;; skips lines with parse errors, instead of 
	   ;; raising a 'resolv.conf-parse-error
	   (else (loop rev-result))))))))
					

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Figure out the default name servers

(define (dns-find-nameserver-list)
  (cond ((assoc 'nameserver (resolv.conf))
	 => (lambda (nameserver.list)
	      (cdr nameserver.list)))
	(else '("127.0.0.1"))))

;; returns the first found nameserver
(define (dns-find-nameserver)
  (let ((ns (dns-find-nameserver-list)))
    (if (null? ns)
	(dns-error 'no-nameservers)
	(car ns))))

;; checks if the nameservers are working, prints a summary
(define (dns-check-nameservers . args)
  (let* ((print-summary
	  (lambda (working-channels non-working-channels)
	    (for-each (lambda (channel)
		       (display "FAIL: ")(display channel)
		       (display " - host not reachable.")(newline))
		     non-working-channels)
	    (for-each (lambda (channel)
		       (display "PASS: ")(display channel)
		       (display " - connection established.")(newline))
		     working-channels)
	    (if (null? working-channels)
		(begin (display "ERROR: no working nameserver found.")(newline)))))

	 (nameservers (if (null? args)
			  (dns-find-nameserver-list)
			  (car args)))
	 (sockets  (map
		    (lambda (nameserver)
		      (let ((sock (create-socket protocol-family/internet
						 socket-type/stream))
			    (addr (internet-address->socket-address
				   (ip-string->address32 nameserver) 53)))
			(call-with-current-continuation
			 (lambda (k)
			   (with-handler (lambda (cond more)
					   (display "FAIL: ")
					   (display nameserver)
					   (display " - no DNS Service available.")
					   (newline)
					   (k #f))
					 (lambda ()
					   (connect-socket-no-wait sock addr)
					   sock))))))
		    nameservers)))
    
    (let* ((nameservers
	    (let loop ((sockets sockets)
		       (nss nameservers))
	      (cond 
	       ((or (null? sockets) (null? nss)) '())
	       ((socket? (car sockets))
		(cons (car nss) (loop (cdr sockets) (cdr nss))))
	       (else (loop (cdr sockets) (cdr nss))))))

	   (sockets (filter socket? sockets))
	   (ws (map socket:outport sockets))
	   (wport-nameserver-alist (map cons ws nameservers))
	   (wport-socket-alist (map cons ws sockets)))
      (dynamic-wind
       (lambda () 
	 'nothing-to-be-done-before)
       (lambda ()
	 (let loop-port-channels ((working-channels '())
				  (non-working-channels '())
				  (tried-channels '())
				  (number-tries 1))
	   (letrec ((delete-list
		     (lambda (elems list)
		       (cond
			((null? elems) list)
			((null? list) '())
			(else (delete-list (cdr elems) (delete (car elems) list))))))
		    (ready (delete-list tried-channels
				   (apply select-port-channels *timeout* ws))))

	     (if (or (>= number-tries *max-tries*))
		 (print-summary working-channels 
				(delete-list working-channels 
					     (delete-list non-working-channels 
							  nameservers)))
		 (let loop-ready-channels ((working-channels working-channels)
					   (non-working-channels non-working-channels)
					   (ready-channels ready))
		   (if (null? ready-channels)
		       (loop-port-channels working-channels
					   non-working-channels
					   (append tried-channels ready)
					   (+ number-tries 1))
		       (let* ((w (car ready-channels))
			      (hit-ns (cdr (assoc w wport-nameserver-alist)))
			      (sock (cdr (assoc w wport-socket-alist))))
			 (if (connect-socket-successful? sock)
			     (loop-ready-channels (append working-channels (list hit-ns))
						  non-working-channels (cdr ready-channels))
			     (loop-ready-channels working-channels
						  (append non-working-channels 
							  (list hit-ns))
						  (cdr ready-channels))))))))))
       (lambda ()
	 (for-each close-socket sockets))))))


;; computes the nameservers argument of the lookup functions.
;; if a nameserver-name is given and not a nameserver-ip
;; (dns-lookup-name nameserver) is called.
;; use-cache? defaults to #t
(define (lookup-optional-args args)
  (if (null? args)
      (values (map ip-string->address32 (dns-find-nameserver-list)) #t)
      (values
       (map (lambda (nameserver)
	      (cond
	       ((address32? nameserver) nameserver)
	       ((ip-string? nameserver) (ip-string->address32 nameserver))
	       (else (map dns-lookup-name (dns-find-nameserver-list)))))
	    (car args))
       (if (null? (cdr args))
	   #t
	   (cadr args)))))

;; dns-lookup with more options than dns-lookup-*
(define (dns-lookup name type . args)
  (receive (nameservers use-cache?) (lookup-optional-args args)
    (let* ((maybe-ip-string (if (address32? name) 
				(ip-string->in-addr.arpa-string (address32->ip-string name))
				(ip-string->in-addr.arpa-string name)))
	   (query (if maybe-ip-string	; if name is a ip-addr, the query is a in-addr.arpa address
		      (make-simple-query-message
		       maybe-ip-string type (message-class in))
		      (make-simple-query-message name type (message-class in))))
	   (protocol (network-protocol udp))
	   (check-answer (lambda (dns-msg) #t))
	   (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?))
	   (answers (message-answers (dns-message-reply dns-msg))))
      dns-msg)))


;; looks up a hostname, returns an ip.
;; (dns-lookup-name <name> nameservers)
(define (dns-lookup-name name . args)
  (receive (nameservers use-cache?) (lookup-optional-args args)
    (let* ((maybe-ip-string (if (address32? name) 
				(ip-string->in-addr.arpa-string (address32->ip-string name))
				(ip-string->in-addr.arpa-string name)))
	   (query (if maybe-ip-string	; if name is a ip-addr, the query is a in-addr.arpa address
		      (dns-error 'not-a-hostname)
		      (make-simple-query-message name (message-type a) (message-class in))))
	   (protocol (network-protocol udp))
	   (check-answer (lambda (dns-msg) 
			   (let* ((reply (dns-message-reply dns-msg))
				  (answers (message-answers reply)))
			     (not (null? (filter-type answers (message-type a)))))))
	   (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?))
	   (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type a))))
      (resource-record-data-a-ip (resource-record-data (car answers))))))

;; looks up an ip, returns a hostname
;; (dns-inverse-lookup <name> [nameserver])
(define (dns-lookup-ip ip . args)
  (receive (nameservers use-cache?) (lookup-optional-args args)
    (let* ((maybe-ip-string (if (address32? ip) 
				(ip-string->in-addr.arpa-string (address32->ip-string ip))
				(ip-string->in-addr.arpa-string ip)))
	   (query (if maybe-ip-string	; if name is a ip-addr, the query is a in-addr.arpa address
		      (make-simple-query-message maybe-ip-string (message-type ptr) (message-class in))
		      (dns-error 'not-a-ip)))
	   (protocol (network-protocol udp))
	   (check-answer (lambda (dns-msg) 
			   (let* ((reply (dns-message-reply dns-msg))
				  (answers (message-answers reply)))
			     (not (null? (filter-type answers (message-type ptr)))))))
	   (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?))
	   (answers (filter-type (message-answers (dns-message-reply dns-msg)) (message-type ptr))))
      (resource-record-data-ptr-name (resource-record-data (car answers))))))

(define dns-inverse-lookup dns-lookup-ip)

;; looks up an authoritative nameserver for a hostname
;; returns a list of nameservers
;; (dns-lookup-nameserver <name> [nameserver])
(define (dns-lookup-nameserver name . args)
  (receive (nameservers use-cache?) (lookup-optional-args args)
    (let* ((maybe-ip-string (if (address32? name) 
				(ip-string->in-addr.arpa-string (address32->ip-string name))
				(ip-string->in-addr.arpa-string name)))
	   (query (if maybe-ip-string	; if name is a ip-addr, the query is a in-addr.arpa address
		      (dns-error 'not-a-hostname)
		      (make-simple-query-message
		       name (message-type ns) (message-class in))))
	   (protocol (network-protocol udp))
	   (check-answer (lambda (dns-msg) 
			   (let* ((reply (dns-message-reply dns-msg))
				  (answers (message-answers reply))
				  (nameservers (message-nameservers reply)))
			     (or (not (null? (filter-type nameservers (message-type soa))))
				 (not (null? (filter-type answers (message-type ns))))))))
	   (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?))
	   (reply (dns-message-reply dns-msg))
	   (soa (filter-type (message-nameservers reply) (message-type soa)))
	   (nss (filter-type (message-answers reply) (message-type ns)))
	   (add (filter-type (message-additionals reply) (message-type a))))
      (if (null? nss)
	  (list (dns-lookup-name (resource-record-data-soa-mname (resource-record-data (car soa)))))
	  (map (lambda (elem) (resource-record-data-a-ip (resource-record-data elem))) add)))))

;; looks up a mail-exchanger for a hostname.
;; returns a list of mail-exchanger, sorted by their preference
;; if there are no mx-records in the answer-section, 
;; implementation based on RFC2821
;; (dns-lookup-mail-exchanger <name> [nameserver])
(define (dns-lookup-mail-exchanger name . args)
  (receive (nameservers use-cache?) (lookup-optional-args args)
    (let* ((ip-string (if (address32? name) 
			  (ip-string->in-addr.arpa-string (address32->ip-string name))
			  (ip-string->in-addr.arpa-string name)))
	   (query (if ip-string		; if name is a ip-addr, the query is a in-addr.arpa address
		      (dns-error 'not-a-hostname)
		      (make-simple-query-message
		       name (message-type mx) (message-class in))))
	   (protocol (network-protocol tcp))
	   (check-answer (lambda (dns-msg) 
			   (let* ((reply (dns-message-reply dns-msg))
				  (answers (message-answers reply))
				  (nameservers (message-nameservers reply)))
			     (or (not (null? (filter-type answers (message-type mx))))
				 (not (null? (filter-type answers (message-type cname))))
				 (not (null? (filter-type answers (message-type a))))))))
	   (dns-msg (dns-get-information query protocol check-answer nameservers use-cache?))
	   (reply (dns-message-reply dns-msg))
	   (mx (filter-type (message-answers reply) (message-type mx)))
	   (soa (filter-type (message-nameservers reply)(message-type soa)))
	   (cname (filter-type (message-answers reply) (message-type cname)))
	   (a (filter-type (message-answers reply) (message-type a))))

      (cond
       ((not (null? a)) 
	(list (resource-record-data-a-ip (resource-record-data (car a)))))
       ((not (null? cname))
	(dns-lookup-mail-exchanger (resource-record-data-cname-name (resource-record-data (car cname)))))
       ((null? mx) 
	(list (resource-record-data-soa-rname (resource-record-data (car soa)))))
       (else
	(map (lambda (elem) (resource-record-data-mx-exchanger (resource-record-data elem))) (sort-by-preference mx)))))))

;;; pretty-prints a dns-msg
(define (pretty-print-dns-message dns-msg . maybe-port)
  (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)))))
    (with-current-output-port*
     (if (null? maybe-port)
	 (current-output-port)
	 (car maybe-port))
     (lambda ()
       (define (show-dns-message dns-msg)
	 (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 (network-protocol tcp)) "TCP")
				((eq? protocol (network-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-question-count dns-msg))
	     (d 4 "answer-count      " (header-answer-count dns-msg))
	     (d 4 "nameserver-count  " (header-nameserver-count dns-msg))
	     (d 4 "additional-count  " (header-additional-count dns-msg))))
	  ((flags? dns-msg)
	   (begin 
	     (d 5 "querytype" (flags-query-type dns-msg))
	     (d 5 "opcode" (flags-opcode dns-msg))
	     (d 5 "authoritative?" (flags-authoritative? dns-msg))
	     (d 5 "truncated?" (flags-truncated? dns-msg))
	     (d 5 "recursion-desired?" (flags-recursion-desired? dns-msg))
	     (d 5 "recursion-available?" (flags-recursion-available? dns-msg))
	     (d 5 "zero" (flags-zero dns-msg))
	     (d 5 "response-code" (flags-response-code dns-msg))))
	  ((question? dns-msg)
	   (begin
	     (d 4 "name " (question-name dns-msg))
	     (d 4 "type " (message-type-name (question-type dns-msg)))
	     (d 4 "class" (message-class-name (question-class dns-msg)))))
	  ((resource-record? dns-msg)
	   (begin
	     (d 4 "name " (resource-record-name dns-msg))
	     (d 4 "type "(message-type-name (resource-record-type dns-msg)))
	     (d 4 "class" (message-class-name (resource-record-class dns-msg)))
	     (d 4 "ttl  " (resource-record-ttl dns-msg))
	     (d 4 "data " "") (show-dns-message (resource-record-data dns-msg))))
	  ((resource-record-data-a? dns-msg)
	   (d 5 "ip " (address32->ip-string (resource-record-data-a-ip dns-msg))))
	  ((resource-record-data-aaaa? dns-msg)
	   (d 5 "ipv6 " (resource-record-data-aaaa-ipv6 dns-msg)))
	  ((resource-record-data-ns? dns-msg)
	   (d 5 "name " (resource-record-data-ns-name dns-msg)))
	  ((resource-record-data-cname? dns-msg)
	   (d 5 "name " (resource-record-data-cname-name dns-msg)))
	  ((resource-record-data-mx? dns-msg)
	   (begin
	     (d 5 "preference " (resource-record-data-mx-preference dns-msg))
	     (d 5 "exchanger  " (resource-record-data-mx-exchanger dns-msg))))
	  ((resource-record-data-ptr? dns-msg) 
	   (d 5 "name " (resource-record-data-ptr-name dns-msg)))
	  ((resource-record-data-soa? dns-msg)
	   (begin
	     (d 5 "mname   " (resource-record-data-soa-mname dns-msg))
	     (d 5 "rname   " (resource-record-data-soa-rname dns-msg))
	     (d 5 "serial  " (resource-record-data-soa-serial dns-msg))
	     (d 5 "refresh " (resource-record-data-soa-refresh dns-msg))
	     (d 5 "retry   " (resource-record-data-soa-retry dns-msg))
	     (d 5 "expire  " (resource-record-data-soa-expire dns-msg))
	     (d 5 "minimum " (resource-record-data-soa-minimum dns-msg))))
	  ;; ###
	  ((resource-record-data-hinfo? dns-msg)
	   (d 5 "data " (resource-record-data-hinfo-data dns-msg)))
	  ((resource-record-data-txt? dns-msg)
	   (d 5 "text " (resource-record-data-txt-text dns-msg)))
	  ((resource-record-data-wks? dns-msg)
	   (d 5 "data " (resource-record-data-wks-data dns-msg)))
	  ))
       (show-dns-message dns-msg)))))

(define (socket-address->fqdn addr . args)
  (receive (ip32 port)
      (socket-address->internet-address addr)
    (apply dns-lookup-ip ip32 args)))

;; Some code to test the components of domain names
;;(define label-regexp
;;  (rx (: alpha (? (* (| alphanumeric "-")) alphanumeric))))
;;(define (unqualified-hostname name)
;;  (regexp-search? (rx (: ,label-regexp)) name))


(define (maybe-dns-lookup-name name . args)
  (call-with-current-continuation
   (lambda (k)
     (with-handler (lambda (cond more)
		     (if (dns-error? cond)
			 (k #f)
			 (more)))
		   (lambda ()
		     (apply dns-lookup-name name args))))))

(define (maybe-dns-lookup-ip ip-addr . args)
  (call-with-current-continuation
   (lambda (k)
     (with-handler (lambda (cond more)
		     (if (dns-error? cond)
			 (k #f)
			 (more)))
		   (lambda ()
		     (apply dns-lookup-ip ip-addr args))))))

(define (domains-for-search)
  (cond ((assoc 'domain (resolv.conf))
	 => (lambda (pair)
	      (list (cdr pair))))
	((assoc 'search (resolv.conf))
	 => (lambda (pair)
	      (cdr pair)))
	(else '())))

(define (host-fqdn name-or-socket-address . args)
  (if (socket-address? name-or-socket-address)
      (apply socket-address->fqdn name-or-socket-address args)
      (let ((name name-or-socket-address))
	(cond ((apply maybe-dns-lookup-name name args)
	       => (lambda (ip)
		    (apply dns-lookup-ip ip args)))
	      (else
	       (let lp ((domains (domains-for-search)))
		 (if (null? domains)
		     #f
		     (cond ((apply maybe-dns-lookup-name 
				   (string-append name "." (car domains)) args)
			    => (lambda (ip)
				 (apply dns-lookup-ip ip args)))
			   (else (lp (cdr domains)))))))))))

(define (system-fqdn . args)
  (apply host-fqdn (system-name) args))