IPs are now 32bit integer internet addresses,

changed the API for concurrent-lookup,
revised the documentation

scheme/lib/dns.scm

@@ -14,31 +14,40 @@
 ; ---
 ; sample usage & documentation:
 ;
-;  <name>, <ip-string> and <nameserver> are strings.
+;  <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 or a ip.
+;  <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) --> <ip-string>
+;  (dns-find-nameserver) --> <ip-address32>
 ;  this parses the /etc/resolv.conf file and returns the first found 
-;  nameserver.
+;  nameserver in address32 format.
 ;
 ;
 ;  
-;  (dns-lookup-name <name> [nameserver]) --> <ip-string>
-;  (dns-lookup-ip <ip-string> [nameserver]) --> <name>
+;  (dns-lookup-name <name> [nameserver]) --> <ip-address32>
+;  (dns-lookup-ip <ip-string | ip-address32> [nameserver]) --> <name>
 ;  (dns-lookup-nameserver <name> [nameserver]) 
-;                        --> <list of ip-strings of authoritative nameservers>
+;                     --> <list of ip-address32s of authoritative nameservers>
 ;  (dns-lookup-mail-exchanger <name> [nameserver]) 
-;                        --> <list of names of mail-exchangers>
+;                     --> <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:
+;  a concurrent lookup to all nameservers in /etc/resolv.conf is started,
+;  if the variable dns-concurrent-lookup is given as optional <nameserver>
+;  argument.
 ;
-;  (dns-lookup <name/ip-string> <type> [nameserver]) --> <dns-message>
+;
+;  (dns-lookup <name | ip-string | ip-address32> <type> [nameserver]) 
+;                     --> <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
@@ -49,18 +58,20 @@
 ;  only useful in very special cases.
 ;  
 ;
-;  (concurrent-lookup <simple lookup function> <name>)
-;  starts a concurrent lookup to all nameservers in /etc/resolv.conf.
-;  the simple lookup function defines the lookup type.
-;
-;
 ;  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-string>
+;  (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>
+
 
 
 
@@ -151,6 +162,8 @@
    (else (more))))
   
 
+;; concurrent-flag
+(define dns-concurrent-lookup 'dns-concurrent-lookup)
 
 ;;; -- globals and types
 
@@ -254,9 +267,40 @@
   (if *debug* (display "add-size-tag\n"))
   (append (number->octet-pair (length m)) m))
 
+;; converts an octeted-ip to a 32bit integer internet-address
+(define (octet-ip->address32 ip)
+  (if *debug* (display "octet-ip->address32\n"))
+  (+ (arithmetic-shift (char->ascii (list-ref ip 0)) 24)
+     (arithmetic-shift (char->ascii (list-ref ip 1)) 16)
+     (arithmetic-shift (char->ascii (list-ref ip 2)) 8)
+     (char->ascii (list-ref ip 3))))
+
+;; converts a 32 bit integer internet-address to an octeted-ip
+(define (address32->octet-ip ip)
+  (if *debug* (display "number->octet-quad\n"))
+  (list (arithmetic-shift ip -24)
+	(modulo (arithmetic-shift ip -16) 256)
+	(modulo (arithmetic-shift ip -8) 256)
+	(modulo ip 256)))
+
+;; converts an ip-string to an 32bit integer internet-address
+(define (ip-string->address32 ip)
+  (if *debug* (display "ip-string->address32\n"))
+  (octet-ip->address32 (string->octet-ip ip)))
+
+;; converts an ip-string to an 32bit integer internet-address
+(define (address32->ip-string ip)
+;  (if *debug* (display "address32->ip-string\n"))
+  (format #f
+	  "~a.~a.~a.~a" 
+	  (arithmetic-shift ip -24)
+	  (modulo (arithmetic-shift ip -16) 256)
+	  (modulo (arithmetic-shift ip -8) 256)
+	  (modulo ip 256)))
+
 ;; converts an octeted-ip to an human readable ip-string
-(define (ip->string s)
-  (if *debug* (display "ip->string\n"))
+(define (octet-ip->string s)
+  (if *debug* (display "octet-ip->string\n"))
   (format #f
 	  "~a.~a.~a.~a" 
 	  (char->ascii (list-ref s 0))
@@ -265,8 +309,8 @@
 	  (char->ascii (list-ref s 3))))
 
 ;; converts an ip-string to octets
-(define (string->ip s)
-  (if *debug* (display "string->ip\n"))
+(define (string->octet-ip s)
+  (if *debug* (display "string->octet-ip\n"))
   (let loop ((s s)
 	     (result '()))
     (cond
@@ -285,7 +329,7 @@
 		314159265))))
 
 ;; checks if a string is a ip
-(define (ip? s)
+(define (ip-string? s)
   (if *debug* (display "ip-string->in-addr\n"))
   (let loop ((s s)
 	     (count 0))
@@ -304,6 +348,10 @@
 	     (= count 3)
 	     #t))))))
 
+;; checks if v is a address32
+(define (address32? v)
+  (and (number? v)
+       (<= 0 v #xffffffff)))
 
 ;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip)
 (define (ip-string->in-addr s)
@@ -343,7 +391,7 @@
 ;; returns a IP if available (additonal type-a processing)
 (define (force-ip name)
   (let loop ((result (dns-lookup-name name)))
-    (if (ip? result)
+    (if (ip-string? result)
 	result
 	(loop (dns-lookup-name result)))))
 
@@ -612,7 +660,7 @@
   (if *debug* (display "parse-rr-data\n"))
   (cond
    ((eq? type 'a) 
-    (make-rr-data-a (ip->string data)))
+    (make-rr-data-a (octet-ip->address32 data)))
    
    ((eq? type 'ns) 
     (make-rr-data-ns (call-with-values 
@@ -932,7 +980,7 @@
 		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))))))
+		 (loop (append ns (list (ip-string->address32 (match:substring match 1)))))))
 	   (else
 	    (loop ns))))))))
 
@@ -960,12 +1008,12 @@
 	     (for-each (lambda (nameserver)
 			 (spawn
 			  (lambda ()
-			    (display "query sent to ")(display nameserver)(display " \n")
+			    ;(display "query sent to ")(display nameserver)(display " \n")
 			    (let* ((result (apply lookup (list name nameserver))))
 			      (enqueue! queue result)
-			      (display "received reply from ")(display nameserver)(display ": ")(display result)(newline)
+			      ;(display "received reply from ")(display nameserver)(display ": ")(display result)(newline)
 			      (release-lock lock)))))
-		       (dns-find-nameserver-list))))
+		       (map (lambda (adr32) (address32->ip-string adr32)) (dns-find-nameserver-list)))))
 
     (let loop ((count (length nameserver-list)))
       (obtain-lock lock)
@@ -974,16 +1022,17 @@
 	    result
 	    (loop (- count 1)))))))
 
-;; checks the arguments of the dns-lookup-* functions.
+;; checks the arguments of the simple 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) 
+      (address32->ip-string (dns-find-nameserver) )
       (let ((nameserver (car args)))
-	(if (ip? nameserver)
-	    nameserver
-	    (dns-lookup-name nameserver)))))
+	(cond
+	 ((ip-string? nameserver) nameserver)
+	 ((address32? nameserver) (address32->ip-string nameserver))
+	 (else (address32->ip-string (dns-lookup-name nameserver)))))))
 
 
 ;; dns-lookup with more options than dns-lookup-*
@@ -996,7 +1045,9 @@
 	(dns-error-messages condition more)
 	(exit #f))
       (lambda ()
-	(let* ((ip-string (ip-string->in-addr name))
+	(let* ((ip-string (if (address32? name) 
+			      (ip-string->in-addr (address32->ip-string name))
+			      (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)))
@@ -1012,10 +1063,18 @@
 	  dns-msg))))))
 
 
+;; returns a lookup-function with concurrent-flag
+(define (make-lookup-function simple-lookup-function)
+  (lambda (name . args)
+    (if (null? args)
+	(simple-lookup-function name)
+	(if (eq? (car args) dns-concurrent-lookup)
+	    (concurrent-lookup simple-lookup-function name)
+	    (simple-lookup-function name (car args))))))
 
 ;; looks up a hostname, returns an ip.
 ;; (dns-lookup-name <name> [nameserver])
-(define (dns-lookup-name name . args)
+(define (dns-simple-lookup-name name . args)
   (call-with-current-continuation
    (lambda (exit)
      (with-handler
@@ -1023,7 +1082,9 @@
 	(dns-error-messages condition more)
 	(exit #f))
       (lambda ()
-	(let* ((ip-string (ip-string->in-addr name))
+	(let* ((ip-string (if (address32? name) 
+			      (ip-string->in-addr (address32->ip-string name))
+			      (ip-string->in-addr name)))
 	       (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 			     (signal 'not-a-hostname)
 			     (make-octet-query-message (random 256) name 'a 'in)))
@@ -1038,10 +1099,11 @@
 	       (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
 	  (rr-data-a:ip (rr:data (car answers)))))))))
 
+(define dns-lookup-name (make-lookup-function dns-simple-lookup-name))
 
 ;; looks up an ip, returns a hostname
 ;; (dns-inverse-lookup <name> [nameserver])
-(define (dns-inverse-lookup ip . args)
+(define (dns-simple-lookup-ip ip . args)
   (call-with-current-continuation
    (lambda (exit)
      (with-handler
@@ -1049,7 +1111,9 @@
 	(dns-error-messages condition more)
 	(exit #f))
       (lambda ()
-	(let* ((ip-string (ip-string->in-addr ip))
+	(let* ((ip-string (if (address32? ip) 
+			      (ip-string->in-addr (address32->ip-string ip))
+			      (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)
 			     (signal 'not-a-ip)))
@@ -1064,13 +1128,15 @@
 	       (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
 	  (rr-data-ptr:name (rr:data (car answers)))))))))
 
-(define dns-lookup-ip dns-inverse-lookup)
+(define dns-lookup-ip (make-lookup-function dns-simple-lookup-ip))
+
+(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)
+(define (dns-simple-lookup-nameserver name . args)
   (call-with-current-continuation
    (lambda (exit)
      (with-handler
@@ -1078,7 +1144,9 @@
 	(dns-error-messages condition more)
 	(exit #f))
       (lambda ()
-	(let* ((ip-string (ip-string->in-addr name))
+	(let* ((ip-string (if (address32? name) 
+			      (ip-string->in-addr (address32->ip-string name))
+			      (ip-string->in-addr name)))
 	       (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 			     (signal 'not-a-hostname)
 			     (make-octet-query-message (random 256) name 'ns 'in)))
@@ -1100,13 +1168,15 @@
 	      (list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa)))))
 	      (map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))))))
 
+(define dns-lookup-nameserver (make-lookup-function dns-simple-lookup-nameserver))
+
 
 ;; 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)
+(define (dns-simple-lookup-mail-exchanger name . args)
   (call-with-current-continuation
    (lambda (exit)
      (with-handler
@@ -1114,7 +1184,9 @@
 	(dns-error-messages condition more)
 	(exit #f))
       (lambda ()
-	(let* ((ip-string (ip-string->in-addr name))
+	(let* ((ip-string (if (address32? name) 
+			      (ip-string->in-addr (address32->ip-string name))
+			      (ip-string->in-addr name)))
 	       (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address
 			     (signal 'not-a-hostname)
 			     (make-octet-query-message (random 256) name 'mx 'in)))
@@ -1145,7 +1217,7 @@
 	   (else
 	    (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))))))
 
-
+(define dns-lookup-mail-exchanger (make-lookup-function dns-simple-lookup-mail-exchanger))
 
 
 ;;; pretty-prints a dns-msg

scheme/packages.scm

@@ -182,19 +182,21 @@
 	  net:daytime))
 
 (define-interface dns-interface
-  (export dns-clear-cache
-	  dns-lookup
-	  dns-lookup-name
-	  dns-inverse-lookup
-	  dns-lookup-ip
-	  dns-lookup-nameserver
-	  dns-lookup-mail-exchanger
-	  concurrent-lookup
-	  show-dns-message
-	  force-ip
-	  force-ip-list
-	  dns-find-nameserver
-	  dns-find-nameserver-list))
+  (export dns-clear-cache            ; clears the cache
+	  dns-lookup                 ; complex lookup function
+	  dns-lookup-name            ; simple lookup function
+	  dns-inverse-lookup         ; obsolete, use dns-lookup-ip
+	  dns-lookup-ip              ; simple lookup function
+	  dns-lookup-nameserver      ; simple lookup function
+	  dns-lookup-mail-exchanger  ; simple lookpu function
+	  dns-concurrent-lookup      ; the concurrent lookup variable
+	  show-dns-message           ; prints a human readable dns-msg
+	  force-ip                   ; reruns a lookup until a ip is resolved
+	  force-ip-list              ; reruns a lookup until a list of ips is resolved
+	  address32->ip-string       ; converts a address32 in an ip-string
+	  ip-string->address32       ; converts a ip-string in an address32
+	  dns-find-nameserver        ; returns a nameserver
+	  dns-find-nameserver-list)) ; returns a list of nameservers
 
 (define-interface cgi-script-interface
   (export cgi-form-query))