suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add TLS support to SMTP

Browse Source 
svn: r5678
This commit is contained in:
Matthew Flatt 2007-02-23 21:27:10 +00:00
parent 3652cbee39
commit 8138f08177
2 changed files with 65 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/net/doc.txt
View File

@ -524,6 +524,7 @@ PROCEDURES -----------------------------------------------------------
[#:auth-user user-string-or-#f]
[#:auth-passwd pw-string-or-#f]
[#:tcp-connect proc]
[#:tls-encode #f]
[port-no]) -> void
The first argument is the IP address of the SMTP server. The
@ -552,6 +553,17 @@ PROCEDURES -----------------------------------------------------------
`ssl-connect' from `(lib "mzssl.ss" "openssl")' to connect to the
server via SSL.
If the optional #:tls-encode keyword argument supplies a procedure
instead of #f, then the ESMTP STARTTLS protocol is used to request
SSL communication with the server. The procedure given as the
#:tls-encode argument should be like `ports->ssl-ports' from `(lib
"mzssl.ss" "openssl")'; it will be called as
(encode r w #:mode 'connect #:encrypt 'tls #:close-original? #t)
and it should return two values: an input port and an export port.
All further SMTP communication uses the returned ports.
See the "head.ss" library for utilities that construct a message
headers and validate mail address strings.

65
collects/net/smtp-unit.ss
View File

@ -1,5 +1,5 @@
(module smtp-unit (lib "a-unit.ss")
(require (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(require (lib "list.ss") (lib "kw.ss") "base64.ss" "smtp-sig.ss")
(import)
(export smtp^)
@ -16,7 +16,7 @@
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(define (check-reply r v w)
(define (check-reply/accum r v w a)
(flush-output w)
(let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))])
(log "server: ~a\n" l)
@ -26,9 +26,24 @@
(unless (starts-with? l n)
(error 'check-reply "expected reply ~a; got: ~a" v l))
(let ([n- (string-append n "-")])
(when (starts-with? l n-)
;; Multi-line reply. Go again.
(check-reply r v w)))))))
(if (starts-with? l n-)
;; Multi-line reply. Go again.
(check-reply/accum r v w (if a (cons (substring l 4) a) #f))
;; We're finished, so add the last and reverse the result
(when a
(reverse (cons (substring l 4) a)))))))))
(define (check-reply/commands r v w . commands)
;; drop the first response, which is just the flavor text -- we expect the rest to
;; be a list of supported ESMTP commands.
(let ([cmdlist (rest (check-reply/accum r v w '()))])
(for-each (lambda (c1)
(unless (findf (lambda (c2) (string=? c1 c2)) cmdlist)
(error "expected advertisement of ESMTP command ~a" c1)))
commands)))
(define (check-reply r v w)
(check-reply/accum r v w #f))
(define (protect-line l)
;; If begins with a dot, add one more
@ -52,7 +67,7 @@
f)))
(define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd)
auth-user auth-passwd tls-encode)
(with-handlers ([void (lambda (x)
(close-input-port r)
(close-output-port w)
@ -60,6 +75,21 @@
(check-reply r 220 w)
(log "hello\n")
(fprintf w "EHLO ~a\r\n" (smtp-sending-server))
(when tls-encode
(check-reply/commands r 250 w "STARTTLS")
(log "starttls\n")
(fprintf w "STARTTLS\r\n")
(check-reply r 220 w)
(let-values ([(ssl-r ssl-w)
(tls-encode r w
#:mode 'connect
#:encrypt 'tls
#:close-original? #t)])
(set! r ssl-r)
(set! w ssl-w))
;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO.
(log "tls hello\n")
(fprintf w "EHLO ~a\r\n" (smtp-sending-server)))
(check-reply r 250 w)
(when auth-user
@ -100,9 +130,19 @@
(flush-output w)
(check-reply r 250 w)
(log "quit\n")
(fprintf w "QUIT\r\n")
(check-reply r 221 w)
;; Once a 250 has been received in response to the . at the end of
;; the DATA block, the email has been sent successfully and out of our
;; hands. This function should thus indicate success at this point
;; no matter what else happens.
;;
;; Some servers (like smtp.gmail.com) will just close the connection
;; on a QUIT, so instead of causing any QUIT errors to look like the
;; email failed, we'll just log them.
(with-handlers ([void (lambda (x)
(log "error after send: ~a\n" (exn-message x)))])
(log "quit\n")
(fprintf w "QUIT\r\n")
(check-reply r 221 w))
(close-output-port w)
(close-input-port r)))
@ -114,12 +154,13 @@
[auth-user #f]
[auth-passwd #f]
[tcp-connect tcp-connect]
[tls-encode #f]
#:body
(#:optional [opt-port-no port-no]))
(when (null? recipients)
(error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))])
(values (current-input-port) (current-output-port))
(tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd)))))
auth-user auth-passwd tls-encode)))))