sunet/scheme/lib/smtp.scm

;;; SMTP client code		-*- Scheme -*- 

;;; This file is part of the Scheme Untergrund Networking package.

;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.

;;; See rfc821: http://www.ietf.org/rfc/rfc0821.txt

;;; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; (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
;;; 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 list of strings or an input port.

(define (send-mail-via-smtp 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)))
       (receive (code text)
	   (smtp-transactions/no-close socket ; Do prologue.
				       (smtp/helo local)
				       (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)
				(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 headers body))
		 (if (and (< code 400) (null? losers))
		     (values code text)
		     (values 700 losers))))))))))

;;; 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 (system-name))
			 (query arg))
    (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 (cons " " details))))


;;; (smtp-transactions socket transaction1 ...)
;;; (smtp-transactions/no-close socket transaction1 ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)))
    (values code text)))

(define (smtp-transactions/no-close socket . transactions)
  (let loop ((transactions transactions))
    (receive (code text) ((car transactions) socket)
      (if (or (null? (cdr transactions))
	      (= code 221)
	      (= code 421)		; Redundant, I know.
	      (<= 400 code))
	  (values code text)
	  (loop (cdr transactions))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 (data)
    (lambda (socket)
      (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 (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.

	      ;; We got a positive acknowledgement for the DATA msg,
	      ;; now send the message body.
	      (let ((p (socket:outport socket)))
		(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 ()
			 (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.")))

		(write-crlf p)
		(write-char #\. p)
		(write-crlf p)
		(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:"))

;; 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 details
      (send-help (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)))

;;; 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