+ Complete parsing for /etc/resolv.conf
+ use search or domain field from resolv.conf to determine FQDNs
This commit is contained in:
mainzelm
parent
29fc6b1b9d
commit
7e6da5347e
|
|
@ -1011,27 +1011,156 @@
|
|||
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)))))))
|
||||
(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)
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue