scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ error conditions

This commit is contained in:
cresh 2002-05-21 15:25:09 +00:00
parent 5d357598b1
commit 66208241f5
2 changed files with 342 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

173
dns.scm
View File

@ -6,13 +6,9 @@
; based on the PLT-implementation.
;
;
; TODO: -*!!! CHECK-ANSWER !!!
; *(wrong: if check-answer is not successfull, bad hostname is returned)
; *solution: error conditions -> if thrown, return #f
; TODO:
; - 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))
(error "send-receive-message: error from server: ~A"
(if (not (zero? rcode))
(case rcode
((1) "format error")
((2) "server failure")
((3) "name error")
((4) "not implemented")
((5) "refused"))))))
((1) (signal 'dns-format-error))
((2) (signal 'dns-server-failure))
((3) (signal 'dns-name-error))
((4) (signal 'dns-not-implemented))
((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)"
(question:name (car (message:questions (parse question)))))
(signal 'bad-address)
(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))))))))))

2
modules.scm
View File

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