518 lines
18 KiB
Scheme
518 lines
18 KiB
Scheme
;;; 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.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;;; 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?
|
|
|
|
;;; (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 ((local (host-info:name (host-info (system-name))))
|
|
(socket (smtp/open (:optional maybe-host "localhost"))))
|
|
(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
|