Revamp SMTP once more:

- introduce SMTP-CONNECTION records
- regularize naming (no funny slashes)
- in SMTP-SEND-MAIL, add date header if not present
- gratuitous capitalizion of word components for field names in outgoing headers

scheme/lib/smtp.scm

@@ -3,6 +3,7 @@
 ;;; This file is part of the Scheme Untergrund Networking package.
 
 ;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
+;;; Copyright (c) 2002-2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
 ;;; For copyright information, see the file COPYING which comes with
 ;;; the distribution.
 
@@ -28,9 +29,6 @@
 ;;; of addresses.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-
-;;; (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
 ;;; text-list. However, if only problem with message is that some recipients
@@ -42,110 +40,78 @@
 ;;;
 ;;; BODY is a list of strings or an input port.
 
-(define (send-mail-via-smtp from to-list headers body . maybe-host)
+(define (smtp-send-mail from to-list headers body . maybe-host)
   (call-with-current-continuation
    (lambda (bailout)
      (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)))
+	    (connection (smtp-connect host)))
        (receive (code text)
-	   (smtp-transactions/no-close socket ; Do prologue.
+	   (smtp-transactions/no-close connection ; Do prologue.
-				       (smtp/helo local)
+				       (smtp-helo local)
-				       (smtp/mail from))
+				       (smtp-mail from))
 	 (if (>= code 400)
 	     (values code text)		; error
 	     ;; Send over recipients and collect the losers.
 	     (let ((losers (filter-map
 			    (lambda (to)
-			      (receive (code text) ((smtp/rcpt to) socket)
+			      (receive (code text)
+				  ((smtp-rcpt to) (smtp-connection-socket connection))
 				(and (>= code 400) ; Error
 				     (cond ((>= code 600)
-					    (smtp/quit socket)
+					    (smtp-quit
+					     (smtp-connection-socket connection))
 					    (bailout code text))
 					   (else `(,to ,code ,@text))))))
 			    to-list)))
 
 	       ;; Send the message body and wrap things up.
-	       (receive (code text) (smtp-transactions socket
+	       (receive (code text)
-						       (smtp/data headers body))
+		   (smtp-transactions connection
+				      (smtp-data (normalize-headers headers) body))
 		 (if (and (< code 400) (null? losers))
 		     (values code text)
 		     (values 700 losers))))))))))
 
-;;; EXPN, VRFY, MAIL-HELP
+(define (normalize-headers headers)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  (if (assq 'date headers)
-;;; These three are simple queries of the server.
+      headers
+      (cons (cons 'date
+		  (rfc822-time->string (time)))
+	    headers)))
 
 (define (smtp-query socket query arg)
   (receive (code text)
       (smtp-transactions socket
-			 (smtp/helo (system-name))
+			 (smtp-helo (system-name))
 			 (query arg))
     (values code text)))
 
-(define (expn name host)
+(define (smtp-expand name host)
-  (smtp-query (smtp/open host) smtp/expn name))
+  (smtp-query (smtp-connect host) smtp-expn name))
 
-(define (vrfy name host)
+(define (smtp-verify name host)
-  (smtp-query (smtp/open host) smtp/vrfy name))
+  (smtp-query (smtp-connect host) smtp-vrfy name))
 
-(define (mail-help host . details)
+(define (smtp-get-help host . details)
-  (smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details))))
+  (smtp-query (smtp-connect host) smtp-help (apply string-append (cons " " details))))
 
-
+(define (smtp-transactions connection . transactions)
-;;; (smtp-transactions socket transaction1 ...)
+  (let ((socket (smtp-connection-socket connection)))
-;;; (smtp-transactions/no-close socket transaction1 ...)
+    (receive (code text) (apply smtp-transactions/no-close connection transactions)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; These procedures make it easy to do simple sequences of SMTP commands.
-;;;
-;;; Evaluate a series of expressions ?transaction1, ?transaction2, ...
-;;; - Each expression should perform an SMTP transaction, 
-;;;   and return two values:
-;;;   + CODE (the integer reply code)
-;;;   + TEXT (list of strings that came with the reply).
-;;;
-;;; - If the transaction's reply code is 221 or 421 (meaning the socket has
-;;;   been closed), then the transaction sequence is aborted, and the
-;;;   SMTP-TRANSACTIONS form returns the CODE and TEXT values for the current
-;;;   transaction.
-;;;
-;;; - If the reply code is an error code (in the four- or five-hundred range), 
-;;;   the transaction sequence is aborted, and the fatal transaction's CODE
-;;;   and TEXT values are returned. SMTP-TRANSACTIONS will additionally
-;;;   close the socket for you; SMTP-TRANSACTIONS/NO-CLOSE will not.
-;;;
-;;; - If the transaction is the last in the transaction sequence, 
-;;;   its CODE and TEXT values are returned.
-;;;
-;;; - Otherwise, we throw away the current CODE and TEXT values, and
-;;;   proceed to the next transaction.
-;;;
-;;; SMTP-TRANSACTIONS closes the socket after the transaction.
-;;;
-;;; If the socket should be kept open in the case of an abort, use
-;;; SMTP-TRANSACTIONS/NO-CLOSE.
-;;;
-;;; We abort sequences if a transaction results in a 400-class error code.
-;;; So, a sequence mailing a message to five people, with 5 RCPT's, would
-;;; abort if the mailing address for one of these people was wrong, rather
-;;; than proceeding to mail the other four. This may not be what you want;
-;;; if so, you'll have to roll your own.
-
-(define (smtp-transactions socket . transactions)
-  (receive (code text) (apply smtp-transactions/no-close socket transactions)
       (cond
        ((or (= code 221)
 	    (= code 421))
 	(values))
        (else
-      (smtp/quit socket)))
+	(smtp-quit socket)))
-    (values code text)))
+      (values code text))))
 
-(define (smtp-transactions/no-close socket . transactions)
+(define (smtp-transactions/no-close connection . transactions)
   (let loop ((transactions transactions))
-    (receive (code text) ((car transactions) socket)
+    (receive (code text) ((car transactions) (smtp-connection-socket connection))
       (if (or (null? (cdr transactions))
 	      (= code 221)
 	      (= code 421)		; Redundant, I know.
@@ -173,26 +139,30 @@
 	(write-crlf           port))
       (handle-smtp-reply socket))))
 
+(define-record-type smtp-connection :smtp-connection
+  (make-smtp-connection socket)
+  smtp-connection?
+  (socket smtp-connection-socket))
 
-(define (smtp/open host . maybe-port)
+(define (smtp-connect host . maybe-port)
   (let ((sock (socket-connect protocol-family/internet socket-type/stream host
 			      (:optional maybe-port "smtp"))))
     (receive (code text) (handle-smtp-reply sock)
       (if (< code 400)
-	  sock
+	  (make-smtp-connection sock)
 	  (error "SMTP socket-open server-reply error" sock code text)))))
 
 ;; HELLO <local-hostname>
-(define smtp/helo (unary-smtp-command "HELO"))
+(define smtp-helo (unary-smtp-command "HELO"))
 
 ;; MAIL FROM: <sender-address>
-(define smtp/mail (unary-smtp-command "MAIL FROM:"))
+(define smtp-mail (unary-smtp-command "MAIL FROM:"))
 
 ;; RECIPIENT TO: <destination-address>
-(define smtp/rcpt (unary-smtp-command "RCPT TO:"))
+(define smtp-rcpt (unary-smtp-command "RCPT TO:"))
 
 ;; DATA
-(define smtp/data
+(define smtp-data
   (let ((send-DATA-msg (nullary-smtp-command "DATA")))
     (lambda (headers message)		; MESSAGE is a list of strings or an input port.
       (lambda (socket)
@@ -204,7 +174,7 @@
 	      ;; now send the message body.
 	      (let ((p (socket:outport socket)))
 		(for-each (lambda (pair)
-			    (display (car pair) p)
+			    (display (symbol->field-name (car pair)) p)
 			    (write-char #\: p)
 			    (display (cdr pair) p)
 			    (write-crlf p))
@@ -232,6 +202,18 @@
 		(force-output p)
 		(handle-smtp-reply socket))))))))
 
+(define component-charset (char-set-complement (char-set #\-)))
+
+(define (symbol->field-name symbol)
+  (let ((components (string-tokenize (symbol->string symbol) component-charset)))
+    (string-join (map upcase-string components) "-")))
+
+(define (upcase-string strng)
+  (if (string=? "" strng)
+      ""
+      (string-append (string (char-upcase (string-ref strng 0)))
+		     (substring strng 1 (string-length strng)))))
+
 (define (write-data-line line port)
   (display (if (string=? line ".")
 	       ".."
@@ -240,34 +222,34 @@
   (write-crlf port))
 
 ;; SEND FROM: <sender-address>
-(define smtp/send (unary-smtp-command "SEND FROM:"))
+(define smtp-send (unary-smtp-command "SEND FROM:"))
 
 ;; SEND OR MAIL <sender-address>
-(define smtp/soml (unary-smtp-command "SOML FROM:"))
+(define smtp-soml (unary-smtp-command "SOML FROM:"))
 
 ;; SEND AND MAIL <sender-address>
-(define smtp/saml (unary-smtp-command "SOML SAML:"))
+(define smtp-saml (unary-smtp-command "SOML SAML:"))
 
 ;; RESET
-(define smtp/rset (nullary-smtp-command "RSET"))
+(define smtp-rset (nullary-smtp-command "RSET"))
 
 ;; VERIFY <user>
-(define smtp/vrfy (unary-smtp-command "VRFY"))
+(define smtp-vrfy (unary-smtp-command "VRFY"))
 
 ;; EXPAND <user>
-(define smtp/expn (unary-smtp-command "EXPN"))
+(define smtp-expn (unary-smtp-command "EXPN"))
 
 ;; HELP <details>
-(define smtp/help
+(define smtp-help
   (let ((send-help (unary-smtp-command "HELP")))
     (lambda details
       (send-help (apply string-append details)))))
 
 ;; NOOP
-(define smtp/noop (nullary-smtp-command "NOOP"))
+(define smtp-noop (nullary-smtp-command "NOOP"))
 
 ;; QUIT
-(define smtp/quit
+(define smtp-quit
   (let ((quit (nullary-smtp-command "QUIT")))
     (lambda (socket)
       (receive (code text) (quit socket) ; Quit & close socket gracefully.
@@ -277,7 +259,7 @@
 	(values code text)))))
 
 ;; TURN
-(define smtp/turn (nullary-smtp-command "TURN"))
+(define smtp-turn (nullary-smtp-command "TURN"))
 
 ;;; Read and handle the reply. Return an integer (the reply code),
 ;;; and a list of the text lines that came tagged by the reply code.

scheme/packages.scm

@@ -32,13 +32,14 @@
 	  emit-text))
 
 (define-interface smtp-interface
-  (export send-mail-via-smtp
+  (export smtp-send-mail
-	  expn vrfy mail-help
+	  smtp-expand smtp-verify smtp-help
 	  smtp-transactions
 	  smtp-transactions/no-close
-	  smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
+	  smtp-connect
-	  smtp/send smtp/soml smtp/saml smtp/rset smtp/expn
+	  smtp-helo smtp-mail smtp-rcpt smtp-data
-	  smtp/help smtp/noop smtp/quit smtp/turn))
+	  smtp-send smtp-soml smtp-saml smtp-rset smtp-expn
+	  smtp-help smtp-noop smtp-quit smtp-turn))
 
 (define-interface rfc822-interface
   (export read-rfc822-headers
@@ -371,12 +372,14 @@
 				
   (open scheme-with-scsh
 					; user-login-name and sockets
+	define-record-types
 	(subset srfi-1 (filter-map))
+	(subset srfi-13 (string-tokenize string-join))
 	crlf-io				; read-crlf-line write-crlf
 	receiving			; values receive
-	let-opt				; let-optionals
 	dns				; SYSTEM-FQDN
-	)
+	let-opt
+	(subset rfc822 (rfc822-time->string)))
   (files (lib smtp)))
 
 (define-structure rfc822 rfc822-interface