Add support for AUTH PLAIN to smtp library
Update documentation The smtp.server used for testing now starts on a random port instead of hard-coding 4321db4
Slava Pestov
parent
6b0a477d3d
commit
dce74a6915
|
|
@ -2,12 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel prettyprint io io.timeouts
|
||||
sequences namespaces io.sockets continuations calendar
|
||||
io.encodings.ascii io.streams.duplex destructors ;
|
||||
io.encodings.ascii io.streams.duplex destructors
|
||||
locals concurrency.promises threads accessors ;
|
||||
IN: smtp.server
|
||||
|
||||
! Mock SMTP server for testing purposes.
|
||||
|
||||
! Usage: 4321 mock-smtp-server
|
||||
! $ telnet 127.0.0.1 4321
|
||||
! Trying 127.0.0.1...
|
||||
! Connected to localhost.
|
||||
|
|
@ -62,13 +62,16 @@ SYMBOL: data-mode
|
|||
]
|
||||
} cond nip [ process ] when ;
|
||||
|
||||
: mock-smtp-server ( port -- )
|
||||
"Starting SMTP server on port " write dup . flush
|
||||
"127.0.0.1" swap <inet4> ascii <server> [
|
||||
accept drop [
|
||||
1 minutes timeouts
|
||||
"220 hello\r\n" write flush
|
||||
process
|
||||
global [ flush ] bind
|
||||
] with-stream
|
||||
] with-disposal ;
|
||||
:: mock-smtp-server ( promise -- )
|
||||
#! Store the port we are running on in the promise.
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> ascii <server> [
|
||||
dup addr>> port>> promise fulfill
|
||||
accept drop [
|
||||
1 minutes timeouts
|
||||
"220 hello\r\n" write flush
|
||||
process
|
||||
global [ flush ] bind
|
||||
] with-stream
|
||||
] with-disposal
|
||||
] in-thread ;
|
||||
|
|
|
|||
|
|
@ -5,20 +5,49 @@ io.sockets strings calendar ;
|
|||
IN: smtp
|
||||
|
||||
HELP: smtp-domain
|
||||
{ $description "The name of the machine that is sending the email. This variable will be filled in by the " { $link host-name } " word if not set by the user." } ;
|
||||
{ $var-description "The name of the machine that is sending the email. This variable will be filled in by the " { $link host-name } " word if not set by the user." } ;
|
||||
|
||||
HELP: smtp-server
|
||||
{ $description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
|
||||
{ $var-description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
|
||||
|
||||
HELP: smtp-read-timeout
|
||||
{ $description "Holds an " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
|
||||
{ $var-description "Holds a " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
|
||||
|
||||
HELP: esmtp?
|
||||
{ $description "Set true by default, determines whether the SMTP client is using the Extended SMTP protocol." } ;
|
||||
HELP: smtp-auth
|
||||
{ $var-description "Holds either " { $link no-auth } " or an instance of " { $link plain-auth } ", specifying how to authenticate with the SMTP server. Set to " { $link no-auth } " by default." } ;
|
||||
|
||||
HELP: no-auth
|
||||
{ $class-description "If the " { $link smtp-auth } " variable is set to this value, no authentication will be performed." } ;
|
||||
|
||||
HELP: plain-auth
|
||||
{ $class-description "If the " { $link smtp-auth } " variable is set to this value, plain authentication will be performed, with the username and password stored in the " { $slot "username" } " and " { $slot "password" } " slots of the tuple sent to the server as plain-text." } ;
|
||||
|
||||
HELP: <plain-auth> ( username password -- plain-auth )
|
||||
{ $values { "username" string } { "password" string } { "plain-auth" plain-auth } }
|
||||
{ $description "Creates a new " { $link plain-auth } " instance." } ;
|
||||
|
||||
HELP: with-smtp-connection
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." } ;
|
||||
{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." }
|
||||
{ $notes "This word is used to implement " { $link send-email } " and there is probably no reason to call it directly." } ;
|
||||
|
||||
HELP: email
|
||||
{ $class-description "An e-mail. E-mails have the following slots:"
|
||||
{ $table
|
||||
{ { $slot "from" } "The sender of the e-mail. An e-mail address." }
|
||||
{ { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." }
|
||||
{ { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
|
||||
{ { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
|
||||
{ { $slot "subject" } " The subject of the e-mail. A string." }
|
||||
{ { $slot "body" } " The body of the e-mail. A string." }
|
||||
}
|
||||
"The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."
|
||||
$nl
|
||||
"An e-mail address is a string in one of the following two formats:"
|
||||
{ $list
|
||||
{ $snippet "joe@groff.com" }
|
||||
{ $snippet "Joe Groff <joe@groff.com>" }
|
||||
} } ;
|
||||
|
||||
HELP: <email>
|
||||
{ $values { "email" email } }
|
||||
|
|
@ -26,9 +55,9 @@ HELP: <email>
|
|||
|
||||
HELP: send-email
|
||||
{ $values { "email" email } }
|
||||
{ $description "Sends an " { $link email } " object to an STMP server stored in the " { $link smtp-server } " variable. The required slots are " { $slot "from" } " and " { $slot "to" } "." }
|
||||
{ $description "Sends an e-mail." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: accessors smtp ;"
|
||||
{ $code "USING: accessors smtp ;"
|
||||
"<email>"
|
||||
" \"groucho@marx.bros\" >>from"
|
||||
" { \"chico@marx.bros\" \"harpo@marx.bros\" } >>to"
|
||||
|
|
@ -42,10 +71,20 @@ HELP: send-email
|
|||
} ;
|
||||
|
||||
ARTICLE: "smtp" "SMTP client library"
|
||||
"Configuring SMTP:"
|
||||
"The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server."
|
||||
$nl
|
||||
"This library is configured by a set of dynamically-scoped variables:"
|
||||
{ $subsection smtp-server }
|
||||
{ $subsection smtp-read-timeout }
|
||||
{ $subsection smtp-domain }
|
||||
{ $subsection esmtp? }
|
||||
{ $subsection smtp-auth }
|
||||
"The latter is set to an instance of one of the following:"
|
||||
{ $subsection no-auth }
|
||||
{ $subsection plain-auth }
|
||||
"Constructing an e-mail:"
|
||||
{ $subsection email }
|
||||
{ $subsection <email> }
|
||||
"Sending an email:"
|
||||
{ $subsection send-email } ;
|
||||
|
||||
ABOUT: "smtp"
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
USING: smtp tools.test io.streams.string io.sockets threads
|
||||
smtp.server kernel sequences namespaces logging accessors
|
||||
assocs sorting smtp.private ;
|
||||
assocs sorting smtp.private concurrency.promises ;
|
||||
IN: smtp.tests
|
||||
|
||||
\ send-email must-infer
|
||||
|
||||
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
|
||||
|
||||
[ "hello\nworld" validate-address ] must-fail
|
||||
|
|
@ -63,13 +65,13 @@ IN: smtp.tests
|
|||
[ from>> extract-email ] tri
|
||||
] unit-test
|
||||
|
||||
[ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test
|
||||
<promise> "p" set
|
||||
|
||||
[ ] [ yield ] unit-test
|
||||
[ ] [ "p" get mock-smtp-server ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"localhost" 4321 <inet> smtp-server set
|
||||
"localhost" "p" get ?promise <inet> smtp-server set
|
||||
|
||||
<email>
|
||||
"Hi guys\nBye guys" >>body
|
||||
|
|
@ -82,5 +84,3 @@ IN: smtp.tests
|
|||
send-email
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[ ] [ yield ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,16 +1,28 @@
|
|||
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
|
||||
! Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays namespaces make io io.timeouts kernel logging
|
||||
io.sockets sequences combinators splitting assocs strings
|
||||
math.parser random system calendar io.encodings.ascii summary
|
||||
calendar.format accessors sets hashtables ;
|
||||
USING: arrays namespaces make io io.encodings.string
|
||||
io.encodings.utf8 io.timeouts kernel logging io.sockets
|
||||
sequences combinators splitting assocs strings math.parser
|
||||
random system calendar io.encodings.ascii summary
|
||||
calendar.format accessors sets hashtables base64 ;
|
||||
IN: smtp
|
||||
|
||||
SYMBOL: smtp-domain
|
||||
SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
|
||||
SYMBOL: smtp-read-timeout 1 minutes smtp-read-timeout set-global
|
||||
SYMBOL: esmtp? t esmtp? set-global
|
||||
|
||||
SYMBOL: smtp-server
|
||||
"localhost" 25 <inet> smtp-server set-global
|
||||
|
||||
SYMBOL: smtp-read-timeout
|
||||
1 minutes smtp-read-timeout set-global
|
||||
|
||||
SINGLETON: no-auth
|
||||
|
||||
TUPLE: plain-auth username password ;
|
||||
C: <plain-auth> plain-auth
|
||||
|
||||
SYMBOL: smtp-auth
|
||||
no-auth smtp-auth set-global
|
||||
|
||||
LOG: log-smtp-connection NOTICE ( addrspec -- )
|
||||
|
||||
|
|
@ -34,12 +46,12 @@ TUPLE: email
|
|||
: <email> ( -- email ) email new ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: crlf ( -- ) "\r\n" write ;
|
||||
|
||||
: command ( string -- ) write crlf flush ;
|
||||
|
||||
: helo ( -- )
|
||||
esmtp? get "EHLO " "HELO " ? host-name append command ;
|
||||
: helo ( -- ) "EHLO " host-name append command ;
|
||||
|
||||
ERROR: bad-email-address email ;
|
||||
|
||||
|
|
@ -60,8 +72,7 @@ ERROR: bad-email-address email ;
|
|||
ERROR: message-contains-dot message ;
|
||||
|
||||
M: message-contains-dot summary ( obj -- string )
|
||||
drop
|
||||
"Message cannot contain . on a line by itself" ;
|
||||
drop "Message cannot contain . on a line by itself" ;
|
||||
|
||||
: validate-message ( msg -- msg' )
|
||||
"." over member?
|
||||
|
|
@ -115,7 +126,7 @@ ERROR: smtp-transaction-failed < smtp-error ;
|
|||
3 swap ?nth CHAR: - = ;
|
||||
|
||||
: process-multiline ( multiline -- response )
|
||||
>r readln r> 2dup " " append head? [
|
||||
[ readln ] dip 2dup " " append head? [
|
||||
drop dup smtp-response
|
||||
] [
|
||||
swap check-response process-multiline
|
||||
|
|
@ -127,6 +138,16 @@ ERROR: smtp-transaction-failed < smtp-error ;
|
|||
|
||||
: get-ok ( -- ) receive-response check-response ;
|
||||
|
||||
GENERIC: send-auth ( auth -- )
|
||||
|
||||
M: no-auth send-auth drop ;
|
||||
|
||||
M: plain-auth send-auth
|
||||
[ username>> ] [ password>> ] bi "\0" swap 3append utf8 encode >base64
|
||||
"AUTH PLAIN " prepend command ;
|
||||
|
||||
: auth ( -- ) smtp-auth get send-auth get-ok ;
|
||||
|
||||
ERROR: invalid-header-string string ;
|
||||
|
||||
: validate-header ( string -- string' )
|
||||
|
|
@ -170,6 +191,7 @@ ERROR: invalid-header-string string ;
|
|||
: (send-email) ( headers email -- )
|
||||
[
|
||||
helo get-ok
|
||||
auth
|
||||
dup from>> extract-email mail-from get-ok
|
||||
dup to>> [ extract-email rcpt-to get-ok ] each
|
||||
dup cc>> [ extract-email rcpt-to get-ok ] each
|
||||
|
|
@ -180,6 +202,7 @@ ERROR: invalid-header-string string ;
|
|||
body>> send-body get-ok
|
||||
quit get-ok
|
||||
] with-smtp-connection ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: send-email ( email -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue