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

92
extra/smtp/smtp.factor
View File

@ -3,8 +3,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces io io.timeouts kernel logging io.sockets
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
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 ;
: send-body ( body -- )
string-lines
validate-message
[ write crlf ] each
"." write crlf ;
@ -89,28 +90,36 @@ LOG: smtp-response DEBUG
: 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' )
dup [ "\r\n" member? ] contains?
[ "Invalid header string: " swap append throw ] when ;
: prepare-header ( key value -- )
: write-header ( key value -- )
swap
validate-header %
": " %
validate-header % ;
validate-header write
": " write
validate-header write
crlf ;
: prepare-headers ( assoc -- )
[ [ prepare-header ] "" make , ] assoc-each ;
: write-headers ( assoc -- )
[ 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 )
#! This could be much smarter.
@ -127,30 +136,25 @@ LOG: smtp-response DEBUG
">" %
] "" make ;
: 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 ;
: set-header ( email value key -- email )
pick headers>> set-at ;
: prepare-message ( body headers -- body' )
[
prepare-headers
"" ,
dup string? [ string-lines ] when %
] { } make ;
: prepare ( email -- email )
clone
dup from>> "From" set-header
[ extract-email ] change-from
dup to>> ", " join "To" set-header
[ [ 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 )
simple-headers >r >r prepare-message r> r> ;
: <email> ( -- email )
email construct-empty
H{ } clone >>headers ;
: 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 ;
: send ( email -- )
prepare (send) ;
! 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
@ -171,13 +175,3 @@ LOG: smtp-response DEBUG
! (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 ;