scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
sunet/smtp.scm

607 lines
22 KiB
Scheme
Raw Permalink Blame History

;;; SMTP client code -*- Scheme -*-
;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
;;; <bdc@ai.mit.edu>, <shivers@lcs.mit.edu>
;;;
;;; See rfc821: /ftp@ftp.internic.net:/rfc/rfc821.txt
;;; External dependencies and non-R4RS'isms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; system-name user-login-name (for high-level SENDMAIL proc)
;;; receive values (MV return)
;;; write-string read-string/partial (scsh I/O procs)
;;; force-output
;;; scsh's socket module
;;; :optional
;;; error
;;; switchq (Conditional macro)
;;; ? (COND)
;;; read-crlf-line write-crlf
;;; \n \r in strings (Not R4RS)
;;; 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?
;;; (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 (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
(? ((>= 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 (? ((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 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 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 <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 (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)))
(? ((string? message)
(receive (data last-char) (smtp-stuff message #f)
(write-string data p)))
((input-port? message)
(let lp ((last-char #f))
(? ((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: <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 (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.
(switchq = 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))
(switchq = 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
;;; <crlf> <period> <crlf>
;;; If the message body contains this magic sequence, it has to be escaped.
;;; We do this by mapping the sequence <lf> <period> to <lf> <period> <period>;
;;; 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 <lf> <period> 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)
(? ((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 <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
Reference in New Issue View Git Blame Copy Permalink