+ error conditions

dns.scm

@@ -6,13 +6,9 @@
 ; based on the PLT-implementation.
 ; 
 ;
-; TODO: -*!!! CHECK-ANSWER !!! 
+; TODO: 
-;        *(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, unknown)
-;       -*error conditions
-;       -*better interface (found or #f)
 ;       - more documentation
 ;
 ;
@@ -42,6 +38,90 @@
 (define *debug* #f)
 
 
+;; --- error conditions
+(define-condition-type 'invalid-type '())
+(define invalid-type? (condition-predicate 'invalid-type))
+
+(define-condition-type 'invalid-class '())
+(define invalid-class? (condition-predicate 'invalid-class))
+
+(define-condition-type 'parse-error '())
+(define parse-error? (condition-predicate 'parse))
+
+(define-condition-type 'unexpected-eof-from-server '())
+(define unexpected-eof-from-server? (condition-predicate 'unexpected-eof-from-server))
+
+(define-condition-type 'bad-address '())
+(define bad-address? (condition-predicate 'bad-address))
+
+(define-condition-type 'no-nameservers '())
+(define no-nameservers? (condition-predicate 'no-nameservers))
+
+(define-condition-type 'not-a-hostname '())
+(define not-a-hostname? (condition-predicate 'not-a-hostname))
+
+(define-condition-type 'not-a-ip '())
+(define not-a-ip? (condition-predicate 'not-a-ip))
+
+
+(define-condition-type 'dns-format-error '())
+(define dns-format-error? (condition-predicate 'dns-format-error))
+
+(define-condition-type 'dns-server-failure '())
+(define dns-server-failure? (condition-predicate 'dns-server-failure))
+
+(define-condition-type 'dns-name-error '())
+(define dns-name-error? (condition-predicate 'dns-name-error))
+
+(define-condition-type 'dns-not-implemented '())
+(define dns-not-implemented? (condition-predicate 'dns-not-implemented))
+
+(define-condition-type 'dns-refused '())
+(define dns-refused? (condition-predicate 'dns-refused))
+
+
+(define-condition-type 'dns-error '(dns-format-error
+				    dns-server-failure
+				    dns-name-error
+				    dns-not-implemented
+				    dns-refused))
+
+(define dns-error? (condition-predicate 'dns-error))
+
+
+;; called by the error-handlers, prints out error descriptions
+(define (dns-error-messages condition more)
+  (cond
+   ((invalid-type? condition)
+    (display "make-octet-question: invalid DNS query type\n"))
+   ((invalid-class? condition)
+    (display "make-octet-question: invalid DNS query class\n"))
+   ((parse-error? condition)
+    (display "parse: error parsing server message\n"))
+   ((unexpected-eof-from-server? condition)
+    (display "send-receive-message: unexpected EOF from server\n"))
+   ((bad-address? condition)
+    (display "dns-get-information: bad address (in combination with query type)\n"))
+   ((no-nameservers? condition)
+    (display "dns-find-nameserver: no nameservers found in /etc/resolv.conf\n"))
+   ((not-a-hostname? condition)
+    (display "no hostname given\n"))
+   ((not-a-ip? condition)
+    (display "no ip given\n"))
+   ((dns-format-error? condition) 
+    (display "error from server: (1) format error\n"))
+   ((dns-server-failure? condition) 
+    (display "error from server: (2) server failure\n"))
+   ((dns-name-error? condition) 
+    (display "error from server: (3) name error\n"))
+   ((dns-not-implemented? condition) 
+    (display "error from server: (4) not implemented\n"))
+   ((dns-refused? condition) 
+    (display "error from server: (5) refused\n"))
+   (else (more))))
+  
+
+
 ;;; -- globals and types
 
 ;; off
@@ -84,7 +164,7 @@
 (define (cossa i l)
   (if *debug* (display "cossa\n"))
   (cond
-   ((null? l) 'unknown) ;;(error "dns-message: type not implemented: " i))
+   ((null? l) 'unknown)
    ((equal? (cadar l) i)
     (car l))
    (else (cossa i (cdr l)))))
@@ -292,9 +372,9 @@
 (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))
+      (signal 'invalid-type))
   (if (not (assoc class classes))
-      (error "make-octet-question: invalid DNS query class ~A" class))
+      (signal 'invalid-class))
 
   (let* ((qname   (name->octets name))
 	 (qtype   (number->octet-pair (cadr (assoc type types))))
@@ -613,7 +693,7 @@
 	      (lambda () (parse-n parse-rr start message (header:arc header)))
 	      (lambda (ars start)
 		(if (not (null? start))
-		    (error "parse: error parsing server message"))
+		    (signal 'parse-error))
 		(make-message header qds ans nss ars message)))))))))))
 
 
@@ -629,14 +709,13 @@
       (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))
+    (if (not (zero? rcode))
-	(error "send-receive-message: error from server: ~A"
 	(case rcode
-		 ((1) "format error")
+	  ((1) (signal 'dns-format-error))
-		 ((2) "server failure")
+	  ((2) (signal 'dns-server-failure))
-		 ((3) "name error")
+	  ((3) (signal 'dns-name-error))
-		 ((4) "not implemented")
+	  ((4) (signal 'dns-not-implemented))
-		 ((5) "refused"))))))
+	  ((5) (signal 'dns-refused))))))
 
 ;; #t if message is truncated (could happen via UDP)
 (define (truncated? reply)
@@ -667,7 +746,7 @@
 		   (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"))
+			   (signal 'unexpected-eof-from-server))
 		       (string->list s)))))
 	       (lambda ()
 		 (close-socket socket)))))))
@@ -785,8 +864,7 @@
 	   (try-recursive
 	    (lambda (auth? nss)
 	      (if (or auth? (null? nss)) 
-		  (error "dns-get-information: bad address (in combination with query-type)" 
+		  (signal 'bad-address)
-			 (question:name (car (message:questions (parse question)))))
 		  (let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss)))))
 			 (dns-msg (if (and ns
 					   (not (member ns tried))
@@ -820,7 +898,7 @@
 	  (cond
 	   ((eof-object? l)
 	    (if (null? ns)
-		(error "dns-find-nameserver-list: no nameserver(s) found in /etc/resolv.conf")
+		(signal 'no-nameservers)
 		ns))
 	   ((regexp-search (posix-string->regexp "nameserver[ 	]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l)
 	    => (lambda (match)
@@ -833,7 +911,7 @@
 (define (dns-find-nameserver)
   (let ((ns (dns-find-nameserver-list)))
     (if (null? ns)
-	(error "dns-find-nameserver: no nameserver found in /etc/resolv.conf")
+	(signal 'no-nameservers)
 	(car ns))))
 
 
@@ -881,6 +959,13 @@
 ;; dns-lookup with more options than dns-lookup-*
 ;; optional: nameserver could be passed to the function.
 (define (dns-lookup name type . args)
+  (call-with-current-continuation
+   (lambda (exit)
+     (with-handler
+      (lambda (condition more)
+	(dns-error-messages condition more)
+	(exit #f))
+      (lambda ()
 	(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)
@@ -894,16 +979,23 @@
 	  (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))
+	  dns-msg))))))
 
 
 
 ;; looks up a hostname, returns an ip.
 ;; (dns-lookup-name <name> [nameserver])
 (define (dns-lookup-name name . args)
+  (call-with-current-continuation
+   (lambda (exit)
+     (with-handler
+      (lambda (condition more)
+	(dns-error-messages condition more)
+	(exit #f))
+      (lambda ()
 	(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")
+			     (signal 'not-a-hostname)
 			     (make-octet-query-message (random 256) name 'a 'in)))
 	       (use-cache? #t)
 	       (protocol 'udp)
@@ -914,16 +1006,23 @@
 				 (not (null? (filter-type answers 'a))))))
 	       (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
 	       (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a)))
-    (rr-data-a:ip (rr:data (car answers)))))
+	  (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)
+  (call-with-current-continuation
+   (lambda (exit)
+     (with-handler
+      (lambda (condition more)
+	(dns-error-messages condition more)
+	(exit #f))
+      (lambda ()
 	(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")))
+			     (signal 'not-a-ip)))
 	       (use-cache? #t)
 	       (protocol 'udp)
 	       (nameserver (check-args args))
@@ -933,7 +1032,7 @@
 				 (not (null? (filter-type answers 'ptr))))))
 	       (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer))
 	       (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr)))
-    (rr-data-ptr:name (rr:data (car answers)))))
+	  (rr-data-ptr:name (rr:data (car answers)))))))))
 
 (define dns-lookup-ip dns-inverse-lookup)
 
@@ -942,9 +1041,16 @@
 ;; returns a list of nameservers
 ;; (dns-lookup-nameserver <name> [nameserver])
 (define (dns-lookup-nameserver name . args)
+  (call-with-current-continuation
+   (lambda (exit)
+     (with-handler
+      (lambda (condition more)
+	(dns-error-messages condition more)
+	(exit #f))
+      (lambda ()
 	(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")
+			     (signal 'not-a-hostname)
 			     (make-octet-query-message (random 256) name 'ns 'in)))
 	       (use-cache? #t)
 	       (protocol 'udp)
@@ -962,7 +1068,7 @@
 	       (add (filter-type (message:additionals reply) 'a)))
 	  (if (null? nss)
 	      (list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa)))))
-	(map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))
+	      (map (lambda (elem) (rr-data-a:ip (rr:data elem))) add))))))))
 
 
 ;; looks up a mail-exchanger for a hostname.
@@ -971,9 +1077,16 @@
 ;; implementation based on RFC2821
 ;; (dns-lookup-mail-exchanger <name> [nameserver])
 (define (dns-lookup-mail-exchanger name . args)
+  (call-with-current-continuation
+   (lambda (exit)
+     (with-handler
+      (lambda (condition more)
+	(dns-error-messages condition more)
+	(exit #f))
+      (lambda ()
 	(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")
+			     (signal 'not-a-hostname)
 			     (make-octet-query-message (random 256) name 'mx 'in)))
 	       (use-cache? #t)
 	       (protocol 'tcp)
@@ -1000,7 +1113,7 @@
 	   ((null? mx) 
 	    (list (rr-data-soa:rname (rr:data (car soa)))))
 	   (else
-      (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))
+	    (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx))))))))))
 
 
 
@@ -1097,7 +1210,7 @@
 	(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)

modules.scm

@@ -485,6 +485,8 @@
 	defrec-package
 	random
 	queues
+	conditions
+	handle
 	sort
 	threads
 	locks)