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

fixed bugs related to invalid nameservers: 

* added new error signal no-nameserver-given
* modified send-receive-message-* functions:
	- better error handling
	- timeout/maxtries functionality
	- try to contact all nameservers,
	  before error is signaled
This commit is contained in:
cresh 2003-07-09 20:45:20 +00:00
parent f972598f59
commit e71a3581af
1 changed files with 109 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
scheme/lib/dns.scm
View File

@ -103,6 +103,9 @@
(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))
@ -147,8 +150,10 @@
"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: nameserver refused connection")
"send-receive-message: could not establish connection to server (no valid nameserver given)")
((not-a-hostname)
"no hostname given")
((not-a-ip)
@ -767,46 +772,81 @@
(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 nameservers query)
(receive (reply hit-ns other-nss)
(let ((sockets (map (lambda (nameserver)
(let ((sockets (filter
socket?
(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)))
sock))))))
nameservers))))
(let* ((ws (map socket:outport sockets))
(wport-nameserver-alist (map cons ws nameservers))
(wport-socket-alist (map cons ws sockets)))
(dynamic-wind
(lambda () #f)
(lambda ()
(let* ((ready-ports (apply select-port-channels #f ws))
(w (car ready-ports))
'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-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))
(dns-error 'bad-nameserver hit-ns))
(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 (k)
(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 (not (= len (string-length s)))
(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))))))))
(delete hit-ns nameservers))))))))))))))))))))
(lambda ()
(for-each close-socket sockets)))))
(reply-acceptable? reply query)
@ -837,15 +877,34 @@
(rport-socket-alist (map cons rs sockets)))
(for-each (lambda (w) (display query-string w)) ws)
(for-each force-output ws)
(let* ((ready (apply select-port-channels #f rs))
(r (car ready))
(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-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))))
(dns-error 'bad-nameserver hit-ns))
;;; 512 is the maximum udp-message size:
(values (parse (string->list (read-string/partial 512 r)))
(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)))))
(delete hit-ns nameservers)))))))))))))))
(lambda ()
(for-each close-socket sockets)))))
(reply-acceptable? reply query)
@ -971,7 +1030,9 @@
(receive (nameservers use-cache?) (lookup-optional-args args)
(let lp ((tried '()) (nss nameservers))
(if (null? nss)
(dns-error 'bad-address)
(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)