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

authenticated SMTP

Browse Source 
svn: r2136
This commit is contained in:
Matthew Flatt 2006-02-06 14:03:28 +00:00
parent 37a6e9df62
commit 0c7aff3441
9 changed files with 124 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/net/doc.txt
View File

@ -497,7 +497,12 @@ EXCEPTIONS -----------------------------------------------------------
PROCEDURES -----------------------------------------------------------
> (smtp-send-message server-string from-string to-list-of-strings header
message-list-of-strings/bytes [port]) -> void
message-list-of-strings/bytes
[#:port-no k]
[#:auth-user user-string-or-#f]
[#:auth-passwd pw-string-or-#f]
[#:tcp-connect proc]
[port-no]) -> void
The first argument is the IP address of the SMTP server. The
`from-string' argument specifies the mail address of the sender, and
@ -509,11 +514,24 @@ PROCEDURES -----------------------------------------------------------
message, where each string or byte string in the list corresponds to
a single line of message text; no string in
`message-list-of-strings' should contain a carriage return or
newline characters. The optional `port' argument specifies the IP
port to use in contacting the SMTP server; the default is 25.
newline characters.
See the head package for utilities that construct a message headers
and validate mail address strings.
The optional `port-no' argument --- which can be specified either
with the #:port-no keyword or, for backward compatibility, as an
extra argument after keywords --- specifies the IP port to use in
contacting the SMTP server; the default is 25.
The optional #:auth-user and #:auth-passwd keyword argument supply a
username and password for authenticated SMTP (using the AUTH PLAIN
protocol).
The optional #:tcp-connect keyword argument supplies a connection
procedure to be used in place of `tcp-connect'. For example, use
`ssl-connect' from `(lib "mzssl.ss" "openssl")' to connect to the
server via SSL.
See the "head.ss" library for utilities that construct a message
headers and validate mail address strings.
> (smtp-sending-end-of-message [proc])

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)))))))

10
collects/sirmail/doc.txt
View File

@ -54,11 +54,11 @@ Sending panel:
- Mail From: The user's email address.
- SMTP Server: The SMTP server's host name (outgoing mail). Use a
":<portno>" suffix on the host name to connect to port
<portno>. Supply multiple SMTP hosts by separating the addresses
with a comma; the "File" menu of mail-sending frame will let you
choose a specific server.
- SMTP Server: The SMTP server's host name (outgoing mail). General
syntax: [<type>:][<user>@]<host>[:<portno>] where <type> is "tcp"
(the default) or "ssl". Supply multiple SMTP hosts by separating
the addresses with a comma; the "File" menu of mail-sending frame
will let you choose a specific server.
- Default To Domain: If a destination address that isn't declared as
an alias doesn't include a domain name, SirMail automatically

13
collects/sirmail/optionr.ss
View File

@ -29,6 +29,19 @@
(values (cadr m) (string->number (caddr m)))
(values s default-port))))
(define (parse-server-name+user+type s default-port)
(let ([m (regexp-match #rx"^(ssl|tcp):.*:.*" s)])
(let-values ([(ssl? s) (if m
(values (string=? "ssl" (substring s 0 3))
(substring s 4))
(values #f s))])
(let ([m (regexp-match #rx"^(.*)@(.*)$" s)])
(let-values ([(user s) (if m
(values (cadr m) (caddr m))
(values #f s))])
(let-values ([(server port) (parse-server-name s default-port)])
(values ssl? user server port)))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Preferences ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

23
collects/sirmail/pref.ss
View File

@ -316,9 +316,21 @@
(<= 1 (string->number (caddr m)) 65535)
(is-host-address? (cadr m))))))
(define (is-host-address+port-list? s)
(define (is-host-address+port+user? s)
(or (is-host-address+port? s)
(let ([m (regexp-match "^(?:[-+a-zA-Z0-9_.]+)@(.*)$" s)])
(and m
(is-host-address+port? (cadr m))))))
(define (is-host-address+port+user+type? s)
(or (is-host-address+port+user? s)
(let ([m (regexp-match "^(?:ssl|tcp):(.*)$" s)])
(and m
(is-host-address+port+user? (cadr m))))))
(define (is-host-address+port+user+type-list? s)
(let ([l (regexp-split ", *" s)])
(andmap is-host-address+port? l)))
(andmap is-host-address+port+user+type? l)))
(define (check-address ok? who tl s port-ok? multi?)
(or (ok? s)
@ -352,8 +364,8 @@
(check-address is-host-address? who tl s #f #f))
(define (check-host-address/port who tl s)
(check-address is-host-address+port? who tl s #t #f))
(define (check-host-address/port/multi who tl s)
(check-address is-host-address+port-list? who tl s #t #t))
(define (check-host-address/port/user/type/multi who tl s)
(check-address is-host-address+port+user+type-list? who tl s #t #t))
;; check-biff-delay : (union #f string) (union #f parent) string -> boolean
;; checks to see if the string in the biff delay field makes
@ -472,7 +484,8 @@
(let ([p (instantiate vertical-panel% (parent))])
(make-text-field "Mail From" p 20 'sirmail:mail-from #f check-user-address (lambda (x) x) (lambda (x) x))
(make-text-field "SMTP Server" p 20 'sirmail:smtp-server #f check-host-address/port/multi (lambda (x) x) (lambda (x) x))
(make-text-field "SMTP Server" p 20 'sirmail:smtp-server #f check-host-address/port/user/type/multi
(lambda (x) x) (lambda (x) x))
(make-file/directory-button #t #f p
'sirmail:sent-directory

8
collects/sirmail/readr.ss
View File

@ -255,12 +255,8 @@
;; New connection
(begin
(let ([pw (or (get-PASSWORD)
(let ([p (get-text-from-user "Password"
(format "Password for ~a:" (USERNAME))
main-frame
""
'(password))])
(unless p (raise-user-error 'connect "connection cancelled"))
(let ([p (get-pw-from-user (USERNAME) main-frame)])
(unless p (raise-user-error 'connect "connection canceled"))
p))])
(let*-values ([(imap count new) (let-values ([(server port-no)
(parse-server-name (IMAP-SERVER)

32
collects/sirmail/sendr.ss
View File

@ -11,7 +11,8 @@
(require (lib "list.ss")
(lib "file.ss")
(lib "string.ss")
(lib "process.ss"))
(lib "process.ss")
(lib "mzssl.ss" "openssl"))
(require "sirmails.ss"
"pref.ss"
@ -25,6 +26,8 @@
(require (lib "hierlist-sig.ss" "hierlist"))
(define smtp-passwords (make-hash-table 'equal))
(provide send@)
(define send@
(unit/sig sirmail:send^
@ -410,12 +413,20 @@
w))
(define (send-msg)
(define-values (smtp-server-to-use smtp-port-to-use)
(parse-server-name (SMTP-SERVER) 25))
(define-values (smtp-ssl? smtp-auth-user smtp-server-to-use smtp-port-to-use)
(parse-server-name+user+type (SMTP-SERVER) 25))
(define smtp-auth-passwd (and smtp-auth-user
(or (hash-table-get smtp-passwords (cons smtp-auth-user smtp-server-to-use)
(lambda () #f))
(let ([p (get-pw-from-user smtp-auth-user mailer-frame)])
(unless p (raise-user-error 'send "send canceled"))
p))))
(send-message
(send message-editor get-text)
smtp-ssl?
smtp-server-to-use
smtp-port-to-use
smtp-auth-user smtp-auth-passwd
(map (lambda (i) (send i user-data))
(send enclosure-list get-items))
enable
@ -433,7 +444,10 @@
(if f
(send message-editor save-file f 'text)
(loop))))))
message-count))
message-count)
(when smtp-auth-passwd
(hash-table-put! smtp-passwords (cons smtp-auth-user smtp-server-to-use)
smtp-auth-passwd)))
;; enq-msg : -> void
;; enqueues a message for a later send
@ -592,7 +606,7 @@
(new-mailer p "" "" "" "" ""
(map (lambda (i) (send i user-data))
(send enclosure-list get-items))
0)
message-count)
(semaphore-post s)))
(semaphore-wait s)))]
[shortcut #\=])
@ -711,8 +725,9 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (send-message message-str
ssl?
smtp-server
smtp-port
smtp-port auth-user auth-pw
enclosures
enable
status-message-starting
@ -793,7 +808,10 @@
tos
new-header
body-lines
smtp-port))))
#:port-no smtp-port
#:tcp-connect (if ssl? ssl-connect tcp-connect)
#:auth-user auth-user
#:auth-passwd auth-pw))))
save-before-killing))
(status-done))
(message-box

5
collects/sirmail/sirmails.ss
View File

@ -37,6 +37,8 @@
confirm-box
get-pw-from-user
generalize-encoding
parse-encoded
encode-for-header))
@ -76,7 +78,8 @@
USE-EXTERNAL-COMPOSER?
parse-server-name))
parse-server-name
parse-server-name+user+type))
(provide sirmail:read^)
(define-signature sirmail:read^

9
collects/sirmail/utilr.ss
View File

@ -230,6 +230,15 @@
'yes
'no)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (get-pw-from-user username parent)
(get-text-from-user "Password"
(format "Password for ~a:" username)
parent
""
'(password)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Decoding `from' names ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;