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

View File

@ -103,6 +103,9 @@
(define-condition-type 'no-nameservers '(dns-error)) (define-condition-type 'no-nameservers '(dns-error))
(define no-nameservers? (condition-predicate 'no-nameservers)) (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-condition-type 'bad-nameserver '(dns-error))
(define bad-nameserver? (condition-predicate 'bad-nameserver)) (define bad-nameserver? (condition-predicate 'bad-nameserver))
@ -147,8 +150,10 @@
"dns-get-information: bad address (in combination with query type)") "dns-get-information: bad address (in combination with query type)")
((no-nameservers) ((no-nameservers)
"dns-find-nameserver: no nameservers found in /etc/resolv.conf") "dns-find-nameserver: no nameservers found in /etc/resolv.conf")
((no-nameserver-given)
"dns-find-nameserver: no nameservers given")
((bad-nameserver) ((bad-nameserver)
"send-receive-message: nameserver refused connection") "send-receive-message: could not establish connection to server (no valid nameserver given)")
((not-a-hostname) ((not-a-hostname)
"no hostname given") "no hostname given")
((not-a-ip) ((not-a-ip)
@ -767,46 +772,81 @@
(if (not (eq? response-code 'dns-no-error)) (if (not (eq? response-code 'dns-no-error))
(dns-error response-code)))) (dns-error response-code))))
(define *max-tries* 3)
(define *timeout* 1)
;; connects to nameserver and sends and receives messages. returns the reply. ;; connects to nameserver and sends and receives messages. returns the reply.
;; here: via TCP ;; here: via TCP
(define (send-receive-message-tcp nameservers query) (define (send-receive-message-tcp nameservers query)
(receive (reply hit-ns other-nss) (receive (reply hit-ns other-nss)
(let ((sockets (map (lambda (nameserver) (let ((sockets (filter
(let ((sock (create-socket protocol-family/internet socket?
socket-type/stream)) (map
(addr (internet-address->socket-address (lambda (nameserver)
nameserver 53))) (let ((sock (create-socket protocol-family/internet
;; we ignore the return value and select socket-type/stream))
;; unconditionally later (addr (internet-address->socket-address
(connect-socket-no-wait sock addr) nameserver 53)))
sock)) ;; we ignore the return value and select
nameservers))) ;; 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* ((ws (map socket:outport sockets)) (let* ((ws (map socket:outport sockets))
(wport-nameserver-alist (map cons ws nameservers)) (wport-nameserver-alist (map cons ws nameservers))
(wport-socket-alist (map cons ws sockets))) (wport-socket-alist (map cons ws sockets)))
(dynamic-wind (dynamic-wind
(lambda () #f)
(lambda () (lambda ()
(let* ((ready-ports (apply select-port-channels #f ws)) 'nothing-to-be-done-before)
(w (car ready-ports)) (lambda ()
(hit-ns (cdr (assoc w wport-nameserver-alist))) (let loop-port-channels ((tried-channels '())
(sock (cdr (assoc w wport-socket-alist)))) (number-tries 1))
(if (not (connect-socket-successful? sock)) (letrec ((delete-list
(dns-error 'bad-nameserver hit-ns)) (lambda (elems list)
(let ((query-string (cond
(list->string (add-size-tag (message-source query)))) ((null? elems) list)
(r (socket:inport sock))) ((null? list) '())
(display query-string w) (else (delete-list (cdr elems) (delete (car elems) list))))))
(force-output w) (ws-new (delete-list tried-channels ws)))
(let ((a (read-char r)) (if (or (null? ws-new) (>= number-tries *max-tries*))
(b (read-char r))) (dns-error 'bad-nameserver)
(let ((len (octet-pair->number a b))) (let ((ready (apply select-port-channels *timeout* ws)))
(let ((s (read-string len r))) (if (= (length tried-channels) (length ws))
(if (not (= len (string-length s))) (dns-error 'bad-nameserver)
(dns-error 'unexpected-eof-from-server)) (let loop-ready-channels ((ready-channels ready))
(values (parse (string->list s)) (if (null? ready-channels)
hit-ns (loop-port-channels (append tried-channels ready) (+ number-tries 1))
(delete hit-ns nameservers)))))))) (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 (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 (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 () (lambda ()
(for-each close-socket sockets))))) (for-each close-socket sockets)))))
(reply-acceptable? reply query) (reply-acceptable? reply query)
@ -837,23 +877,42 @@
(rport-socket-alist (map cons rs sockets))) (rport-socket-alist (map cons rs sockets)))
(for-each (lambda (w) (display query-string w)) ws) (for-each (lambda (w) (display query-string w)) ws)
(for-each force-output ws) (for-each force-output ws)
(let* ((ready (apply select-port-channels #f rs)) (let loop-port-channels ((tried-channels '())
(r (car ready)) (number-tries 1))
(hit-ns (cdr (assoc r rport-nameserver-alist)))) (letrec ((delete-list
(if (not (connect-socket-successful? (cdr (assoc r rport-socket-alist)))) (lambda (elems list)
(dns-error 'bad-nameserver hit-ns)) (cond
;;; 512 is the maximum udp-message size: ((null? elems) list)
(values (parse (string->list (read-string/partial 512 r))) ((null? list) '())
hit-ns (else (delete-list (cdr elems) (delete (car elems) list))))))
(delete hit-ns nameservers))))) (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))))
(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 () (lambda ()
(for-each close-socket sockets))))) (for-each close-socket sockets)))))
(reply-acceptable? reply query) (reply-acceptable? reply query)
(if (flags-truncated? (header-flags (message-header reply))) (if (flags-truncated? (header-flags (message-header reply)))
(send-receive-message-tcp nameservers query) (send-receive-message-tcp nameservers query)
(values reply (values reply
hit-ns hit-ns
other-nss)))) other-nss))))
;;; -- cache ;;; -- cache
@ -971,7 +1030,9 @@
(receive (nameservers use-cache?) (lookup-optional-args args) (receive (nameservers use-cache?) (lookup-optional-args args)
(let lp ((tried '()) (nss nameservers)) (let lp ((tried '()) (nss nameservers))
(if (null? nss) (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) (receive (dns-msg hit-ns nss-with-no-reply)
(dns-query/cache query use-cache? protocol nss tried) (dns-query/cache query use-cache? protocol nss tried)
(if (check-answer dns-msg) (if (check-answer dns-msg)