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

smtp now uses new-slots

db4
Slava Pestov 2008-03-07 01:55:38 -06:00
parent 755003df08
commit 047a6c27a1
2 changed files with 70 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,6 @@
USING: smtp tools.test io.streams.string threads USING: smtp tools.test io.streams.string threads
smtp.server kernel sequences namespaces logging ; smtp.server kernel sequences namespaces logging accessors
assocs sorting ;
IN: smtp.tests IN: smtp.tests
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
@ -12,7 +13,7 @@ IN: smtp.tests
[ { "hello" "." "world" } validate-message ] must-fail [ { "hello" "." "world" } validate-message ] must-fail
[ "hello\r\nworld\r\n.\r\n" ] [ [ "hello\r\nworld\r\n.\r\n" ] [
{ "hello" "world" } [ 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" check-response ] must-fail
@ -38,46 +39,27 @@ IN: smtp.tests
] must-fail ] must-fail
[ [
V{ {
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
{ "From" "Doug <erg@factorcode.org>" } { "From" "Doug <erg@factorcode.org>" }
{ "Subject" "Factor rules" } { "Subject" "Factor rules" }
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
} }
{ "slava@factorcode.org" "dharmatech@factorcode.org" } { "slava@factorcode.org" "dharmatech@factorcode.org" }
"erg@factorcode.org" "erg@factorcode.org"
] [ ] [
"Factor rules" <email>
{ "Factor rules" >>subject
"Slava <slava@factorcode.org>" {
"Ed <dharmatech@factorcode.org>" "Slava <slava@factorcode.org>"
} "Ed <dharmatech@factorcode.org>"
"Doug <erg@factorcode.org>" } >>to
simple-headers >r >r 2 head* r> r> "Doug <erg@factorcode.org>" >>from
] unit-test prepare
dup headers>> >alist sort-keys [
[ drop { "Date" "Message-Id" } member? not
{ ] assoc-subset
"To: Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" over to>>
"From: Doug <erg@factorcode.org>" rot from>>
"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 ] unit-test
[ ] [ [ 4321 smtp-server ] in-thread ] unit-test [ ] [ [ 4321 smtp-server ] in-thread ] unit-test
@ -87,14 +69,14 @@ IN: smtp.tests
"localhost" smtp-host set "localhost" smtp-host set
4321 smtp-port set 4321 smtp-port set
"Hi guys\nBye guys" <email>
"Factor rules" "Hi guys\nBye guys" >>body
{ "Factor rules" >>subject
"Slava <slava@factorcode.org>" {
"Ed <dharmatech@factorcode.org>" "Slava <slava@factorcode.org>"
} "Ed <dharmatech@factorcode.org>"
"Doug <erg@factorcode.org>" } >>to
"Doug <erg@factorcode.org>" >>from
send-simple-message send
] with-scope ] with-scope
] unit-test ] unit-test

92
extra/smtp/smtp.factor
View File

@ -3,8 +3,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces io io.timeouts kernel logging io.sockets USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar io.encodings.ascii calendar.format ; math.parser random system calendar io.encodings.ascii
calendar.format new-slots accessors ;
IN: smtp IN: smtp
SYMBOL: smtp-domain SYMBOL: smtp-domain
@ -49,6 +49,7 @@ SYMBOL: esmtp t esmtp set-global
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ; "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
: send-body ( body -- ) : send-body ( body -- )
string-lines
validate-message validate-message
[ write crlf ] each [ write crlf ] each
"." write crlf ; "." write crlf ;
@ -89,28 +90,36 @@ LOG: smtp-response DEBUG
: get-ok ( -- ) flush receive-response check-response ; : get-ok ( -- ) flush receive-response check-response ;
: 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 ;
: validate-header ( string -- string' ) : validate-header ( string -- string' )
dup [ "\r\n" member? ] contains? dup [ "\r\n" member? ] contains?
[ "Invalid header string: " swap append throw ] when ; [ "Invalid header string: " swap append throw ] when ;
: prepare-header ( key value -- ) : write-header ( key value -- )
swap swap
validate-header % validate-header write
": " % ": " write
validate-header % ; validate-header write
crlf ;
: prepare-headers ( assoc -- ) : write-headers ( assoc -- )
[ [ prepare-header ] "" make , ] assoc-each ; [ write-header ] assoc-each ;
TUPLE: email from to subject headers body ;
M: email clone
(clone) [ clone ] change-headers ;
: (send) ( email -- )
[
helo get-ok
dup from>> mail-from get-ok
dup to>> [ rcpt-to get-ok ] each
data get-ok
dup headers>> write-headers
crlf
body>> send-body get-ok
quit get-ok
] with-smtp-connection ;
: extract-email ( recepient -- email ) : extract-email ( recepient -- email )
#! This could be much smarter. #! This could be much smarter.
@ -127,30 +136,25 @@ LOG: smtp-response DEBUG
">" % ">" %
] "" make ; ] "" make ;
: simple-headers ( subject to from -- headers to from ) : set-header ( email value key -- email )
[ pick headers>> set-at ;
>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 ;
: prepare-message ( body headers -- body' ) : prepare ( email -- email )
[ clone
prepare-headers dup from>> "From" set-header
"" , [ extract-email ] change-from
dup string? [ string-lines ] when % dup to>> ", " join "To" set-header
] { } make ; [ [ extract-email ] map ] change-to
dup subject>> "Subject" set-header
now timestamp>rfc822-string "Date" set-header
message-id "Message-Id" set-header ;
: prepare-simple-message ( body subject to from -- body' to from ) : <email> ( -- email )
simple-headers >r >r prepare-message r> r> ; email construct-empty
H{ } clone >>headers ;
: send-message ( body headers to from -- ) : send ( email -- )
>r >r prepare-message r> r> send-raw-message ; prepare (send) ;
: 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 ! 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 ! CRAM MD5, and the old code didn't work properly either, so here
@ -171,13 +175,3 @@ LOG: smtp-response DEBUG
! (cram-md5-auth) "\r\n" append get-ok ; ! (cram-md5-auth) "\r\n" append get-ok ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: new-slots
TUPLE: email from to subject body ;
: <email> ( -- email ) email construct-empty ;
: send ( email -- )
{ email-body email-subject email-to email-from } get-slots
send-simple-message ;