diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index d66a3ed..67c2c33 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -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 ((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 - (connect-socket-no-wait sock addr) - sock)) - nameservers))) + (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)))) (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 () + 'nothing-to-be-done-before) (lambda () - (let* ((ready-ports (apply select-port-channels #f ws)) - (w (car ready-ports)) - (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)) - (let ((query-string - (list->string (add-size-tag (message-source query)))) - (r (socket:inport sock))) - (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))) - (dns-error 'unexpected-eof-from-server)) - (values (parse (string->list s)) - hit-ns - (delete hit-ns nameservers)))))))) + (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)) + (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 () (for-each close-socket sockets))))) (reply-acceptable? reply query) @@ -837,23 +877,42 @@ (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)) - (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))) - hit-ns - (delete hit-ns nameservers))))) + (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)))) + (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 () (for-each close-socket sockets))))) - (reply-acceptable? reply query) - (if (flags-truncated? (header-flags (message-header reply))) - (send-receive-message-tcp nameservers query) - (values reply - hit-ns - other-nss)))) + (reply-acceptable? reply query) + (if (flags-truncated? (header-flags (message-header reply))) + (send-receive-message-tcp nameservers query) + (values reply + hit-ns + other-nss)))) ;;; -- cache @@ -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)