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
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 ;

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

@ -1,41 +1,111 @@
! Tested with Apache JAMES version 2.3.1 on localhost
! cram-md5 authentication tested against Exim 4
! Replace "localhost" with your smtp server
! e.g. "your.smtp.server" initialize
USING: smtp tools.test io.streams.string io.logging threads
smtp.server kernel sequences namespaces ;
IN: temporary
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
! f set-esmtp ! when esmtp (extended smtp) is not supported
[ { "hello" "." "world" } validate-message ] must-fail
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>"
! "To: Destination Address <someone@example.com>"
! "Subject: test message"
! "Date: Thu, 17 May 2007 18:46:45 +0200"
! "Message-Id: <unique.message.id.string@example.com>"
! " "
! "This is a test message."
! } send-message
[ "220 the end" ] [
[
"220-a multiline response\r\n250-another line\r\n220 the end"
[ receive-response ] string-in
] with-log-stdio
] unit-test
{ "From: Your Name <root@localhost>"
"To: Destination Address <root@localhost>"
"Subject: test message"
"Date: Thu, 17 May 2007 18:46:45 +0200"
"Message-Id: <unique.message.id.string@example.com>"
" "
"This is a test message."
} send-message
[ ] [
[
"220-a multiline response\r\n250-another line\r\n220 the end"
[ get-ok ] string-in
] with-log-stdio
] unit-test
quit
[
"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
" "
"Hi guys"
"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
[ ] [ [ 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

237
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.
!
! cram-md5 auth code contributed by Dirk Vleugels <dvl@2scale.net>
USING: alien alien.c-types combinators crypto.common crypto.hmac base64
kernel io io.sockets namespaces sequences splitting ;
USING: namespaces io kernel io.logging io.sockets sequences
combinators sequences.lib splitting assocs strings math.parser
random system calendar ;
IN: smtp
! =========================================================
! smtp.factor implementation
! =========================================================
SYMBOL: smtp-domain
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
: default-port 25 ; inline
: read-timeout 60000 ; inline
: esmtp t ; inline ! t = ehlo
: domain "localhost.localdomain" ; inline
: log-smtp-connection ( host port -- )
[
"Establishing SMTP connection to " % swap % ":" % #
] "" make log-message ;
SYMBOL: sess
SYMBOL: conn
SYMBOL: challenge
: with-smtp-connection ( quot -- )
[
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 )
default-port read-timeout domain esmtp
session construct-boa ;
: helo ( -- )
esmtp get "EHLO " "HELO " ? write host-name write crlf ;
! =========================================================
! Initialization routines
! =========================================================
: validate-address ( string -- string' )
#! 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 -- )
<session> sess set ;
: mail-from ( fromaddr -- )
"MAIL FROM:<" write validate-address write ">" write crlf ;
: set-port ( port -- )
sess get set-session-port ;
: rcpt-to ( to -- )
"RCPT TO:<" write validate-address write ">" write crlf ;
: set-read-timeout ( timeout -- )
sess get set-session-timeout ;
: data ( -- )
"DATA" write crlf ;
: set-esmtp ( esmtp -- )
sess get set-session-esmtp ;
: validate-message ( msg -- msg' )
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
: set-domain ( -- )
host-name sess get set-session-domain ;
: send-body ( body -- )
validate-message
[ write crlf ] each
"." write crlf ;
: do-start ( -- )
sess get [ session-address ] keep session-port <inet> <client>
dup conn set [ sess get session-timeout swap set-timeout ]
keep stream-readln print ;
: quit ( -- )
"QUIT" write crlf ;
! =========================================================
! Command routines
! =========================================================
: log-response ( string -- ) "SMTP: " swap append log-message ;
: check-response ( response -- )
{
{ [ dup "220" head? ] [ print ] }
{ [ dup "235" swap subseq? ] [ print ] }
{ [ dup "250" head? ] [ print ] }
{ [ dup "221" head? ] [ print ] }
{ [ dup "bye" head? ] [ print ] }
{ [ dup "220" head? ] [ log-response ] }
{ [ dup "235" swap subseq? ] [ log-response ] }
{ [ dup "250" head? ] [ log-response ] }
{ [ dup "221" head? ] [ log-response ] }
{ [ dup "bye" head? ] [ log-response ] }
{ [ dup "4" head? ] [ "server busy" throw ] }
{ [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
{ [ dup "354" head? ] [ print ] }
{ [ dup "50" head? ] [ print "syntax error" throw ] }
{ [ dup "53" head? ] [ print "invalid authentication data" throw ] }
{ [ dup "55" head? ] [ print "fatal error" throw ] }
{ [ t ] [ "unknow error" throw ] }
{ [ dup "354" head? ] [ log-response ] }
{ [ dup "50" head? ] [ log-response "syntax error" throw ] }
{ [ dup "53" head? ] [ log-response "invalid authentication data" throw ] }
{ [ dup "55" head? ] [ log-response "fatal error" throw ] }
{ [ t ] [ "unknown error" throw ] }
} cond ;
SYMBOL: multiline
: multiline? ( response -- boolean )
CHAR: - swap index 3 = ;
?fourth CHAR: - = ;
: process-multiline ( -- response )
conn get stream-readln dup
multiline get " " append head? [
print
: process-multiline ( multiline -- response )
>r readln r> 2dup " " append head? [
drop dup log-response
] [
check-response process-multiline
swap check-response process-multiline
] if ;
: recv-response ( -- response )
conn get stream-readln
dup multiline? [
dup 3 head multiline set process-multiline
] [ ] if ;
: receive-response ( -- response )
readln
dup multiline? [ 3 head process-multiline ] when ;
: get-ok ( command -- )
>r conn get r> over stream-write stream-flush
recv-response check-response ;
: get-ok ( -- ) flush receive-response check-response ;
: helo ( -- )
"HELO " sess get session-domain append "\r\n" append get-ok ;
: send-raw-message ( body to from -- )
[
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 ( -- )
"EHLO " sess get session-domain append "\r\n" append get-ok ;
: validate-header ( string -- string' )
dup [ "\r\n" member? ] contains?
[ "Invalid header string: " swap append throw ] when ;
: mailfrom ( fromaddr -- )
"MAIL FROM:<" swap append ">\r\n" append get-ok ;
: prepare-header ( key value -- )
swap
validate-header %
": " %
validate-header % ;
: rcptto ( to -- )
"RCPT TO:<" swap append ">\r\n" append get-ok ;
: prepare-headers ( assoc -- )
[ [ prepare-header ] "" make , ] assoc-each ;
: (cram-md5-auth) ( -- response )
swap challenge get
string>md5-hmac hex-string
" " swap append append
>base64 ;
: extract-email ( recepient -- email )
#! This could be much smarter.
" " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
: cram-md5-auth ( key login -- )
"AUTH CRAM-MD5\r\n" get-ok
(cram-md5-auth) "\r\n" append get-ok ;
: data ( -- )
"DATA\r\n" get-ok ;
: message-id ( -- string )
[
"<" %
2 big-random #
"-" %
millis #
"@" %
smtp-domain get %
">" %
] "" make ;
: start ( -- )
set-domain ! replaces localhost.localdomain with hostname
do-start
sess get session-esmtp [
ehlo
] [
helo
] if ;
: simple-headers ( subject to from -- headers to from )
[
>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 ;
: send-message ( msg -- )
data
"\r\n" join conn get swap "\r\n" append over stream-write
stream-flush ".\r\n" get-ok ;
: prepare-message ( body headers -- body' )
[
prepare-headers
" " ,
dup string? [ string-lines ] when %
] { } make ;
: quit ( -- )
"QUIT\r\n" get-ok ;
: prepare-simple-message ( body subject to from -- body' to from )
simple-headers >r >r prepare-message r> r> ;
: send-message ( body headers to from -- )
>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 ;