From cfc8d84aadc75c16327295e9694c3c042d286938 Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Thu, 5 Sep 2002 09:38:37 +0000
Subject: [PATCH] Use DNS for FQDN determination in SMTP.

---
 scheme/lib/dns.scm  | 13 +++++++++++++
 scheme/lib/smtp.scm | 12 +++++-------
 scheme/packages.scm | 17 ++++++++++-------
 3 files changed, 28 insertions(+), 14 deletions(-)

diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm
index ed55249..a0fcfe8 100644
--- a/scheme/lib/dns.scm
+++ b/scheme/lib/dns.scm
@@ -1358,3 +1358,16 @@
 		  (cons (cons ip32 fqdn) *fqdn-cache*))
 	    fqdn))))
       (dns-lookup-ip ip32)))
+
+(define (host-fqdn name-or-socket-address)
+  (if (socket-address? name-or-socket-address)
+      (socket-address->fqdn name-or-socket-address #f)
+      (internet-address->fqdn
+       (car
+	(host-info:addresses
+	 (host-info name-or-socket-address)))
+       #f)))
+
+(define (system-fqdn)
+  (internet-address->fqdn (car (host-info:addresses (host-info (system-name))))
+			  #t))
diff --git a/scheme/lib/smtp.scm b/scheme/lib/smtp.scm
index 8394423..ef8144f 100644
--- a/scheme/lib/smtp.scm
+++ b/scheme/lib/smtp.scm
@@ -29,11 +29,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not
-;;; a useful Internet host name. How do we do that?  
-;;; [Andreas:] I've inserted a way to do this. It works fine on my
-;;; system. Does it work on your, too?
-
 ;;; (send-mail-via-smtp from to-list headers body [host])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Mail message to recipients in list TO-LIST. Message handed off to server
@@ -50,8 +45,11 @@
 (define (send-mail-via-smtp from to-list headers body . maybe-host)
   (call-with-current-continuation
    (lambda (bailout)
-     (let ((local (host-info:name (host-info (system-name))))
-	   (socket (smtp/open (:optional maybe-host "localhost"))))
+     (let* ((host (:optional maybe-host "localhost"))
+	    (local (if (string=? host "localhost")
+		       (system-name) ; we don't need any DNS for that
+		       (system-fqdn)))
+	    (socket (smtp/open host)))
        (receive (code text)
 	   (smtp-transactions/no-close socket ; Do prologue.
 				       (smtp/helo local)
diff --git a/scheme/packages.scm b/scheme/packages.scm
index 37d88f3..fd4a3f9 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -199,7 +199,9 @@
 	  dns-find-nameserver		; returns a nameserver
 	  dns-find-nameserver-list	; returns a list of nameservers
 	  socket-address->fqdn
-	  internet-address->fqdn))
+	  internet-address->fqdn
+	  host-fqdn
+	  system-fqdn))
 
 (define-interface cgi-script-interface
   (export cgi-form-query))
@@ -433,13 +435,14 @@
 
 (define-structure smtp smtp-interface
 				
-  (open scsh			; write-string read-string/partial force-output
-				;   system-name user-login-name and sockets
+  (open scsh				; write-string read-string/partial force-output
+					; user-login-name and sockets
 	(subset srfi-1 (filter-map))
-	crlf-io			; read-crlf-line write-crlf
-	receiving		; values receive
-	let-opt			; let-optionals
-	error-package		; error
+	crlf-io				; read-crlf-line write-crlf
+	receiving			; values receive
+	let-opt				; let-optionals
+	error-package			; error
+	dns				; SYSTEM-FQDN
 	scheme)
   (files (lib smtp)))