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

Cleaned up SMTP implementation and added some features

db4
Slava Pestov 2008-02-07 01:03:27 -06:00
parent 6373e350ba
commit a06c536123
4 changed files with 310 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/smtp/authors.txt
View File

@ -1 +1,3 @@
Elie Chaftari Elie Chaftari
Dirk Vleugels
Slava Pestov

72
extra/smtp/server/server.factor Normal file
View File

@ -0,0 +1,72 @@
! Copyright (C) 2007 Elie CHAFTARI
! See http://factorcode.org/license.txt for BSD license.
! Mock SMTP server for testing purposes.
! Usage: 4321 smtp-server
! $ telnet 127.0.0.1 4321
! Trying 127.0.0.1...
! Connected to localhost.
! Escape character is '^]'.
! 220 hello
! EHLO
! 220 and..?
! MAIL FROM: <here@mail.com>
! 220 OK
! RCPT TO: <there@mail.com>
! 220 OK
! Hi
! 500 ERROR
! DATA
! 354 Enter message, ending with "." on a line by itself
! Hello I am still waiting for your call
! Thanks
! .
! 220 OK
! QUIT
! bye
! Connection closed by foreign host.
USING: combinators kernel prettyprint io io.server sequences
namespaces io.sockets continuations ;
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
] }
{ [ data-mode get ] [ t ] }
{ [ t ] [
"500 ERROR\r\n" write flush t
] }
} cond nip [ process ] when ;
: smtp-server ( port -- )
"Starting SMTP server on port " write dup . flush
"127.0.0.1" swap <inet4> <server> [
accept [
60000 stdio get set-timeout
"220 hello\r\n" write flush
process
] with-stream
] with-disposal ;

128
extra/smtp/smtp-tests.factor
View File

@ -1,41 +1,111 @@
! Tested with Apache JAMES version 2.3.1 on localhost USING: smtp tools.test io.streams.string io.logging threads
! cram-md5 authentication tested against Exim 4 smtp.server kernel sequences namespaces ;
! Replace "localhost" with your smtp server IN: temporary
! e.g. "your.smtp.server" initialize
USING: smtp tools.test ; { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
"localhost" initialize ! replace localhost with your smtp server [ "hello\nworld" validate-address ] must-fail
! 8889 set-port ! default port = 25, change for testing purposes [ "slava@factorcode.org" ]
[ "slava@factorcode.org" validate-address ] unit-test
! 30000 set-read-timeout ! default = 60000 [ { "hello" "." "world" } validate-message ] must-fail
! f set-esmtp ! when esmtp (extended smtp) is not supported
start [ "hello\r\nworld\r\n.\r\n" ] [
{ "hello" "world" } [ send-body ] string-out
] unit-test
! "md5 password here" "login" cram-md5-auth [
[
"500 syntax error" check-response
] with-log-stdio
] must-fail
"root@localhost" mailfrom ! your@mail.address [ ] [
[
"220 success" check-response
] with-log-stdio
] unit-test
"root@localhost" rcptto ! someone@example.com [ "220 success" ] [
"220 success" [ receive-response ] string-in
] unit-test
! { "From: Your Name <your@mail.address>" [ "220 the end" ] [
! "To: Destination Address <someone@example.com>" [
! "Subject: test message" "220-a multiline response\r\n250-another line\r\n220 the end"
! "Date: Thu, 17 May 2007 18:46:45 +0200" [ receive-response ] string-in
! "Message-Id: <unique.message.id.string@example.com>" ] with-log-stdio
! " " ] unit-test
! "This is a test message."
! } send-message
{ "From: Your Name <root@localhost>" [ ] [
"To: Destination Address <root@localhost>" [
"Subject: test message" "220-a multiline response\r\n250-another line\r\n220 the end"
"Date: Thu, 17 May 2007 18:46:45 +0200" [ get-ok ] string-in
"Message-Id: <unique.message.id.string@example.com>" ] with-log-stdio
] unit-test
[
"Subject:\r\nsecurity hole" validate-header
] must-fail
[
V{
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
{ "From" "Doug <erg@factorcode.org>" }
{ "Subject" "Factor rules" }
}
{ "slava@factorcode.org" "dharmatech@factorcode.org" }
"erg@factorcode.org"
] [
"Factor rules"
{
"Slava <slava@factorcode.org>"
"Ed <dharmatech@factorcode.org>"
}
"Doug <erg@factorcode.org>"
simple-headers >r >r 2 head* r> r>
] unit-test
[
{
"To: Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>"
"From: Doug <erg@factorcode.org>"
"Subject: Factor rules"
f
f
" " " "
"This is a test message." "Hi guys"
} send-message "Bye guys"
}
{ "slava@factorcode.org" "dharmatech@factorcode.org" }
"erg@factorcode.org"
] [
"Hi guys\nBye guys"
"Factor rules"
{
"Slava <slava@factorcode.org>"
"Ed <dharmatech@factorcode.org>"
}
"Doug <erg@factorcode.org>"
prepare-simple-message
>r >r f 3 pick set-nth f 4 pick set-nth r> r>
] unit-test
quit [ ] [ [ 4321 smtp-server ] in-thread ] unit-test
[ ] [
[
4321 smtp-port set
"Hi guys\nBye guys"
"Factor rules"
{
"Slava <slava@factorcode.org>"
"Ed <dharmatech@factorcode.org>"
}
"Doug <erg@factorcode.org>"
send-simple-message
] with-scope
] unit-test

235
extra/smtp/smtp.factor
View File

@ -1,138 +1,173 @@
! Copyright (C) 2007 Elie CHAFTARI ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! USING: namespaces io kernel io.logging io.sockets sequences
! cram-md5 auth code contributed by Dirk Vleugels <dvl@2scale.net> combinators sequences.lib splitting assocs strings math.parser
random system calendar ;
USING: alien alien.c-types combinators crypto.common crypto.hmac base64
kernel io io.sockets namespaces sequences splitting ;
IN: smtp IN: smtp
! ========================================================= SYMBOL: smtp-domain
! smtp.factor implementation SYMBOL: smtp-host "localhost" smtp-host set-global
! ========================================================= SYMBOL: smtp-port 25 smtp-port set-global
SYMBOL: read-timeout 60000 read-timeout set-global
SYMBOL: esmtp t esmtp set-global
! Connection default values : log-smtp-connection ( host port -- )
: default-port 25 ; inline [
: read-timeout 60000 ; inline "Establishing SMTP connection to " % swap % ":" % #
: esmtp t ; inline ! t = ehlo ] "" make log-message ;
: domain "localhost.localdomain" ; inline
SYMBOL: sess : with-smtp-connection ( quot -- )
SYMBOL: conn [
SYMBOL: challenge smtp-host get smtp-port get
2dup log-smtp-connection
<inet> <client> [
smtp-domain [ host-name or ] change
read-timeout get stdio get set-timeout
call
] with-stream
] with-log-stdio ; inline
TUPLE: session address port timeout domain esmtp ; : crlf "\r\n" write ;
: <session> ( address -- session ) : helo ( -- )
default-port read-timeout domain esmtp esmtp get "EHLO " "HELO " ? write host-name write crlf ;
session construct-boa ;
! ========================================================= : validate-address ( string -- string' )
! Initialization routines #! Make sure we send funky stuff to the server by accident.
! ========================================================= dup [ "\r\n>" member? ] contains?
[ "Bad e-mail address: " swap append throw ] when ;
: initialize ( address -- ) : mail-from ( fromaddr -- )
<session> sess set ; "MAIL FROM:<" write validate-address write ">" write crlf ;
: set-port ( port -- ) : rcpt-to ( to -- )
sess get set-session-port ; "RCPT TO:<" write validate-address write ">" write crlf ;
: set-read-timeout ( timeout -- ) : data ( -- )
sess get set-session-timeout ; "DATA" write crlf ;
: set-esmtp ( esmtp -- ) : validate-message ( msg -- msg' )
sess get set-session-esmtp ; "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
: set-domain ( -- ) : send-body ( body -- )
host-name sess get set-session-domain ; validate-message
[ write crlf ] each
"." write crlf ;
: do-start ( -- ) : quit ( -- )
sess get [ session-address ] keep session-port <inet> <client> "QUIT" write crlf ;
dup conn set [ sess get session-timeout swap set-timeout ]
keep stream-readln print ;
! ========================================================= : log-response ( string -- ) "SMTP: " swap append log-message ;
! Command routines
! =========================================================
: check-response ( response -- ) : check-response ( response -- )
{ {
{ [ dup "220" head? ] [ print ] } { [ dup "220" head? ] [ log-response ] }
{ [ dup "235" swap subseq? ] [ print ] } { [ dup "235" swap subseq? ] [ log-response ] }
{ [ dup "250" head? ] [ print ] } { [ dup "250" head? ] [ log-response ] }
{ [ dup "221" head? ] [ print ] } { [ dup "221" head? ] [ log-response ] }
{ [ dup "bye" head? ] [ print ] } { [ dup "bye" head? ] [ log-response ] }
{ [ dup "4" head? ] [ "server busy" throw ] } { [ dup "4" head? ] [ "server busy" throw ] }
{ [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } { [ dup "354" head? ] [ log-response ] }
{ [ dup "354" head? ] [ print ] } { [ dup "50" head? ] [ log-response "syntax error" throw ] }
{ [ dup "50" head? ] [ print "syntax error" throw ] } { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] }
{ [ dup "53" head? ] [ print "invalid authentication data" throw ] } { [ dup "55" head? ] [ log-response "fatal error" throw ] }
{ [ dup "55" head? ] [ print "fatal error" throw ] } { [ t ] [ "unknown error" throw ] }
{ [ t ] [ "unknow error" throw ] }
} cond ; } cond ;
SYMBOL: multiline
: multiline? ( response -- boolean ) : multiline? ( response -- boolean )
CHAR: - swap index 3 = ; ?fourth CHAR: - = ;
: process-multiline ( -- response ) : process-multiline ( multiline -- response )
conn get stream-readln dup >r readln r> 2dup " " append head? [
multiline get " " append head? [ drop dup log-response
print
] [ ] [
check-response process-multiline swap check-response process-multiline
] if ; ] if ;
: recv-response ( -- response ) : receive-response ( -- response )
conn get stream-readln readln
dup multiline? [ dup multiline? [ 3 head process-multiline ] when ;
dup 3 head multiline set process-multiline
] [ ] if ;
: get-ok ( command -- ) : get-ok ( -- ) flush receive-response check-response ;
>r conn get r> over stream-write stream-flush
recv-response check-response ;
: helo ( -- ) : send-raw-message ( body to from -- )
"HELO " sess get session-domain append "\r\n" append get-ok ; [
helo get-ok
mail-from get-ok
[ rcpt-to get-ok ] each
data get-ok
send-body get-ok
quit get-ok
] with-smtp-connection ;
: ehlo ( -- ) : validate-header ( string -- string' )
"EHLO " sess get session-domain append "\r\n" append get-ok ; dup [ "\r\n" member? ] contains?
[ "Invalid header string: " swap append throw ] when ;
: mailfrom ( fromaddr -- ) : prepare-header ( key value -- )
"MAIL FROM:<" swap append ">\r\n" append get-ok ; swap
validate-header %
": " %
validate-header % ;
: rcptto ( to -- ) : prepare-headers ( assoc -- )
"RCPT TO:<" swap append ">\r\n" append get-ok ; [ [ prepare-header ] "" make , ] assoc-each ;
: (cram-md5-auth) ( -- response ) : extract-email ( recepient -- email )
swap challenge get #! This could be much smarter.
string>md5-hmac hex-string " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
" " swap append append
>base64 ;
: cram-md5-auth ( key login -- ) : message-id ( -- string )
"AUTH CRAM-MD5\r\n" get-ok [
(cram-md5-auth) "\r\n" append get-ok ; "<" %
2 big-random #
"-" %
millis #
"@" %
smtp-domain get %
">" %
] "" make ;
: data ( -- ) : simple-headers ( subject to from -- headers to from )
"DATA\r\n" get-ok ; [
>r dup ", " join "To" set [ extract-email ] map r>
dup "From" set extract-email
rot "Subject" set
now timestamp>rfc822-string "Date" set
message-id "Message-Id" set
] { } make-assoc -rot ;
: start ( -- ) : prepare-message ( body headers -- body' )
set-domain ! replaces localhost.localdomain with hostname [
do-start prepare-headers
sess get session-esmtp [ " " ,
ehlo dup string? [ string-lines ] when %
] [ ] { } make ;
helo
] if ;
: send-message ( msg -- ) : prepare-simple-message ( body subject to from -- body' to from )
data simple-headers >r >r prepare-message r> r> ;
"\r\n" join conn get swap "\r\n" append over stream-write
stream-flush ".\r\n" get-ok ;
: quit ( -- ) : send-message ( body headers to from -- )
"QUIT\r\n" get-ok ; >r >r prepare-message r> r> send-raw-message ;
: send-simple-message ( body subject to from -- )
prepare-simple-message send-raw-message ;
! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
! CRAM MD5, and the old code didn't work properly either, so here
! it is in case anyone wants to fix it later.
!
! check-response used to have this clause:
! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
!
! and the rest of the code was as follows:
! : (cram-md5-auth) ( -- response )
! swap challenge get
! string>md5-hmac hex-string
! " " swap append append
! >base64 ;
!
! : cram-md5-auth ( key login -- )
! "AUTH CRAM-MD5\r\n" get-ok
! (cram-md5-auth) "\r\n" append get-ok ;