steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-11-30 13:53:13 -06:00
parent 4b62fb68f1
commit 14377c6e36
4 changed files with 126 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
basis/smtp/server/server.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2007 Elie CHAFTARI ! Copyright (C) 2007 Elie CHAFTARI
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel prettyprint io io.timeouts USING: combinators kernel prettyprint io io.timeouts sequences
sequences namespaces io.sockets continuations calendar namespaces io.sockets io.sockets.secure continuations calendar
io.encodings.ascii io.streams.duplex destructors io.encodings.ascii io.streams.duplex destructors locals
locals concurrency.promises threads accessors ; concurrency.promises threads accessors smtp.private
io.unix.sockets.secure.debug ;
IN: smtp.server IN: smtp.server
! Mock SMTP server for testing purposes. ! Mock SMTP server for testing purposes.
@ -34,36 +35,43 @@ IN: smtp.server
SYMBOL: data-mode SYMBOL: data-mode
: process ( -- ) : process ( -- )
readln { read-crlf {
{ [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ {
"220 and..?\r\n" write flush t [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
] } [ "220 and..?\r\n" write flush t ]
{ [ dup "QUIT" = ] [ }
"bye\r\n" write flush f {
] } [ dup "STARTTLS" = ]
{ [ dup "MAIL FROM:" head? ] [ [
"220 OK\r\n" write flush t "220 2.0.0 Ready to start TLS\r\n" write flush
] } accept-secure-handshake t
{ [ dup "RCPT TO:" head? ] [ ]
"220 OK\r\n" write flush t }
] } { [ dup "QUIT" = ] [ "220 bye\r\n" write flush f ] }
{ [ dup "DATA" = ] [ { [ 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 data-mode on
"354 Enter message, ending with \".\" on a line by itself\r\n" "354 Enter message, ending with \".\" on a line by itself\r\n"
write flush t write flush t
] } ]
{ [ dup "." = data-mode get and ] [ }
{
[ dup "." = data-mode get and ]
[
data-mode off data-mode off
"220 OK\r\n" write flush t "220 OK\r\n" write flush t
] }
{ [ data-mode get ] [ dup global [ print ] bind t ] }
[
"500 ERROR\r\n" write flush t
] ]
}
{ [ data-mode get ] [ dup global [ print ] bind t ] }
[ "500 ERROR\r\n" write flush t ]
} cond nip [ process ] when ; } cond nip [ process ] when ;
:: mock-smtp-server ( promise -- ) :: mock-smtp-server ( promise -- )
#! Store the port we are running on in the promise. #! Store the port we are running on in the promise.
[
[ [
"127.0.0.1" 0 <inet4> ascii <server> [ "127.0.0.1" 0 <inet4> ascii <server> [
dup addr>> port>> promise fulfill dup addr>> port>> promise fulfill
@ -74,4 +82,5 @@ SYMBOL: data-mode
global [ flush ] bind global [ flush ] bind
] with-stream ] with-stream
] with-disposal ] with-disposal
] with-test-context
] in-thread ; ] in-thread ;

4
basis/smtp/smtp-docs.factor
View File

@ -10,6 +10,9 @@ HELP: smtp-domain
HELP: smtp-server HELP: smtp-server
{ $var-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-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 HELP: smtp-read-timeout
{ $var-description "Holds a " { $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." } ;
@ -75,6 +78,7 @@ ARTICLE: "smtp" "SMTP client library"
$nl $nl
"This library is configured by a set of dynamically-scoped variables:" "This library is configured by a set of dynamically-scoped variables:"
{ $subsection smtp-server } { $subsection smtp-server }
{ $subsection smtp-tls? }
{ $subsection smtp-read-timeout } { $subsection smtp-read-timeout }
{ $subsection smtp-domain } { $subsection smtp-domain }
{ $subsection smtp-auth } { $subsection smtp-auth }

17
basis/smtp/smtp-tests.factor
View File

@ -18,15 +18,22 @@ IN: smtp.tests
"hello\nworld" [ send-body ] with-string-writer "hello\nworld" [ send-body ] with-string-writer
] unit-test ] 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 "220 success" [ receive-response ] with-string-reader
] unit-test ] 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" "220-a multiline response\r\n250-another line\r\n220 the end"
[ receive-response ] with-string-reader [ receive-response ] with-string-reader
] unit-test ] unit-test
@ -72,6 +79,8 @@ IN: smtp.tests
[ ] [ [ ] [
[ [
"localhost" "p" get ?promise <inet> smtp-server set "localhost" "p" get ?promise <inet> smtp-server set
no-auth smtp-auth set
smtp-tls? on
<email> <email>
"Hi guys\nBye guys" >>body "Hi guys\nBye guys" >>body

105
basis/smtp/smtp.factor
View File

@ -2,10 +2,11 @@
! Slava Pestov, Doug Coleman. ! Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces make io io.encodings.string USING: arrays namespaces make io io.encodings.string
io.encodings.utf8 io.timeouts kernel logging io.sockets io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
sequences combinators splitting assocs strings math.parser io.encodings.ascii kernel logging sequences combinators
random system calendar io.encodings.ascii summary splitting assocs strings math.order math.parser random system
calendar.format accessors sets hashtables base64 ; calendar summary calendar.format accessors sets hashtables
base64 debugger classes prettyprint ;
IN: smtp IN: smtp
SYMBOL: smtp-domain SYMBOL: smtp-domain
@ -13,6 +14,8 @@ SYMBOL: smtp-domain
SYMBOL: smtp-server SYMBOL: smtp-server
"localhost" 25 <inet> smtp-server set-global "localhost" 25 <inet> smtp-server set-global
SYMBOL: smtp-tls?
SYMBOL: smtp-read-timeout SYMBOL: smtp-read-timeout
1 minutes smtp-read-timeout set-global 1 minutes smtp-read-timeout set-global
@ -43,16 +46,24 @@ TUPLE: email
{ subject string } { subject string }
{ body string } ; { body string } ;
: <email> ( -- email ) email new ; : <email> ( -- email ) email new ; inline
<PRIVATE <PRIVATE
: crlf ( -- ) "\r\n" write ; : crlf ( -- ) "\r\n" write ;
: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: command ( string -- ) write crlf flush ; : command ( string -- ) write crlf flush ;
\ command DEBUG add-input-logging
: helo ( -- ) "EHLO " host-name append command ; : helo ( -- ) "EHLO " host-name append command ;
: start-tls ( -- ) "STARTTLS" command ;
ERROR: bad-email-address email ; ERROR: bad-email-address email ;
: validate-address ( string -- string' ) : validate-address ( string -- string' )
@ -89,7 +100,30 @@ M: message-contains-dot summary ( obj -- string )
LOG: smtp-response DEBUG 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-server-busy < smtp-error ;
ERROR: smtp-syntax-error < smtp-error ; ERROR: smtp-syntax-error < smtp-error ;
ERROR: smtp-command-not-implemented < 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 ; ERROR: smtp-transaction-failed < smtp-error ;
: check-response ( response -- ) : check-response ( response -- )
dup smtp-response dup code>> {
{ { [ dup { 220 235 250 221 354 } member? ] [ 2drop ] }
{ [ dup "bye" head? ] [ drop ] } { [ dup 400 499 between? ] [ drop smtp-server-busy ] }
{ [ dup "220" head? ] [ drop ] } { [ dup 500 = ] [ drop smtp-syntax-error ] }
{ [ dup "235" swap subseq? ] [ drop ] } { [ dup 501 = ] [ drop smtp-command-not-implemented ] }
{ [ dup "250" head? ] [ drop ] } { [ dup 500 509 between? ] [ drop smtp-syntax-error ] }
{ [ dup "221" head? ] [ drop ] } { [ dup 530 539 between? ] [ drop smtp-bad-authentication ] }
{ [ dup "354" head? ] [ drop ] } { [ dup 550 = ] [ drop smtp-mailbox-unavailable ] }
{ [ dup "4" head? ] [ smtp-server-busy ] } { [ dup 551 = ] [ drop smtp-user-not-local ] }
{ [ dup "500" head? ] [ smtp-syntax-error ] } { [ dup 552 = ] [ drop smtp-exceeded-storage-allocation ] }
{ [ dup "501" head? ] [ smtp-command-not-implemented ] } { [ dup 553 = ] [ drop smtp-bad-mailbox-name ] }
{ [ dup "50" head? ] [ smtp-syntax-error ] } { [ dup 554 = ] [ drop smtp-transaction-failed ] }
{ [ dup "53" head? ] [ smtp-bad-authentication ] } [ drop smtp-error ]
{ [ 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 ]
} cond ; } 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 ; : get-ok ( -- ) receive-response check-response ;
GENERIC: send-auth ( auth -- ) GENERIC: send-auth ( auth -- )
M: no-auth send-auth drop ; M: no-auth send-auth drop ;
M: plain-auth send-auth : plain-auth-string ( username password -- string )
[ username>> ] [ password>> ] bi "\0" swap 3append utf8 encode >base64 [ "\0" prepend ] bi@ append utf8 encode >base64 ;
"AUTH PLAIN " prepend command ;
: 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 ; ERROR: invalid-header-string string ;
@ -190,7 +207,9 @@ ERROR: invalid-header-string string ;
: (send-email) ( headers email -- ) : (send-email) ( headers email -- )
[ [
get-ok
helo get-ok helo get-ok
smtp-tls? get [ start-tls get-ok send-secure-handshake ] when
auth auth
dup from>> extract-email mail-from get-ok dup from>> extract-email mail-from get-ok
dup to>> [ extract-email rcpt-to get-ok ] each dup to>> [ extract-email rcpt-to get-ok ] each