sunet/smtp.scm

;;; SMTP client code		-*- Scheme -*- 
;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
;;; <bdc@ai.mit.edu>, <shivers@lcs.mit.edu>
;;;
;;; See rfc821: /ftp@ftp.internic.net:/rfc/rfc821.txt

;;; External dependencies and non-R4RS'isms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; system-name user-login-name			(for high-level SENDMAIL proc)
;;; receive values				(MV return)
;;; write-string read-string/partial 		(scsh I/O procs)
;;;      force-output
;;; scsh's socket module		
;;; :optional
;;; error
;;; switchq					(Conditional macro)
;;; ?						(COND)
;;; read-crlf-line write-crlf
;;; \n \r in strings				(Not R4RS)

;;; SMTP protocol procedures tend to return two values:
;;; - CODE The integer SMTP reply code returned by server for the transaction.
;;; - TEXT A list of strings -- the text messages tagged by the code.
;;; The text strings have the initial code numerals and the terminating
;;; cr/lf's stripped. Codes in the range [1,399] are sucess codes; codes
;;; in the range [400,599] are error codes; codes >= 600 are not part
;;; of the official SMTP spec. This module uses codes >= 600 to indicate
;;; extra-protocol errors. There are two of these:
;;; - 600 Server reply could not be parsed.
;;;   The server sent back some sort of incomprehensible garbage reply.
;;; - 621 Premature EOF while reading server reply.
;;;   The server shut down in the middle of a reply.
;;; A list of the official protocol return codes is appended at the end of
;;; this file.

;;; These little cover functions are trivial packagings of the protocol.
;;; You could write your own to handle, e.g., mailing a message to a list
;;; of addresses.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not a
;;; useful Internet host name. How do we do that?

;;; (sendmail to-list 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
;;; were rejected, sendmail sends to the rest of the recipients, and the
;;; partial-success return is [700 loser-alist] where loser-alist
;;; is a list whose elements are of the form (loser-recipient code . text) --
;;; 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.

(define (sendmail to-list body . maybe-host)
  (call-with-current-continuation
   (lambda (bailout)
     (let ((local (system-name))
	   (socket (smtp/open (:optional maybe-host "localhost"))))
       (receive (code text) (smtp-transactions socket	; Do prologue.
			      (smtp/helo socket local)
			      (smtp/mail socket (string-append (user-login-name)
							       "@" local)))
	 (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 socket to)
				 (and (>= code 400) ; Error
				      (cond ((>= code 600)
					     (smtp/quit socket)
					     (bailout code text))
					 (else `(,to ,code ,@text))))))
			     to-list)))

	       ;; Send the message body and wrap things up.
	       (receive (code text) (smtp-transactions socket
				      (smtp/data socket body)
				      (smtp/quit socket))
		 (if (and (< code 400) (null? losers))
		     (values code text)
		     (values 700 losers))))))))))

;;; Trivial utility -- like map, but filter out #f's.

(define (filter-map f lis)
  (let lp ((ans '()) (lis lis))
    (if (pair? lis)
	(lp (cond ((f (car lis)) => (lambda (val) (cons val ans)))
		  (else ans))
	    (cdr lis))
	(reverse ans))))

(define (%sendmail from local-host to dest-host message)
  (let ((socket (smtp/open dest-host)))
    (smtp-transactions socket
      (smtp/helo socket local-host)
      (smtp/mail socket from)
      (smtp/rcpt socket to)
      (smtp/data socket message)
      (smtp/quit socket))))


;;; EXPN, VRFY, MAIL-HELP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These three are simple queries of the server.

(define (smtp-query socket query arg)
  (receive (code text)
	     (smtp-transactions socket
               (smtp/helo socket (system-name))
	       (query socket arg))
      (if (not (or (= code 421) (= code 221)))
	  (smtp/quit socket))
      (values code text)))

(define (expn name host)
  (smtp-query (smtp/open host) smtp/expn name))

(define (vrfy name host)
  (smtp-query (smtp/open host) smtp/vrfy name))

(define (mail-help host . details)
  (smtp-query (smtp/open host) smtp/help (apply string-append details)))


;;; (smtp-transactions socket ?transaction1 ...)
;;; (smtp-transactions/no-close socket ?transaction1 ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These macros 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 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.
;;;
;;; Since SMTP-TRANSACTIONS closes the socket whenever it aborts a sequence,
;;; an SMTP-TRANSACTIONS form terminated with an (smtp/quit socket) transaction
;;; will always close the socket.
;;;
;;; 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-syntax smtp-transactions 
  (syntax-rules ()
    ((smtp-transactions socket ?T1 ?T2 ...)
     (let ((s socket))
       (receive (code text) (smtp-transactions/no-close s ?T1 ?T2 ...)
	 (if (<= 400 code) (smtp/quit s))
	 (values code text))))))

(define-syntax smtp-transactions/no-close
  (syntax-rules ()
    ((smtp-transactions/no-close socket ?T1 ?T2 ...)
     ;; %smtp-transactions/no-close replicates the socket argument, 
     ;; so we have to force it to be a variable.
     (let ((s socket))
       (%smtp-transactions/no-close s ?T1 ?T2 ...)))))

;;; SOCKET must be a variable, hence replicable.
(define-syntax %smtp-transactions/no-close
  (syntax-rules ()
    ((%smtp-transactions/no-close socket ?T1 ?T2 ?T3 ...)
     (receive (code text) ?T1
       (if (or (= code 221)
	       (= code 421)		; Redundant, I know.
	       (<= 400 code))
	   (values code text)
	   (%smtp-transactions/no-close socket ?T2 ?T3 ...))))

    ((%smtp-transactions/no-close socket ?T1)
     ?T1)))

;;; I can't make this nested definition work. I'm not enough of a macro stud.
;(define-syntax smtp-transactions/no-close
;  (syntax-rules ()
;    ((smtp-transactions/no-close socket ?T1 ...)
;     (letrec-syntax ((%smtp-transactions/no-close
;		      (syntax-rules ()
;
;		        ((%smtp-transactions/no-close socket ?T1 ?T2 ...)
;			 (receive (code text) ?T1
;			   (if (or (= code 221)
;				   (= code 421)		; Redundant, I know.
;				   (<= 400 code))
;			       (values code text)
;			       (%smtp-transactions/no-close socket ?T2 ...))))
;
;			((%smtp-transactions/no-close socket ?T1)
;			 ?T1))))
;
;       ;; %smtp-transactions/no-close replicates the socket argument, 
;       ;; so we have to force it to be a variable.
;       (let ((s socket))
;	 (%smtp-transactions/no-close s ?T1 ...))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The basics of the protocol

(define (nullary-smtp-command command)
  (lambda (socket)
    (let ((port (socket:outport socket)))
       (write-string command port)
       (write-crlf port))
    (handle-smtp-reply socket)))


(define (unary-smtp-command command)
  (lambda (socket data)
    (let ((port (socket:outport socket)))
       (write-string command port)
       (display      #\space port)
       (write-string data    port)
       (write-crlf           port))
    (handle-smtp-reply socket)))


(define (smtp/open 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
	  (error "SMTP socket-open server-reply error" sock code text)))))

;; HELLO <local-hostname>
(define smtp/helo (unary-smtp-command "HELO"))

;; MAIL FROM: <sender-address>
(define smtp/mail (unary-smtp-command "MAIL FROM:"))

;; RECIPIENT TO: <destination-address>
(define smtp/rcpt (unary-smtp-command "RCPT TO:"))

;; DATA
(define smtp/data
  (let ((send-DATA-msg (nullary-smtp-command "DATA")))
    (lambda (socket message)  ; MESSAGE is a string or an input port.
      (receive (code text) (send-DATA-msg socket)
	(if (>= code 400) (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)))
		    
		    ((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)))))))
		    
		    (else (error "Message must be string or input-port.")))

	      (write-string "\r\n.\r\n" p)
	      (force-output p)
	      (handle-smtp-reply socket)))))))

;; SEND FROM: <sender-address>
(define smtp/send (unary-smtp-command "SEND FROM:"))

;; SEND OR MAIL <sender-address>
(define smtp/soml (unary-smtp-command "SOML FROM:"))

;; SEND AND MAIL <sender-address>
(define smtp/saml (unary-smtp-command "SOML SAML:"))

;; RESET
(define smtp/rset (nullary-smtp-command "RSET"))

;; VERIFY <user>
(define smtp/vrfy (unary-smtp-command "VRFY"))

;; EXPAND <user>
(define smtp/expn (unary-smtp-command "EXPN"))

;; HELP <details>
(define smtp/help
  (let ((send-help (unary-smtp-command "HELP")))
    (lambda (socket . details)
      (send-help socket (apply string-append details)))))

;; NOOP
(define smtp/noop (nullary-smtp-command "NOOP"))

;; QUIT
(define smtp/quit
  (let ((quit (nullary-smtp-command "QUIT")))
    (lambda (socket)
      (receive (code text) (quit socket)    ; Quit & close socket gracefully.
	(case code		
	  ((221 421))
	  (else (close-socket socket)))	    ; But close in any event.
	(values code text)))))

;; 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.
;;; The text lines have the reply-code prefix (first 4 chars) and the
;;; terminating cr/lf's stripped.
;;;
;;; In bdc's analog of this proc, he would read another reply if the code was 
;;; in the one-hundred range (1xx). These codes aren't even used in smtp,
;;; according to the RFC. So why?

(define (handle-smtp-reply socket)
  (receive (code text) (read-smtp-reply (socket:inport socket))
    (case code
      ((221 421) (close-socket socket)))	; All done.
    (values code text)))

;;; Read a reply from the SMTP server. Returns two values:
;;; - CODE	Integer. The reply code.
;;; - TEXT	String list. A list of the text lines comprising the reply.
;;;             Each line of text is stripped of the initial reply-code
;;;             numerals (e.g., the first four chars of the reply), and
;;;		the trailing cr/lf. We are in fact generous about what
;;;             we take to be a line -- the protocol requires cr/lf
;;;             terminators, but we'll accept just lf. This appears to
;;;             true to the spirit of the "be strict in what you send,
;;;             and generous in what you accept" Internet protocol philosphy.

(define (read-smtp-reply port)
  (let lp ((replies '()))
    (let ((ln (read-crlf-line port)))
      (if (eof-object? ln)
	  (values 621 (cons "Premature EOF during smtp reply."
			    (reverse replies)))
	  (receive (code line more?) (parse-smtp-reply ln)
	    (let ((replies (cons line replies)))
	      (if more? (lp replies)
		  (values code (reverse replies)))))))))

;;; Parse a line of SMTP reply. Return three values:
;;;   CODE	integer - the reply code that prefixes the string.
;;;   REST	string  - the rest of the line.
;;;   MORE?     boolean - is there more reply to read (i.e., was the numeric 
;;;                       reply code terminated by a "-" character?)

(define (parse-smtp-reply line)
  (if (and (string? line)			; This is all checking
	   (> (string-length line) 3)		; to see if the line
	   (char-numeric? (string-ref line 0))	; is properly formatted.
	   (char-numeric? (string-ref line 1))
	   (char-numeric? (string-ref line 2))
	   (let ((c (string-ref line 3)))
	     (or (char=? c #\space) (char=? c #\-))))

      (values (string->number (substring line 0 3))	; It is.
	      (substring line 4 (string-length line))
	      (char=? (string-ref line 3) #\-))

      (values 600					; It isn't.
	      (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.
;;;
;;;   1yz   Positive Preliminary reply
;;;
;;;      The command has been accepted, but the requested action
;;;      is being held in abeyance, pending confirmation of the
;;;      information in this reply.  The sender-SMTP should send
;;;      another command specifying whether to continue or abort
;;;      the action.
;;;
;;;         [Note: SMTP does not have any commands that allow this
;;;         type of reply, and so does not have the continue or
;;;         abort commands.]
;;;
;;;   2yz   Positive Completion reply
;;;
;;;      The requested action has been successfully completed.  A
;;;      new request may be initiated.
;;;
;;;   3yz   Positive Intermediate reply
;;;
;;;      The command has been accepted, but the requested action
;;;      is being held in abeyance, pending receipt of further
;;;      information.  The sender-SMTP should send another command
;;;      specifying this information.  This reply is used in
;;;      command sequence groups.
;;;
;;;   4yz   Transient Negative Completion reply
;;;
;;;      The command was not accepted and the requested action did
;;;      not occur.  However, the error condition is temporary and
;;;      the action may be requested again.  The sender should
;;;      return to the beginning of the command sequence (if any).
;;;      It is difficult to assign a meaning to "transient" when
;;;      two different sites (receiver- and sender- SMTPs) must
;;;      agree on the interpretation.  Each reply in this category
;;;      might have a different time value, but the sender-SMTP is
;;;      encouraged to try again.  A rule of thumb to determine if
;;;      a reply fits into the 4yz or the 5yz category (see below)
;;;      is that replies are 4yz if they can be repeated without
;;;      any change in command form or in properties of the sender
;;;      or receiver.  (E.g., the command is repeated identically
;;;      and the receiver does not put up a new implementation.)
;;;
;;;   5yz   Permanent Negative Completion reply
;;;
;;;      The command was not accepted and the requested action did
;;;      not occur.  The sender-SMTP is discouraged from repeating
;;;      the exact request (in the same sequence).  Even some
;;;      "permanent" error conditions can be corrected, so the
;;;      human user may want to direct the sender-SMTP to
;;;      reinitiate the command sequence by direct action at some
;;;      point in the future (e.g., after the spelling has been
;;;      changed, or the user has altered the account status).
;;;
;;;The second digit encodes responses in specific categories:
;;;
;;;   x0z   Syntax -- These replies refer to syntax errors,
;;;         syntactically correct commands that don't fit any
;;;         functional category, and unimplemented or superfluous
;;;         commands.
;;;
;;;   x1z   Information --  These are replies to requests for
;;;         information, such as status or help.
;;;
;;;   x2z   Connections -- These are replies referring to the
;;;         transmission channel.
;;;
;;;   x3z   Unspecified as yet.
;;;
;;;   x4z   Unspecified as yet.
;;;
;;;   x5z   Mail system -- These replies indicate the status of
;;;         the receiver mail system vis-a-vis the requested
;;;         transfer or other mail system action.

;;; Complete list (grouped by function)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 500 Syntax error, command unrecognized
;;;    [This may include errors such as command line too long]
;;; 501 Syntax error in parameters or arguments
;;; 502 Command not implemented
;;; 503 Bad sequence of commands
;;; 504 Command parameter not implemented
;;;  
;;; 211 System status, or system help reply
;;; 214 Help message
;;;    [Information on how to use the receiver or the meaning of a
;;;    particular non-standard command; this reply is useful only
;;;    to the human user]
;;;  
;;; 220 <domain> Service ready
;;; 221 <domain> Service closing transmission channel
;;; 421 <domain> Service not available,
;;;     closing transmission channel
;;;    [This may be a reply to any command if the service knows it
;;;    must shut down]
;;;  
;;; 250 Requested mail action okay, completed
;;; 251 User not local; will forward to <forward-path>
;;; 450 Requested mail action not taken: mailbox unavailable
;;;    [E.g., mailbox busy]
;;; 550 Requested action not taken: mailbox unavailable
;;;    [E.g., mailbox not found, no access]
;;; 451 Requested action aborted: error in processing
;;; 551 User not local; please try <forward-path>
;;; 452 Requested action not taken: insufficient system storage
;;; 552 Requested mail action aborted: exceeded storage allocation
;;; 553 Requested action not taken: mailbox name not allowed
;;;    [E.g., mailbox syntax incorrect]
;;; 354 Start mail input; end with <CRLF>.<CRLF>
;;; 554 Transaction failed
;;;

;;; State diagram
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONNECTION ESTABLISHMENT
;;;     S: 220
;;;     F: 421
;;;  HELO
;;;     S: 250
;;;     E: 500, 501, 504, 421
;;;  MAIL
;;;     S: 250
;;;     F: 552, 451, 452
;;;     E: 500, 501, 421
;;;  RCPT
;;;     S: 250, 251
;;;     F: 550, 551, 552, 553, 450, 451, 452
;;;     E: 500, 501, 503, 421
;;;  DATA
;;;     I: 354 -> data -> S: 250
;;;                       F: 552, 554, 451, 452
;;;     F: 451, 554
;;;     E: 500, 501, 503, 421
;;;  RSET
;;;     S: 250
;;;     E: 500, 501, 504, 421
;;;  SEND
;;;     S: 250
;;;     F: 552, 451, 452
;;;     E: 500, 501, 502, 421
;;;  SOML
;;;     S: 250
;;;     F: 552, 451, 452
;;;     E: 500, 501, 502, 421
;;;  SAML
;;;     S: 250
;;;     F: 552, 451, 452
;;;     E: 500, 501, 502, 421
;;;  VRFY
;;;     S: 250, 251
;;;     F: 550, 551, 553
;;;     E: 500, 501, 502, 504, 421
;;;  EXPN
;;;     S: 250
;;;     F: 550
;;;     E: 500, 501, 502, 504, 421
;;;  HELP
;;;     S: 211, 214
;;;     E: 500, 501, 502, 504, 421
;;;  NOOP
;;;     S: 250
;;;     E: 500, 421
;;;  QUIT
;;;     S: 221
;;;     E: 500
;;;  TURN
;;;     S: 250
;;;     F: 502
;;;     E: 500, 503