Fix AUTH PLAIN support,and add STARTTLS support; clean up response handling code a bit, to make better error messages; fix a bug where the first line initially sent by the server was not being read
Slava Pestov
parent
4b62fb68f1
commit
14377c6e36
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2007 Elie CHAFTARI
|
||||
! 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
|
||||
locals concurrency.promises threads accessors ;
|
||||
USING: combinators kernel prettyprint io io.timeouts sequences
|
||||
namespaces io.sockets io.sockets.secure continuations calendar
|
||||
io.encodings.ascii io.streams.duplex destructors locals
|
||||
concurrency.promises threads accessors smtp.private
|
||||
io.unix.sockets.secure.debug ;
|
||||
IN: smtp.server
|
||||
|
||||
! Mock SMTP server for testing purposes.
|
||||
|
|
@ -34,44 +35,52 @@ IN: smtp.server
|
|||
SYMBOL: data-mode
|
||||
|
||||
: process ( -- )
|
||||
readln {
|
||||
{ [ [ dup "HELO" head? ] keep "EHLO" head? or ] [
|
||||
"220 and..?\r\n" write flush t
|
||||
] }
|
||||
{ [ dup "QUIT" = ] [
|
||||
"bye\r\n" write flush f
|
||||
] }
|
||||
{ [ dup "MAIL FROM:" head? ] [
|
||||
"220 OK\r\n" write flush t
|
||||
] }
|
||||
{ [ dup "RCPT TO:" head? ] [
|
||||
"220 OK\r\n" write flush t
|
||||
] }
|
||||
{ [ dup "DATA" = ] [
|
||||
data-mode on
|
||||
"354 Enter message, ending with \".\" on a line by itself\r\n"
|
||||
write flush t
|
||||
] }
|
||||
{ [ dup "." = data-mode get and ] [
|
||||
data-mode off
|
||||
"220 OK\r\n" write flush t
|
||||
] }
|
||||
read-crlf {
|
||||
{
|
||||
[ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
|
||||
[ "220 and..?\r\n" write flush t ]
|
||||
}
|
||||
{
|
||||
[ dup "STARTTLS" = ]
|
||||
[
|
||||
"220 2.0.0 Ready to start TLS\r\n" write flush
|
||||
accept-secure-handshake t
|
||||
]
|
||||
}
|
||||
{ [ dup "QUIT" = ] [ "220 bye\r\n" write flush f ] }
|
||||
{ [ dup "MAIL FROM:" head? ] [ "220 OK\r\n" write flush t ] }
|
||||
{ [ dup "RCPT TO:" head? ] [ "220 OK\r\n" write flush t ] }
|
||||
{
|
||||
[ dup "DATA" = ]
|
||||
[
|
||||
data-mode on
|
||||
"354 Enter message, ending with \".\" on a line by itself\r\n"
|
||||
write flush t
|
||||
]
|
||||
}
|
||||
{
|
||||
[ dup "." = data-mode get and ]
|
||||
[
|
||||
data-mode off
|
||||
"220 OK\r\n" write flush t
|
||||
]
|
||||
}
|
||||
{ [ data-mode get ] [ dup global [ print ] bind t ] }
|
||||
[
|
||||
"500 ERROR\r\n" write flush t
|
||||
]
|
||||
[ "500 ERROR\r\n" write flush t ]
|
||||
} cond nip [ process ] when ;
|
||||
|
||||
:: 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
|
||||
[
|
||||
"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
|
||||
] with-test-context
|
||||
] in-thread ;
|
||||
|
|
|
|||
|
|
@ -10,6 +10,9 @@ HELP: smtp-domain
|
|||
HELP: smtp-server
|
||||
{ $var-description "Holds an " { $link inet } " object with the address of an SMTP server." } ;
|
||||
|
||||
HELP: smtp-tls?
|
||||
{ $var-description "If set to true, secure socket communication will be established after connecting to the SMTP server. The server must support the " { $snippet "STARTTLS" } " command. Off by default." } ;
|
||||
|
||||
HELP: smtp-read-timeout
|
||||
{ $var-description "Holds a " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ;
|
||||
|
||||
|
|
@ -75,6 +78,7 @@ ARTICLE: "smtp" "SMTP client library"
|
|||
$nl
|
||||
"This library is configured by a set of dynamically-scoped variables:"
|
||||
{ $subsection smtp-server }
|
||||
{ $subsection smtp-tls? }
|
||||
{ $subsection smtp-read-timeout }
|
||||
{ $subsection smtp-domain }
|
||||
{ $subsection smtp-auth }
|
||||
|
|
|
|||
|
|
@ -18,15 +18,22 @@ IN: smtp.tests
|
|||
"hello\nworld" [ send-body ] with-string-writer
|
||||
] unit-test
|
||||
|
||||
[ "500 syntax error" check-response ] must-fail
|
||||
[ { "500 syntax error" } <response> check-response ]
|
||||
[ smtp-error? ] must-fail-with
|
||||
|
||||
[ ] [ "220 success" check-response ] unit-test
|
||||
[ ] [ { "220 success" } <response> check-response ] unit-test
|
||||
|
||||
[ "220 success" ] [
|
||||
[ T{ response f 220 { "220 success" } } ] [
|
||||
"220 success" [ receive-response ] with-string-reader
|
||||
] unit-test
|
||||
|
||||
[ "220 the end" ] [
|
||||
[
|
||||
T{ response f 220 {
|
||||
"220-a multiline response"
|
||||
"250-another line"
|
||||
"220 the end"
|
||||
} }
|
||||
] [
|
||||
"220-a multiline response\r\n250-another line\r\n220 the end"
|
||||
[ receive-response ] with-string-reader
|
||||
] unit-test
|
||||
|
|
@ -72,6 +79,8 @@ IN: smtp.tests
|
|||
[ ] [
|
||||
[
|
||||
"localhost" "p" get ?promise <inet> smtp-server set
|
||||
no-auth smtp-auth set
|
||||
smtp-tls? on
|
||||
|
||||
<email>
|
||||
"Hi guys\nBye guys" >>body
|
||||
|
|
|
|||
|
|
@ -2,10 +2,11 @@
|
|||
! Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
|
||||
io.encodings.ascii kernel logging sequences combinators
|
||||
splitting assocs strings math.order math.parser random system
|
||||
calendar summary calendar.format accessors sets hashtables
|
||||
base64 debugger classes prettyprint ;
|
||||
IN: smtp
|
||||
|
||||
SYMBOL: smtp-domain
|
||||
|
|
@ -13,6 +14,8 @@ SYMBOL: smtp-domain
|
|||
SYMBOL: smtp-server
|
||||
"localhost" 25 <inet> smtp-server set-global
|
||||
|
||||
SYMBOL: smtp-tls?
|
||||
|
||||
SYMBOL: smtp-read-timeout
|
||||
1 minutes smtp-read-timeout set-global
|
||||
|
||||
|
|
@ -43,16 +46,24 @@ TUPLE: email
|
|||
{ subject string }
|
||||
{ body string } ;
|
||||
|
||||
: <email> ( -- email ) email new ;
|
||||
: <email> ( -- email ) email new ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: crlf ( -- ) "\r\n" write ;
|
||||
|
||||
: read-crlf ( -- bytes )
|
||||
"\r" read-until
|
||||
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
|
||||
|
||||
: command ( string -- ) write crlf flush ;
|
||||
|
||||
\ command DEBUG add-input-logging
|
||||
|
||||
: helo ( -- ) "EHLO " host-name append command ;
|
||||
|
||||
: start-tls ( -- ) "STARTTLS" command ;
|
||||
|
||||
ERROR: bad-email-address email ;
|
||||
|
||||
: validate-address ( string -- string' )
|
||||
|
|
@ -89,7 +100,30 @@ M: message-contains-dot summary ( obj -- string )
|
|||
|
||||
LOG: smtp-response DEBUG
|
||||
|
||||
ERROR: smtp-error message ;
|
||||
: multiline? ( response -- boolean )
|
||||
3 swap ?nth CHAR: - = ;
|
||||
|
||||
: (receive-response) ( -- )
|
||||
read-crlf
|
||||
[ , ]
|
||||
[ smtp-response ]
|
||||
[ multiline? [ (receive-response) ] when ]
|
||||
tri ;
|
||||
|
||||
TUPLE: response code messages ;
|
||||
|
||||
: <response> ( lines -- response )
|
||||
[ first 3 head string>number ] keep response boa ;
|
||||
|
||||
: receive-response ( -- response )
|
||||
[ (receive-response) ] { } make <response> ;
|
||||
|
||||
ERROR: smtp-error response ;
|
||||
|
||||
M: smtp-error error.
|
||||
"SMTP error (" write dup class pprint ")" print
|
||||
response>> messages>> [ print ] each ;
|
||||
|
||||
ERROR: smtp-server-busy < smtp-error ;
|
||||
ERROR: smtp-syntax-error < smtp-error ;
|
||||
ERROR: smtp-command-not-implemented < smtp-error ;
|
||||
|
|
@ -101,52 +135,35 @@ ERROR: smtp-bad-mailbox-name < smtp-error ;
|
|||
ERROR: smtp-transaction-failed < smtp-error ;
|
||||
|
||||
: check-response ( response -- )
|
||||
dup smtp-response
|
||||
{
|
||||
{ [ dup "bye" head? ] [ drop ] }
|
||||
{ [ dup "220" head? ] [ drop ] }
|
||||
{ [ dup "235" swap subseq? ] [ drop ] }
|
||||
{ [ dup "250" head? ] [ drop ] }
|
||||
{ [ dup "221" head? ] [ drop ] }
|
||||
{ [ dup "354" head? ] [ drop ] }
|
||||
{ [ dup "4" head? ] [ smtp-server-busy ] }
|
||||
{ [ dup "500" head? ] [ smtp-syntax-error ] }
|
||||
{ [ dup "501" head? ] [ smtp-command-not-implemented ] }
|
||||
{ [ dup "50" head? ] [ smtp-syntax-error ] }
|
||||
{ [ dup "53" head? ] [ smtp-bad-authentication ] }
|
||||
{ [ dup "550" head? ] [ smtp-mailbox-unavailable ] }
|
||||
{ [ dup "551" head? ] [ smtp-user-not-local ] }
|
||||
{ [ dup "552" head? ] [ smtp-exceeded-storage-allocation ] }
|
||||
{ [ dup "553" head? ] [ smtp-bad-mailbox-name ] }
|
||||
{ [ dup "554" head? ] [ smtp-transaction-failed ] }
|
||||
[ smtp-error ]
|
||||
dup code>> {
|
||||
{ [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
|
||||
{ [ dup 400 499 between? ] [ drop smtp-server-busy ] }
|
||||
{ [ dup 500 = ] [ drop smtp-syntax-error ] }
|
||||
{ [ dup 501 = ] [ drop smtp-command-not-implemented ] }
|
||||
{ [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
|
||||
{ [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
|
||||
{ [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
|
||||
{ [ dup 551 = ] [ drop smtp-user-not-local ] }
|
||||
{ [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
|
||||
{ [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
|
||||
{ [ dup 554 = ] [ drop smtp-transaction-failed ] }
|
||||
[ drop smtp-error ]
|
||||
} cond ;
|
||||
|
||||
: multiline? ( response -- boolean )
|
||||
3 swap ?nth CHAR: - = ;
|
||||
|
||||
: process-multiline ( multiline -- response )
|
||||
[ readln ] dip 2dup " " append head? [
|
||||
drop dup smtp-response
|
||||
] [
|
||||
swap check-response process-multiline
|
||||
] if ;
|
||||
|
||||
: receive-response ( -- response )
|
||||
readln
|
||||
dup multiline? [ 3 head process-multiline ] when ;
|
||||
|
||||
: 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 ;
|
||||
: plain-auth-string ( username password -- string )
|
||||
[ "\0" prepend ] bi@ append utf8 encode >base64 ;
|
||||
|
||||
: auth ( -- ) smtp-auth get send-auth get-ok ;
|
||||
M: plain-auth send-auth
|
||||
[ username>> ] [ password>> ] bi plain-auth-string
|
||||
"AUTH PLAIN " prepend command get-ok ;
|
||||
|
||||
: auth ( -- ) smtp-auth get send-auth ;
|
||||
|
||||
ERROR: invalid-header-string string ;
|
||||
|
||||
|
|
@ -190,7 +207,9 @@ ERROR: invalid-header-string string ;
|
|||
|
||||
: (send-email) ( headers email -- )
|
||||
[
|
||||
get-ok
|
||||
helo get-ok
|
||||
smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
|
||||
auth
|
||||
dup from>> extract-email mail-from get-ok
|
||||
dup to>> [ extract-email rcpt-to get-ok ] each
|
||||
|
|
|
|||
Loading…
Reference in New Issue