Revamp SMTP once more:

- introduce SMTP-CONNECTION records
- regularize naming (no funny slashes)
- in SMTP-SEND-MAIL, add date header if not present
- gratuitous capitalizion of word components for field names in outgoing headers
This commit is contained in:
sperber 2003-01-21 15:31:38 +00:00
parent 9b59e5bbe6
commit 65279a42e9
2 changed files with 81 additions and 96 deletions

View File

@ -3,6 +3,7 @@
;;; 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.
@ -28,9 +29,6 @@
;;; of addresses.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (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
@ -42,110 +40,78 @@
;;;
;;; BODY is a list of strings or an input port.
(define (send-mail-via-smtp from to-list headers body . maybe-host)
(define (smtp-send-mail from to-list headers body . maybe-host)
(call-with-current-continuation
(lambda (bailout)
(let* ((host (:optional maybe-host "localhost"))
(local (if (string=? host "localhost")
(system-name) ; we don't need any DNS for that
(system-fqdn)))
(socket (smtp/open host)))
(connection (smtp-connect host)))
(receive (code text)
(smtp-transactions/no-close socket ; Do prologue.
(smtp/helo local)
(smtp/mail from))
(smtp-transactions/no-close connection ; 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)
(receive (code text)
((smtp-rcpt to) (smtp-connection-socket connection))
(and (>= code 400) ; Error
(cond ((>= code 600)
(smtp/quit socket)
(smtp-quit
(smtp-connection-socket connection))
(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))
(receive (code text)
(smtp-transactions connection
(smtp-data (normalize-headers 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 (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))
(smtp-helo (system-name))
(query arg))
(values code text)))
(define (expn name host)
(smtp-query (smtp/open host) smtp/expn name))
(define (smtp-expand name host)
(smtp-query (smtp-connect host) smtp-expn name))
(define (vrfy name host)
(smtp-query (smtp/open host) smtp/vrfy name))
(define (smtp-verify name host)
(smtp-query (smtp-connect host) smtp-vrfy name))
(define (mail-help host . details)
(smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details))))
(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))))
;;; (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)
(define (smtp-transactions/no-close connection . transactions)
(let loop ((transactions transactions))
(receive (code text) ((car transactions) socket)
(receive (code text) ((car transactions) (smtp-connection-socket connection))
(if (or (null? (cdr transactions))
(= code 221)
(= code 421) ; Redundant, I know.
@ -173,26 +139,30 @@
(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/open host . maybe-port)
(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)
sock
(make-smtp-connection sock)
(error "SMTP socket-open server-reply error" sock code text)))))
;; HELLO <local-hostname>
(define smtp/helo (unary-smtp-command "HELO"))
(define smtp-helo (unary-smtp-command "HELO"))
;; MAIL FROM: <sender-address>
(define smtp/mail (unary-smtp-command "MAIL FROM:"))
(define smtp-mail (unary-smtp-command "MAIL FROM:"))
;; RECIPIENT TO: <destination-address>
(define smtp/rcpt (unary-smtp-command "RCPT TO:"))
(define smtp-rcpt (unary-smtp-command "RCPT TO:"))
;; DATA
(define smtp/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)
@ -204,7 +174,7 @@
;; now send the message body.
(let ((p (socket:outport socket)))
(for-each (lambda (pair)
(display (car pair) p)
(display (symbol->field-name (car pair)) p)
(write-char #\: p)
(display (cdr pair) p)
(write-crlf p))
@ -232,6 +202,18 @@
(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 ".")
".."
@ -240,34 +222,34 @@
(write-crlf port))
;; SEND FROM: <sender-address>
(define smtp/send (unary-smtp-command "SEND FROM:"))
(define smtp-send (unary-smtp-command "SEND FROM:"))
;; SEND OR MAIL <sender-address>
(define smtp/soml (unary-smtp-command "SOML FROM:"))
(define smtp-soml (unary-smtp-command "SOML FROM:"))
;; SEND AND MAIL <sender-address>
(define smtp/saml (unary-smtp-command "SOML SAML:"))
(define smtp-saml (unary-smtp-command "SOML SAML:"))
;; RESET
(define smtp/rset (nullary-smtp-command "RSET"))
(define smtp-rset (nullary-smtp-command "RSET"))
;; VERIFY <user>
(define smtp/vrfy (unary-smtp-command "VRFY"))
(define smtp-vrfy (unary-smtp-command "VRFY"))
;; EXPAND <user>
(define smtp/expn (unary-smtp-command "EXPN"))
(define smtp-expn (unary-smtp-command "EXPN"))
;; HELP <details>
(define smtp/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"))
(define smtp-noop (nullary-smtp-command "NOOP"))
;; QUIT
(define smtp/quit
(define smtp-quit
(let ((quit (nullary-smtp-command "QUIT")))
(lambda (socket)
(receive (code text) (quit socket) ; Quit & close socket gracefully.
@ -277,7 +259,7 @@
(values code text)))))
;; TURN
(define smtp/turn (nullary-smtp-command "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.

View File

@ -32,13 +32,14 @@
emit-text))
(define-interface smtp-interface
(export send-mail-via-smtp
expn vrfy mail-help
(export smtp-send-mail
smtp-expand smtp-verify smtp-help
smtp-transactions
smtp-transactions/no-close
smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
smtp/send smtp/soml smtp/saml smtp/rset smtp/expn
smtp/help smtp/noop smtp/quit smtp/turn))
smtp-connect
smtp-helo smtp-mail smtp-rcpt smtp-data
smtp-send smtp-soml smtp-saml smtp-rset smtp-expn
smtp-help smtp-noop smtp-quit smtp-turn))
(define-interface rfc822-interface
(export read-rfc822-headers
@ -371,12 +372,14 @@
(open scheme-with-scsh
; user-login-name and sockets
define-record-types
(subset srfi-1 (filter-map))
(subset srfi-13 (string-tokenize string-join))
crlf-io ; read-crlf-line write-crlf
receiving ; values receive
let-opt ; let-optionals
dns ; SYSTEM-FQDN
)
let-opt
(subset rfc822 (rfc822-time->string)))
(files (lib smtp)))
(define-structure rfc822 rfc822-interface