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 (module smtp-unit mzscheme
(require (lib "unitsig.ss")) (require (lib "unitsig.ss")
(lib "kw.ss")
"base64.ss")
(require "smtp-sig.ss") (require "smtp-sig.ss")
@ -60,7 +62,8 @@
(raise-type-error 'smtp-sending-end-of-message "thunk" f)) (raise-type-error 'smtp-sending-end-of-message "thunk" f))
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) (with-handlers ([void (lambda (x)
(close-input-port r) (close-input-port r)
(close-output-port w) (close-output-port w)
@ -70,6 +73,15 @@
(fprintf w "EHLO ~a~a" ID crlf) (fprintf w "EHLO ~a~a" ID crlf)
(check-reply r 250 w) (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") (log "from~n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf) (fprintf w "MAIL FROM:<~a>~a" sender crlf)
(check-reply r 250 w) (check-reply r 250 w)
@ -107,13 +119,18 @@
(close-input-port r))) (close-input-port r)))
(define smtp-send-message (define smtp-send-message
(case-lambda (lambda/kw (server sender recipients header message-lines
[(server sender recipients header message-lines) #:key
(smtp-send-message server sender recipients header message-lines 25)] [port-no 25]
[(server sender recipients header message-lines pos) [auth-user #f]
[auth-passwd #f]
[tcp-connect tcp-connect]
#:body
(#:optional [opt-port-no port-no]))
(when (null? recipients) (when (null? recipients)
(error 'send-smtp-message "no receivers")) (error 'send-smtp-message "no receivers"))
(let-values ([(r w) (if debug-via-stdio? (let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port)) (values (current-input-port) (current-output-port))
(tcp-connect server pos))]) (tcp-connect server opt-port-no))])
(smtp-send-message* r w sender recipients header message-lines))]))))) (smtp-send-message* r w sender recipients header message-lines
auth-user auth-passwd)))))))