From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 4 Nov 1997 11:04:52 +0000 (+0000)
Subject: Implement direct SMTP mail transmission.  This is for Windows systems,
X-Git-Tag: 20090517-FFI~4942
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=04c0796f9f31682ae5ef6ddf86922806939194a6;p=mit-scheme.git

Implement direct SMTP mail transmission.  This is for Windows systems,
which don't have a sendmail daemon, but it can be used on any system
that supports sockets.
---

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 1c7ec11d0..bbe4395a5 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.213 1997/10/31 01:24:24 cph Exp $
+$Id: edwin.pkg,v 1.214 1997/11/04 11:04:52 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -1476,12 +1476,15 @@ MIT in each case. |#
 	  edwin-variable$mail-interactive
 	  edwin-variable$mail-mode-hook
 	  edwin-variable$mail-organization
+	  edwin-variable$mail-relay-host
 	  edwin-variable$mail-reply-buffer
 	  edwin-variable$mail-self-blind
 	  edwin-variable$mail-setup-hook
 	  edwin-variable$mail-yank-ignored-headers
 	  edwin-variable$send-mail-procedure
 	  edwin-variable$sendmail-program
+	  edwin-variable$smtp-require-valid-recipients
+	  edwin-variable$smtp-trace
 	  edwin-variable$user-mail-address
 	  mail-field-end
 	  mail-field-end!
diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm
index 8251817fe..a5875dc68 100644
--- a/v7/src/edwin/sendmail.scm
+++ b/v7/src/edwin/sendmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: sendmail.scm,v 1.36 1997/10/31 01:23:02 cph Exp $
+;;;	$Id: sendmail.scm,v 1.37 1997/11/04 11:04:46 cph Exp $
 ;;;
 ;;;	Copyright (c) 1991-97 Massachusetts Institute of Technology
 ;;;
@@ -106,6 +106,25 @@ so you can remove or alter the BCC field to override the default."
   "Name of file to write all outgoing messages in, or false for none."
   false
   string-or-false?)
+
+(define-variable mail-relay-host
+  "Name of host to which all outgoing mail should be sent.
+Can be a host name (a string) or #F.
+If #F, mail is passed to sendmail for handling.
+Otherwise, mail is sent directly to the named host using SMTP."
+  #f
+  string-or-false?)
+
+(define-variable smtp-trace
+  "If true, direct SMTP transmissions are traced in a buffer."
+  #f
+  boolean?)
+
+(define-variable smtp-require-valid-recipients
+  "If true, all SMTP recipients must be valid before a message is sent.
+Otherwise, only one valid recipient is required."
+  #t
+  boolean?)
 
 (define-variable mail-yank-ignored-headers
   "Delete these headers from old message when it's inserted in a reply."
@@ -640,9 +659,15 @@ the user from the mailer."
 	       ;; Don't send out a blank subject line.
 	       (if (re-search-forward "^Subject:[ \t]*\n" start end #t)
 		   (delete-match))))))
-      (let ((errors (send-mail-buffer temp-buffer mail-buffer)))
-	(kill-buffer temp-buffer)
-	(if errors (editor-error errors))))))
+      (dynamic-wind
+       (lambda () unspecific)
+       (lambda ()
+	 (if (ref-variable mail-relay-host mail-buffer)
+	     (smtp-mail-buffer temp-buffer mail-buffer)
+	     (let ((errors (send-mail-buffer temp-buffer mail-buffer)))
+	       (if errors
+		   (editor-error errors)))))
+       (lambda () (kill-buffer temp-buffer))))))
 
 (define (prepare-mail-buffer-for-sending mail-buffer process-header)
   (let ((temp-buffer (temporary-buffer " sendmail temp")))
@@ -763,4 +788,216 @@ the user from the mailer."
 	    (loop (cons (->pathname filename) pathnames)))
 	  (begin
 	    (mark-temporary! m)
-	    pathnames)))))
\ No newline at end of file
+	    pathnames)))))
+
+;;;; Direct SMTP
+
+(define (smtp-mail-buffer mail-buffer lookup-buffer)
+  (let ((msg "Sending..."))
+    (message msg)
+    (let ((from
+	   (rfc822-addresses->string
+	    (rfc822-strip-quoted-names (mail-from-string lookup-buffer))))
+	  (rcpts (mail-deduce-address-list mail-buffer))
+	  (trace-buffer
+	   (and (ref-variable smtp-trace lookup-buffer)
+		(temporary-buffer "*SMTP-trace*")))
+	  (require-valid?
+	   (ref-variable smtp-require-valid-recipients lookup-buffer))
+	  (valid-response?
+	   (lambda (response) (= 250 (smtp-response-number response)))))
+      (if (null? rcpts)
+	  (editor-error "No recipients specified for mail."))
+      (mail-delete-bcc-lines mail-buffer)
+      (let ((responses
+	     (call-with-smtp-socket (ref-variable mail-relay-host
+						  lookup-buffer)
+				    trace-buffer
+	       (lambda (port banner)
+		 (smtp-command/helo port)
+		 (smtp-command/mail port from)
+		 (let ((responses
+			(map (lambda (rcpt)
+			       (smtp-command/rcpt port rcpt))
+			     rcpts)))
+		   (if (if require-valid?
+			   (for-all? responses valid-response?)
+			   (there-exists? responses valid-response?))
+		       (smtp-command/data port mail-buffer)
+		       (smtp-command/rset port))
+		   (smtp-command/quit port)
+		   responses)))))
+	(cond ((not (for-all? responses valid-response?))
+	       (pop-up-temporary-buffer "*SMTP-invalid*"
+					'(READ-ONLY FLUSH-ON-SPACE)
+		 (lambda (buffer window)
+		   (let ((m (mark-left-inserting-copy (buffer-start buffer))))
+		     (for-each (lambda (rcpt response)
+				 (if (not (valid-response? response))
+				     (begin
+				       (insert-string rcpt m)
+				       (insert-char #\tab m)
+				       (insert-string response m)
+				       (insert-newline m))))
+			       rcpts responses)
+		     (mark-temporary! m)))))
+	      (trace-buffer
+	       (set-buffer-point! trace-buffer (buffer-start trace-buffer))
+	       (buffer-not-modified! trace-buffer)
+	       (pop-up-buffer trace-buffer #f)))
+	(message msg
+		 (if (if require-valid?
+			 (for-all? responses valid-response?)
+			 (there-exists? responses valid-response?))
+		     "done"
+		     "aborted"))))))
+
+(define (mail-deduce-address-list mail-buffer)
+  (let* ((header-start (buffer-start mail-buffer))
+	 (header-end (mail-header-end header-start))
+	 (regexp
+	  (if (mail-field-start header-start header-end "resent-to")
+	      "^\\(resent-to:\\|resent-cc:\\|resent-bcc:\\)[ \t]*"
+	      "^\\(to:\\|cc:\\|bcc:\\)[ \t]*")))
+    (let loop ((start header-start) (addresses '()))
+      (let ((field-start (re-search-forward regexp start header-end #t)))
+	(if field-start
+	    (let ((field-end (%mail-field-end field-start header-end)))
+	      (loop field-end
+		    (cons (rfc822-strip-quoted-names
+			   (extract-string field-start field-end))
+			  addresses)))
+	    (apply append (reverse! addresses)))))))
+
+(define (mail-delete-bcc-lines mail-buffer)
+  (let* ((header-start (buffer-start mail-buffer))
+	 (header-end (mail-header-end header-start)))
+    (let loop ((start header-start))
+      (let ((fs (mail-field-start start header-end "bcc")))
+	(if fs
+	    (let ((ls (line-start fs 0)))
+	      (delete-string ls
+			     (let ((fe (%mail-field-end fs end)))
+			       (if (mark< fe header-end) (mark1+ fe) fe)))
+	      (loop ls)))))))
+
+(define (call-with-smtp-socket host-name trace-buffer receiver)
+  (let ((port #f))
+    (dynamic-wind
+     (lambda ()
+       (set! port
+	     (make-smtp-port (open-tcp-stream-socket host-name "smtp")
+			     trace-buffer))
+       unspecific)
+     (lambda ()
+       (receiver port (smtp-read-response port 220)))
+     (lambda ()
+       (if port
+	   (begin
+	     (close-port (smtp-port-port port))
+	     (set! port #f)
+	     unspecific))))))
+
+(define-structure smtp-port
+  (port #f read-only #t)
+  (trace-buffer #f read-only #t))
+
+(define (smtp-read-line port)
+  (let ((line (read-line (smtp-port-port port))))
+    (smtp-trace-write-string line port)
+    (smtp-trace-newline port)
+    line))
+
+(define (smtp-write-line port . strings)
+  (for-each (lambda (string)
+	      (smtp-trace-write-string string port)
+	      (write-string string (smtp-port-port port)))
+	    strings)
+  (smtp-trace-newline port)
+  (newline (smtp-port-port port)))
+
+(define (smtp-drain-output port)
+  (flush-output (smtp-port-port port)))
+
+(define (smtp-trace-write-string string port)
+  (let ((trace-buffer (smtp-port-trace-buffer port)))
+    (if trace-buffer
+	(insert-string string (buffer-end trace-buffer)))))
+
+(define (smtp-trace-newline port)
+  (let ((trace-buffer (smtp-port-trace-buffer port)))
+    (if trace-buffer
+	(insert-newline (buffer-end trace-buffer)))))
+
+(define (smtp-command/helo port)
+  (smtp-write-line port "HELO " (os/hostname))
+  (smtp-read-response port 250))
+
+(define (smtp-command/mail port from)
+  (smtp-write-line port "MAIL FROM:<" from ">")
+  (smtp-read-response port 250))
+
+(define (smtp-command/rcpt port rcpt)
+  (smtp-write-line port "RCPT TO:<" rcpt ">")
+  (smtp-read-response port 250 550))
+
+(define (smtp-command/data port mail-buffer)
+  (smtp-write-line port "DATA")
+  (smtp-read-response port 354)
+  (let loop ((start (buffer-start mail-buffer)))
+    (if (not (group-end? start))
+	(let ((le (line-end start 0)))
+	  (let ((line (extract-string start le)))
+	    (if (and (fix:> 0 (string-length line))
+		     (char=? #\. (string-ref line 0)))
+		(smtp-write-line port "." line)
+		(smtp-write-line port line)))
+	  (if (not (group-end? le))
+	      (loop (mark1+ le))))))
+  (smtp-write-line port ".")
+  (smtp-read-response port 250))
+
+(define (smtp-command/rset port)
+  (smtp-write-line port "RSET")
+  (smtp-read-response port 250))
+
+(define (smtp-command/quit port)
+  (smtp-write-line port "QUIT")
+  (smtp-read-response port 221))
+
+(define (smtp-read-response port . numbers)
+  (smtp-drain-output port)
+  (let ((response (smtp-read-line port)))
+    (let ((n (smtp-response-number response)))
+      (if (not (there-exists? numbers (lambda (n*) (= n n*))))
+	  (editor-error response))
+      (if (smtp-response-continued? response)
+	  (let loop ((responses (list response)))
+	    (let ((response (smtp-read-line port)))
+	      (if (not (= n (smtp-response-number response)))
+		  (error "Mismatched codes in multiline response:" n response))
+	      (let ((responses (cons response responses)))
+		(if (smtp-response-continued? response)
+		    (loop responses)
+		    (convert-smtp-multiline-response (reverse! responses))))))
+	  response))))
+
+(define (smtp-response-number line)
+  (or (and (fix:>= (string-length line) 3)
+	   (substring->nonnegative-integer line 0 3))
+      (error "Malformed SMTP response:" line)))
+
+(define (smtp-response-continued? line)
+  (and (fix:>= (string-length line) 4)
+       (char=? #\- (string-ref line 3))))
+
+(define (convert-smtp-multiline-response responses)
+  (apply string-append
+	 (cons* (string-head (car responses) 3)
+		" "
+		(let ((lines
+		       (map (lambda (response) (string-tail (car responses) 4))
+			    responses)))
+		  (cons (car lines)
+			(append-map (lambda (line) (list "\n" line))
+				    lines))))))
\ No newline at end of file