494 lines
17 KiB
Scheme
494 lines
17 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.
|
|
;;; Copyright (c) 2002-2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
|
;;; 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 <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 (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: <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
|