;;; SMTP client code -*- Scheme -*- ;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers. ;;; , ;;; ;;; 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. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not ;;; a useful Internet host name. How do we do that? ;;; [Andreas:] I've inserted a way to do this. It works fine on my ;;; system. Does it work on your, too? ;;; (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 (host-info:name (host-info (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 (cons " " 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 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 (define smtp/helo (unary-smtp-command "HELO")) ;; MAIL FROM: (define smtp/mail (unary-smtp-command "MAIL FROM:")) ;; RECIPIENT TO: (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: (define smtp/send (unary-smtp-command "SEND FROM:")) ;; SEND OR MAIL (define smtp/soml (unary-smtp-command "SOML FROM:")) ;; SEND AND MAIL (define smtp/saml (unary-smtp-command "SOML SAML:")) ;; RESET (define smtp/rset (nullary-smtp-command "RSET")) ;; VERIFY (define smtp/vrfy (unary-smtp-command "VRFY")) ;; EXPAND (define smtp/expn (unary-smtp-command "EXPN")) ;; HELP
(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 ;;; ;;; If the message body contains this magic sequence, it has to be escaped. ;;; We do this by mapping the sequence to ; ;;; 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 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 Service ready ;;; 221 Service closing transmission channel ;;; 421 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 ;;; 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 ;;; 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 . ;;; 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