diff --git a/doc/latex/dns.tex b/doc/latex/dns.tex index 0d2d970..5a48f50 100644 --- a/doc/latex/dns.tex +++ b/doc/latex/dns.tex @@ -149,6 +149,14 @@ accept. \var{Nameserver} is either a \ipaddr or a dotted IP string. resolve these FQDNs. \end{desc} +\defun{dns-check-nameservers} {[nameserver list]} {\undefined} +\begin{desc} + \ex{dns-check-namservers} checks if the given nameservers are reachable. + If no argument is given, the nameservers in \texttt{/etc/resolv.conf} + are checked. Information about the status of the nameservers is printed + to the current output port. +\end{desc} + \section{Low-level Interface} This section describes a set of data structures and procedures which diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index 67c2c33..7fd6075 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -30,17 +30,25 @@ ; if it is a domainname, its ip is looked up on a nameserver listed in ; /etc/resolv.conf. ; -; (dns-find-nameserver) --> -; this parses the /etc/resolv.conf file and returns the first found -; nameserver in address32 format. +; (dns-find-nameserver-list) --> +; this parses the /etc/resolv.conf file and returns the found +; nameserver in a list of dotted strings. ; +; (dns-find-nameserver) --> +; this parses the /etc/resolv.conf file and returns the first found +; nameserver in dotted string notation. +; +; (dns-check-namservers [nameserver list]) --> undefined +; checks if the given nameservers are reachable. If no argument is given, +; the nameservers in /etc/resolv.conf are checked. ; ; -; (dns-lookup-name [nameserver]) --> -; (dns-lookup-ip [nameserver]) --> -; (dns-lookup-nameserver [nameserver]) +; (dns-lookup-name [nameserver list] [use-cache?]) --> +; (dns-lookup-ip [nameserver list] [use-cache?]) +; --> +; (dns-lookup-nameserver [nameserver list] [use-cache?]) ; --> -; (dns-lookup-mail-exchanger [nameserver]) +; (dns-lookup-mail-exchanger [nameserver list] [use-cache?]) ; --> ; ; dns-lookup-name, dns-lookup-ip, dns-lookup-nameserver and @@ -57,7 +65,7 @@ ; /etc/resolv.conf. ; ; -; (dns-lookup [nameserver]) +; (dns-lookup [nameserver list]) ; --> ; (show-dns-message the whole message, human readable ; @@ -780,9 +788,7 @@ ;; here: via TCP (define (send-receive-message-tcp nameservers query) (receive (reply hit-ns other-nss) - (let ((sockets (filter - socket? - (map + (let ((sockets (map (lambda (nameserver) (let ((sock (create-socket protocol-family/internet socket-type/stream)) @@ -797,8 +803,18 @@ (lambda () (connect-socket-no-wait sock addr) sock)))))) - nameservers)))) - (let* ((ws (map socket:outport sockets)) + nameservers))) + (let* ((nameservers + (let loop ((sockets sockets) + (nss nameservers)) + (cond + ((or (null? sockets) (null? nss)) '()) + ((socket? (car sockets)) + (cons (car nss) (loop (cdr sockets) (cdr nss)))) + (else (loop (cdr sockets) (cdr nss)))))) + + (sockets (filter socket? sockets)) + (ws (map socket:outport sockets)) (wport-nameserver-alist (map cons ws nameservers)) (wport-socket-alist (map cons ws sockets))) (dynamic-wind @@ -1240,6 +1256,99 @@ (dns-error 'no-nameservers) (car ns)))) +;; checks if the nameservers are working, prints a summary +(define (dns-check-nameservers . args) + (let* ((print-summary + (lambda (working-channels non-working-channels) + (for-each (lambda (channel) + (display "FAIL: ")(display channel) + (display " - host not reachable.")(newline)) + non-working-channels) + (for-each (lambda (channel) + (display "PASS: ")(display channel) + (display " - connection established.")(newline)) + working-channels) + (if (null? working-channels) + (begin (display "ERROR: no working nameserver found.")(newline))))) + + (nameservers (if (null? args) + (dns-find-nameserver-list) + (car args))) + (sockets (map + (lambda (nameserver) + (let ((sock (create-socket protocol-family/internet + socket-type/stream)) + (addr (internet-address->socket-address + (ip-string->address32 nameserver) 53))) + (call-with-current-continuation + (lambda (k) + (with-handler (lambda (cond more) + (display "FAIL: ") + (display nameserver) + (display " - no DNS Service available.") + (newline) + (k #f)) + (lambda () + (connect-socket-no-wait sock addr) + sock)))))) + nameservers))) + + (let* ((nameservers + (let loop ((sockets sockets) + (nss nameservers)) + (cond + ((or (null? sockets) (null? nss)) '()) + ((socket? (car sockets)) + (cons (car nss) (loop (cdr sockets) (cdr nss)))) + (else (loop (cdr sockets) (cdr nss)))))) + + (sockets (filter socket? sockets)) + (ws (map socket:outport sockets)) + (wport-nameserver-alist (map cons ws nameservers)) + (wport-socket-alist (map cons ws sockets))) + (dynamic-wind + (lambda () + 'nothing-to-be-done-before) + (lambda () + (let loop-port-channels ((working-channels '()) + (non-working-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)))))) + (ready (delete-list tried-channels + (apply select-port-channels *timeout* ws)))) + + (if (or (>= number-tries *max-tries*)) + (print-summary working-channels + (delete-list working-channels + (delete-list non-working-channels + nameservers))) + (let loop-ready-channels ((working-channels working-channels) + (non-working-channels non-working-channels) + (ready-channels ready)) + (if (null? ready-channels) + (loop-port-channels working-channels + non-working-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 (connect-socket-successful? sock) + (loop-ready-channels (append working-channels (list hit-ns)) + non-working-channels (cdr ready-channels)) + (loop-ready-channels working-channels + (append non-working-channels + (list hit-ns)) + (cdr ready-channels)))))))))) + (lambda () + (for-each close-socket sockets)))))) + ;; computes the nameservers argument of the lookup functions. ;; if a nameserver-name is given and not a nameserver-ip diff --git a/scheme/packages.scm b/scheme/packages.scm index b083ef3..326c0f2 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -155,6 +155,7 @@ ip-string->address32 ; converts a ip-string in an address32 dns-find-nameserver ; returns a nameserver dns-find-nameserver-list ; returns a list of nameservers + dns-check-nameservers ; checks for working nameservers socket-address->fqdn host-fqdn system-fqdn))