Make SEND-MAIL-VIA-SMTP accept a headers argument.

scheme/lib/smtp.scm

@@ -34,7 +34,7 @@
 ;;; [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 body [host])
+;;; (send-mail-via-smtp from to-list headers body [host])
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Mail message to recipients in list TO-LIST. Message handed off to server
 ;;; running on HOST; default is the local host. Returns two values: code and
@@ -45,9 +45,9 @@
 ;;; that is, for each recipient refused by the server, you get the error
 ;;; data sent back for that guy. The success check is (< code 400).
 ;;;
-;;; BODY is a string or an input port.
+;;; BODY is a list of strings or an input port.
 
-(define (send-mail-via-smtp from to-list body . maybe-host)
+(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))))
@@ -71,7 +71,7 @@
 
 	       ;; Send the message body and wrap things up.
 	       (receive (code text) (smtp-transactions socket
-						       (smtp/data body))
+						       (smtp/data headers body))
 		 (if (and (< code 400) (null? losers))
 		     (values code text)
 		     (values 700 losers))))))))))
@@ -196,27 +196,35 @@
 ;; DATA
 (define smtp/data
   (let ((send-DATA-msg (nullary-smtp-command "DATA")))
-    (lambda (message)			; MESSAGE is a string or an input port.
+    (lambda (headers message)		; MESSAGE is a list of strings or an input port.
       (lambda (socket)
 	(receive (code text) (send-DATA-msg socket)
 	  (if (>= code 400)
-	      (values code text) ; Error.
+	      (values code text)	; Error.
 
 	      ;; We got a positive acknowledgement for the DATA msg,
 	      ;; now send the message body.
 	      (let ((p (socket:outport socket)))
-		(cond ((string? message)
-		       (receive (data last-char) (smtp-stuff message #f)
-			 (write-string data p)))
+		(for-each (lambda (pair)
+			    (display (car pair) p)
+			    (write-char #\: p)
+			    (display (cdr pair) p)
+			    (write-crlf p))
+			  headers)
+		(write-crlf p)
+		
+		(cond ((or (null? message) (pair? message))
+		       (for-each (lambda (line)
+				   (write-data-line line p))
+				 message))
 		    
 		      ((input-port? message)
-		       (let lp ((last-char #f))
-			 (cond ((read-string/partial 1024 message) =>
-				(lambda (chunk)
-				  (receive (data last-char)
-				      (smtp-stuff chunk last-char)
-				    (write-string data p)
-				    (lp last-char)))))))
+		       (let lp ()
+			 (let ((stuff (read-line message)))
+			   (if (not (eof-object? stuff))
+			       (begin
+				 (write-data-line stuff p)
+				 (newline))))))
 		    
 		      (else (error "Message must be string or input-port.")))
 
@@ -226,6 +234,13 @@
 		(force-output p)
 		(handle-smtp-reply socket))))))))
 
+(define (write-data-line line port)
+  (display (if (string=? line ".")
+	       ".."
+	       line)
+	   port)
+  (write-crlf port))
+
 ;; SEND FROM: <sender-address>
 (define smtp/send (unary-smtp-command "SEND FROM:"))
 
@@ -327,50 +342,6 @@
 	      (string-append "Improperly-formatted smtp reply: " line)
 	      #f)))
 
-
-;;; The message body of a piece of email is terminated by the sequence 
-;;;     <crlf> <period> <crlf>
-;;; If the message body contains this magic sequence, it has to be escaped.
-;;; We do this by mapping the sequence <lf> <period> to <lf> <period> <period>;
-;;; the SMTP receiver undoes this mapping.
-
-;;; S is a string to stuff, PCHAR was the character read just before S
-;;; (which matters if it is a line-feed). If S is the first chunk of the entire
-;;; msg, then PCHAR can be #f. Return two values: the stuffed string, and the
-;;; last char in S (or PCHAR if S is empty). The last-char value returned can
-;;; be used as the PCHAR arg for the following call to SMTP-STUFF.
-
-(define (smtp-stuff s pchar)
-  (let* ((slen (string-length s))
-	 (hits ; Count up all the <lf> <period> seqs in the string.
-	  (let lp ((count 0)
-		   (nl? (eqv? pchar #\newline))	; Was last char a newline?
-		   (i 0))
-	    (if (< i slen)
-		(let ((c (string-ref s i)))
-		  (lp (if (and nl? (char=? c #\.)) (+ count 1) count)
-		      (eq? c #\newline)
-		      (+ i 1)))
-		count))))
-
-    (values (if (zero? hits)
-		s
-		;; Make a new string, and do the dot-stuffing copy.
-		(let ((ns (make-string (+ hits slen))))
-		  (let lp ((nl? (eqv? pchar #\newline))
-			   (i 0)	; S index.
-			   (j 0))	; NS index.
-		    (if (< i slen)
-			(let ((c (string-ref s i)))
-			  (string-set! ns j c)
-			  (cond ((and nl? (char=? c #\.))
-				 (string-set! ns (+ j 1) #\.)
-				 (lp #f (+ i 1) (+ j 2)))
-				(else (lp (char=? c #\newline) (+ i 1) (+ j 1)))))))
-		  ns))
-	    
-	    (if (zero? slen) pchar (string-ref s (- slen 1))))))    ; LAST-CHAR
-
 ;;; Reply codes
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; This material taken from the RFC.