+ Complete parsing for /etc/resolv.conf

+ use search or domain field from resolv.conf to determine FQDNs

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)
+	    (adjust-result rev-result #f '()))
-		(dns-error 'no-nameservers)
-		ns))
 	   ((regexp-search
-	     (rx (: "nameserver" (+ (| " " "\t") 
+	     (rx (: "nameserver" (+ (| " " "\t")
-				    (submatch (** 1 3 digit) 
+				    (submatch (* any))
-					      (= 3 (: "." (** 1 3 digit)))))))
+				    eos)))
 	     l)
 	    => (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
 (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
+      (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)
-  ;; 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))