From 1cfa3e3595d95c0a252897b3b2cc2fa40ba10612 Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Thu, 5 Sep 2002 09:25:42 +0000
Subject: [PATCH] Shift FQDN determination code from HTTPD-CORE to DNS.

---
 scheme/httpd/core.scm | 51 ++++++-------------------------------------
 scheme/lib/dns.scm    | 25 +++++++++++++++++++++
 scheme/packages.scm   | 30 +++++++++++++------------
 3 files changed, 48 insertions(+), 58 deletions(-)

diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm
index 03b8643..96ede84 100644
--- a/scheme/httpd/core.scm
+++ b/scheme/httpd/core.scm
@@ -269,8 +269,10 @@
 	    ;; Interpolate the userhost struct from our net connection.
 	    (if (and (pair? path) (string=? (car path) ""))
 		(let* ((addr (socket-local-address socket))
-		       (local-name (my-reported-fqdn addr options))
-		       (portnum (my-reported-port addr options)))
+		       (local-name (or (httpd-options-fqdn options)
+				       (socket-address->fqdn addr #t)))
+		       (portnum (or (httpd-options-reported-port options)
+				    (my-reported-port addr))))
 		  (make-http-url (make-userhost #f #f
 						local-name
 						(number->string portnum))
@@ -353,46 +355,7 @@
 	      (write-crlf port))
 	    headers))
 
-;;; Return my Internet host name (my fully-qualified domain name).
-;;; This works only if an actual resolver is behind host-info.
-;;;
-;;; In case of aliased names, you just might get the wrong one.
-;;; Furthermore, you may get screwed in the presence of a server
-;;; accelerator such as Squid.
-
-
-(define my-reported-fqdn
-  (let ((fqdn-lock (make-lock))
-	(fqdn-cache '())		; listof (ip32 port options . fqdn)
-	(key-ip32 car)
-	(key-port cadr)
-	(key-options caddr))
-    (lambda (addr options)
-      (obtain-lock fqdn-lock)
-      (let 
-	  ((result
-	    (receive (ip32 port)
-		 (socket-address->internet-address addr)
-	      (let ((fqdn-entry 
-		     (find (lambda (entry)
-			      (let ((entry-key (car entry)))
-				(and (= ip32 (key-ip32 entry-key))
-				     (= port (key-port entry-key))
-				     (eq? options (key-options entry-key)))))
-			    fqdn-cache)))
-		(if fqdn-entry
-		    (cdr fqdn-entry)
-		    (let ((fqdn (or (httpd-options-fqdn options)
-				    (dns-lookup-ip ip32)
-				    (host-info:name (host-info addr)))))
-		      (set! fqdn-cache 
-			    (cons (cons (list ip32 port options) fqdn) fqdn-cache))
-		      fqdn))))))
-	(release-lock fqdn-lock)
-	result))))
-
-(define (my-reported-port addr options)
-  (or (httpd-options-reported-port options)
-      (receive (ip-addr portnum) (socket-address->internet-address addr)
-	portnum)))
+(define (my-reported-port addr)
+  (receive (ip-addr portnum) (socket-address->internet-address addr)
+    portnum))
 
diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm
index d4f84bc..ed55249 100644
--- a/scheme/lib/dns.scm
+++ b/scheme/lib/dns.scm
@@ -1333,3 +1333,28 @@
       (d 5 "data " (rr-data-wks:data dns-msg)))
      
      )))
+
+(define *fqdn-lock* (make-lock))
+(define *fqdn-cache* '())
+
+(define (socket-address->fqdn addr cache?)
+  (receive (ip32 port)
+      (socket-address->internet-address addr)
+    (internet-address->fqdn ip32 cache?)))
+
+(define (internet-address->fqdn ip32 cache?)
+  (if cache?
+      (begin
+	(obtain-lock *fqdn-lock*)
+	(cond
+	 ((assv ip32 *fqdn-cache*) => 
+	  (lambda (pair)
+	    (release-lock *fqdn-lock*)
+	    (cdr pair)))
+	 (else
+	  (release-lock *fqdn-lock*)
+	  (let ((fqdn (dns-lookup-ip ip32)))
+	    (set! *fqdn-cache*
+		  (cons (cons ip32 fqdn) *fqdn-cache*))
+	    fqdn))))
+      (dns-lookup-ip ip32)))
diff --git a/scheme/packages.scm b/scheme/packages.scm
index 7fcda8f..37d88f3 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -184,20 +184,22 @@
 	  net:daytime))
 
 (define-interface dns-interface
-  (export dns-clear-cache            ; clears the cache
-	  dns-lookup                 ; complex lookup function
-	  dns-lookup-name            ; simple lookup function
-	  dns-inverse-lookup         ; obsolete, use dns-lookup-ip
-	  dns-lookup-ip              ; simple lookup function
-	  dns-lookup-nameserver      ; simple lookup function
-	  dns-lookup-mail-exchanger  ; simple lookpu function
-	  show-dns-message           ; prints a human readable dns-msg
-	  force-ip                   ; reruns a lookup until a ip is resolved
-	  force-ip-list              ; reruns a lookup until a list of ips is resolved
-	  address32->ip-string       ; converts a address32 in an ip-string
-	  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
+  (export dns-clear-cache		; clears the cache
+	  dns-lookup			; complex lookup function
+	  dns-lookup-name		; simple lookup function
+	  dns-inverse-lookup		; obsolete, use dns-lookup-ip
+	  dns-lookup-ip			; simple lookup function
+	  dns-lookup-nameserver		; simple lookup function
+	  dns-lookup-mail-exchanger	; simple lookpu function
+	  show-dns-message		; prints a human readable dns-msg
+	  force-ip			; reruns a lookup until a ip is resolved
+	  force-ip-list			; reruns a lookup until a list of ips is resolved
+	  address32->ip-string		; converts a address32 in an ip-string
+	  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
+	  socket-address->fqdn
+	  internet-address->fqdn))
 
 (define-interface cgi-script-interface
   (export cgi-form-query))