diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm index 15ae279..d5ab55c 100644 --- a/scheme/lib/dns.scm +++ b/scheme/lib/dns.scm @@ -1011,28 +1011,157 @@ nss-with-no-reply (lset-difference equal? other-nameservers tried))))))))))) -;; parses the resolv.conf file and returns a list of found nameserver -(define (dns-find-nameserver-list) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parsing of /etc/resolv.conf + +(define (parse-nameserver rest-of-line) + (let ((match (regexp-search + (rx (: (submatch (** 1 3 digit) "." + (** 1 3 digit) "." + (** 1 3 digit) "." + (** 1 3 digit)) + (* white))); don't complain about tailing white space + rest-of-line))) + (if match + (cons 'nameserver (match:substring match 1)) + (signal 'resolv.conf-parse-error)))) + +; could be more restrictive... +(define domain-name-regexp (rx (+ (| alphanum #\. #\-)))) + +(define (parse-domain rest-of-line) + (let ((match (regexp-search + (rx (: (submatch ,domain-name-regexp) + (* white))); don't complain about tailing white space + rest-of-line))) + (if match + (cons 'domain (match:substring match 1)) + (signal 'resolv.conf-parse-error)))) + +(define (parse-search rest-of-line) + (let ((domains (regexp-fold-right domain-name-regexp + (lambda (match junk accu) + (cons (match:substring match 0) accu)) + '() + rest-of-line))) + (if (null? domains) + (signal 'resolv.conf-parse-error) + (cons 'search domains)))) + +(define (parse-sortlist rest-of-line) + (let ((netmask-pairs (regexp-fold-right (rx (+ (| digit #\. #\/))) + (lambda (match junk accu) + (cons (match:substring match 0) accu)) + '() + rest-of-line))) + (if (null? netmask-pairs) + (signal 'resolv.conf-parse-error) + (cons 'sortlist netmask-pairs)))) + +(define (parse-options rest-of-line) + (regexp-fold-right + (rx (| "debug" "no_tld_query" (: "ndots:" (submatch digit)))) + (lambda (match junk accu) + (let ((str (match:substring match 0))) + (cond ((string=? str "debug") + (cons 'debug accu)) + ((string=? str "no_tld_query") + (cons 'no_tld_query accu)) + (else (cons (cons 'ndots + (string->number (match:substring match 1))) accu))))) + '() + rest-of-line)) + +;; TODO: cache result +(define (parse-resolv.conf) + (define (adjust-result rev-result have-search-or-domain? nameservers) + (cond ((null? rev-result) + (if (null? nameservers) + '() + (list (cons 'nameserver nameservers)))) + ((eq? (caar rev-result) 'domain) + (if have-search-or-domain? + (adjust-result (cdr rev-result) have-search-or-domain? nameservers) + (cons (car rev-result) + (adjust-result (cdr rev-result) + #t + nameservers)))) + ((eq? (caar rev-result) 'search) + (if have-search-or-domain? + (adjust-result (cdr rev-result) have-search-or-domain? nameservers) + (cons (car rev-result) + (adjust-result (cdr rev-result) + #t + nameservers)))) + ((eq? (caar rev-result) 'nameserver) + (adjust-result (cdr rev-result) + have-search-or-domain? + (cons (cdar rev-result) + nameservers))) + (else (cons (car rev-result) + (adjust-result (cdr rev-result) + have-search-or-domain? + nameservers))))) + (with-input-from-file "/etc/resolv.conf" (lambda () - (let loop ((ns '())) + (let loop ((rev-result '())) (let ((l (read-line))) (cond ((eof-object? l) - (if (null? ns) - (dns-error 'no-nameservers) - ns)) + (adjust-result rev-result #f '())) ((regexp-search - (rx (: "nameserver" (+ (| " " "\t") - (submatch (** 1 3 digit) - (= 3 (: "." (** 1 3 digit))))))) + (rx (: "nameserver" (+ (| " " "\t") + (submatch (* any)) + eos))) l) => (lambda (match) - (loop (append ns (list (ip-string->address32 (match:substring match 1))))))) - (else - (loop ns)))))))) + (loop (cons (parse-nameserver (match:substring match 1)) + rev-result)))) + ((regexp-search + (rx (: "domain" (+ (| " " "\t") + (submatch (* any)) + eos))) + l) + => (lambda (match) + (loop (cons (parse-domain (match:substring match 1)) + rev-result)))) + ((regexp-search + (rx (: "search" (+ (| " " "\t") + (submatch (* any)) + eos))) + l) + => (lambda (match) + (loop (cons (parse-search (match:substring match 1)) + rev-result)))) + + ((regexp-search + (rx (: "sortlist" (+ (| " " "\t") + (submatch (* any)) + eos))) + l) + => (lambda (match) + (parse-sortlist (match:substring match 1)))) + ((regexp-search + (rx (: "options" (+ (| " " "\t") + (submatch (* any)) + eos))) + l) + => (lambda (match) + (parse-options (match:substring match 1)))) + (else (signal 'resolv.conf-parse-error)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Figure out the default name servers + +(define (dns-find-nameserver-list) + (cond ((assoc 'nameserver (parse-resolv.conf)) + => (lambda (nameserver.list) + (cdr nameserver.list))) + (else '()))) + ;; returns the first found nameserver (define (dns-find-nameserver) (let ((ns (dns-find-nameserver-list))) @@ -1046,12 +1175,12 @@ ;; (dns-lookup-name nameserver) is called. (define (check-args args) (if (null? args) - (dns-find-nameserver-list) + (map ip-string->address32 (dns-find-nameserver-list)) (map (lambda (nameserver) (cond ((address32? nameserver) nameserver) ((ip-string? nameserver) (ip-string->address32 nameserver)) - (else (dns-lookup-name nameserver (dns-find-nameserver-list))))) + (else (map (dns-lookup-name nameserver (dns-find-nameserver-list)))))) (car args)))) ;; dns-lookup with more options than dns-lookup-* @@ -1311,19 +1440,44 @@ fqdn)))) (dns-lookup-ip ip32))) -;;; TODO THIS USES gethostbyname + +(define (is-fqdn? name) + (regexp-search? (rx #\.) name)) + +(define (maybe-dns-lookup-name name) + (call-with-current-continuation + (lambda (k) + (with-handler (lambda (cond more) + (if (dns-error? cond) + (k #f) + (more))) + (lambda () + (dns-lookup-name name)))))) + +(define (domains-for-search) + (let ((resolv.conf (parse-resolv.conf))) + (cond ((assoc 'domain resolv.conf) + => (lambda (pair) + (list (cdr pair)))) + ((assoc 'search resolv.conf) + => (lambda (pair) + (cdr pair))) + (else '())))) + (define (host-fqdn name-or-socket-address) (if (socket-address? name-or-socket-address) (socket-address->fqdn name-or-socket-address #f) - ;; TODO: try looking up with domain from "search" appended - (internet-address->fqdn - (car - (host-info:addresses - (host-info name-or-socket-address))) - #f))) + (let ((name name-or-socket-address)) + (if (is-fqdn? name) + name + (let lp ((domains (domains-for-search))) + (if (null? domains) + #f + (cond ((maybe-dns-lookup-name (string-append name "." (car domains))) + => (lambda (ip) + (dns-lookup-ip ip))) + (else (lp (cdr domains)))))))))) -;;; TODO THIS USES gethostbyname (define (system-fqdn) - ;; TODO: isn't this simply (host-fqdn (system-name))? - (internet-address->fqdn (car (host-info:addresses (host-info (system-name)))) - #t)) + (host-fqdn (system-name))) +