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

authenticated SMTP

Browse Source 
svn: r2136

original commit: 0c7aff3441985920fe951eb766f140bddf62090e
This commit is contained in:
Matthew Flatt 2006-02-06 14:03:28 +00:00
parent 97a0a32a33
commit 7f7f4868ed
1 changed files with 25 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,8 @@
(module smtp-unit mzscheme
(require (lib "unitsig.ss"))
(require (lib "unitsig.ss")
(lib "kw.ss")
"base64.ss")
(require "smtp-sig.ss")
@ -60,7 +62,8 @@
(raise-type-error 'smtp-sending-end-of-message "thunk" f))
f)))
(define (smtp-send-message* r w sender recipients header message-lines)
(define (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd)
(with-handlers ([void (lambda (x)
(close-input-port r)
(close-output-port w)
@ -70,6 +73,15 @@
(fprintf w "EHLO ~a~a" ID crlf)
(check-reply r 250 w)
(when auth-user
(log "auth~n")
(fprintf w "AUTH PLAIN ~a"
;; Encoding adds CRLF
(base64-encode
(string->bytes/latin-1
(format "~a\0~a\0~a" auth-user auth-user auth-passwd))))
(check-reply r 235 w))
(log "from~n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
(check-reply r 250 w)
@ -107,13 +119,18 @@
(close-input-port r)))
(define smtp-send-message
(case-lambda
[(server sender recipients header message-lines)
(smtp-send-message server sender recipients header message-lines 25)]
[(server sender recipients header message-lines pos)
(lambda/kw (server sender recipients header message-lines
#:key
[port-no 25]
[auth-user #f]
[auth-passwd #f]
[tcp-connect tcp-connect]
#: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 pos))])
(smtp-send-message* r w sender recipients header message-lines))])))))
(tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd)))))))