;;; SMTP client code -*- Scheme -*- ;;; 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 ;;; 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. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-condition-type 'smtp-error '(error)) (define smtp-error? (condition-predicate 'smtp-error)) (define-condition-type 'smtp-recipients-rejected-error '(smtp-error)) (define smtp-recipients-rejected-error? (condition-predicate 'smtp-recipients-rejected-error?)) (define (smtp-send-mail from to-list headers body . maybe-host) (let* ((host (:optional maybe-host "localhost")) (local (if (string=? host "localhost") (system-name) ; we don't need any DNS for that (system-fqdn))) (connection (smtp-connect host))) (receive (code text) (smtp-transactions/no-close connection ; Do prologue. (smtp-helo local) (smtp-mail from)) (if (>= code 400) (begin (smtp-quit (smtp-connection-socket connection)) (signal 'smtp-error code text)) ;; Send over recipients and collect the losers. (let ((losers (filter-map (lambda (to) (receive (code text) ((smtp-rcpt to) (smtp-connection-socket connection)) (and (>= code 400) ; Error (cond ((>= code 600) (smtp-quit (smtp-connection-socket connection)) (signal 'smtp-error code text)) (else `(,to ,code ,@text)))))) to-list))) ;; Send the message body and wrap things up. (receive (code text) (smtp-transactions connection (smtp-data (normalize-headers headers) body)) (if (or (>= code 400) (not (null? losers))) (signal 'smtp-recipients-rejected-error 700 losers)))))))) (define (normalize-headers headers) (if (assq 'date headers) 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)) (query arg)) (values code text))) (define (smtp-expand name host) (smtp-query (smtp-connect host) smtp-expn name)) (define (smtp-verify name host) (smtp-query (smtp-connect host) smtp-vrfy name)) (define (smtp-get-help host . details) (smtp-query (smtp-connect host) smtp-help (apply string-append (cons " " details)))) (define (smtp-transactions connection . transactions) (let ((socket (smtp-connection-socket connection))) (receive (code text) (apply smtp-transactions/no-close connection transactions) (cond ((or (= code 221) (= code 421)) (values)) (else (smtp-quit socket))) (values code text)))) (define (smtp-transactions/no-close connection . transactions) (let loop ((transactions transactions)) (receive (code text) ((car transactions) (smtp-connection-socket connection)) (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-record-type smtp-connection :smtp-connection (make-smtp-connection socket) smtp-connection? (socket smtp-connection-socket)) (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) (make-smtp-connection 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 (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 (symbol->field-name (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) (lp)))))) (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 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 ".") ".." line) port) (write-crlf port)) ;; 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 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 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