scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

+ Complete parsing for /etc/resolv.conf 

+ use search or domain field from resolv.conf to determine FQDNs
This commit is contained in:
mainzelm 2002-12-03 16:02:17 +00:00
parent 29fc6b1b9d
commit 7e6da5347e
1 changed files with 179 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

202
scheme/lib/dns.scm
View File

@ -1011,27 +1011,156 @@
nss-with-no-reply nss-with-no-reply
(lset-difference equal? other-nameservers tried))))))))))) (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" (with-input-from-file "/etc/resolv.conf"
(lambda () (lambda ()
(let loop ((ns '())) (let loop ((rev-result '()))
(let ((l (read-line))) (let ((l (read-line)))
(cond (cond
((eof-object? l) ((eof-object? l)
(if (null? ns) (adjust-result rev-result #f '()))
(dns-error 'no-nameservers)
ns))
((regexp-search ((regexp-search
(rx (: "nameserver" (+ (| " " "\t") (rx (: "nameserver" (+ (| " " "\t")
(submatch (** 1 3 digit) (submatch (* any))
(= 3 (: "." (** 1 3 digit))))))) eos)))
l) l)
=> (lambda (match) => (lambda (match)
(loop (append ns (list (ip-string->address32 (match:substring match 1))))))) (loop (cons (parse-nameserver (match:substring match 1))
(else rev-result))))
(loop ns)))))))) ((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 ;; returns the first found nameserver
(define (dns-find-nameserver) (define (dns-find-nameserver)
@ -1046,12 +1175,12 @@
;; (dns-lookup-name nameserver) is called. ;; (dns-lookup-name nameserver) is called.
(define (check-args args) (define (check-args args)
(if (null? args) (if (null? args)
(dns-find-nameserver-list) (map ip-string->address32 (dns-find-nameserver-list))
(map (lambda (nameserver) (map (lambda (nameserver)
(cond (cond
((address32? nameserver) nameserver) ((address32? nameserver) nameserver)
((ip-string? nameserver) (ip-string->address32 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)))) (car args))))
;; dns-lookup with more options than dns-lookup-* ;; dns-lookup with more options than dns-lookup-*
@ -1311,19 +1440,44 @@
fqdn)))) fqdn))))
(dns-lookup-ip ip32))) (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) (define (host-fqdn name-or-socket-address)
(if (socket-address? name-or-socket-address) (if (socket-address? name-or-socket-address)
(socket-address->fqdn name-or-socket-address #f) (socket-address->fqdn name-or-socket-address #f)
;; TODO: try looking up with domain from "search" appended (let ((name name-or-socket-address))
(internet-address->fqdn (if (is-fqdn? name)
(car name
(host-info:addresses (let lp ((domains (domains-for-search)))
(host-info name-or-socket-address))) (if (null? domains)
#f))) #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) (define (system-fqdn)
;; TODO: isn't this simply (host-fqdn (system-name))? (host-fqdn (system-name)))
(internet-address->fqdn (car (host-info:addresses (host-info (system-name))))
#t))