! 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.
]
} 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 ;
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 } }
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"
} ;
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"
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
[ 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
send-email
] with-scope
] unit-test
-
-[ ] [ yield ] unit-test
! 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 -- )
: <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 ;
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?
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
: 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' )
: (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
body>> send-body get-ok
quit get-ok
] with-smtp-connection ;
+
PRIVATE>
: send-email ( email -- )
projects / factor.git / commitdiff