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

SMTP supports Unicode subjects and contents

db4
Daniel Ehrenberg 2009-01-13 19:13:01 -06:00
parent 3b679cf2be
commit 85c6efa718
2 changed files with 22 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,7 +15,7 @@ IN: smtp.tests
[ { "hello" "." "world" } validate-message ] must-fail [ { "hello" "." "world" } validate-message ] must-fail
[ "hello\r\nworld\r\n.\r\n" ] [ [ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
"hello\nworld" [ send-body ] with-string-writer "hello\nworld" [ send-body ] with-string-writer
] unit-test ] unit-test
@ -50,7 +50,10 @@ IN: smtp.tests
[ [
{ {
{ "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" }
{ "From" "Doug <erg@factorcode.org>" } { "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" }
{ "Subject" "Factor rules" } { "Subject" "Factor rules" }
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" } { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
} }

23
basis/smtp/smtp.factor
View File

@ -92,9 +92,8 @@ M: message-contains-dot summary ( obj -- string )
[ message-contains-dot ] when ; [ message-contains-dot ] when ;
: send-body ( body -- ) : send-body ( body -- )
string-lines utf8 encode
validate-message >base64-lines write crlf
[ write crlf ] each
"." command ; "." command ;
: quit ( -- ) : quit ( -- )
@ -167,6 +166,13 @@ M: plain-auth send-auth
: auth ( -- ) smtp-auth get send-auth ; : auth ( -- ) smtp-auth get send-auth ;
: encode-header ( string -- string' )
dup aux>> [
"=?utf-8?B?"
swap utf8 encode >base64
"?=" 3append
] when ;
ERROR: invalid-header-string string ; ERROR: invalid-header-string string ;
: validate-header ( string -- string' ) : validate-header ( string -- string' )
@ -175,7 +181,7 @@ ERROR: invalid-header-string string ;
: write-header ( key value -- ) : write-header ( key value -- )
[ validate-header write ] [ validate-header write ]
[ ": " write validate-header write ] bi* crlf ; [ ": " write validate-header encode-header write ] bi* crlf ;
: write-headers ( assoc -- ) : write-headers ( assoc -- )
[ write-header ] assoc-each ; [ write-header ] assoc-each ;
@ -195,6 +201,13 @@ ERROR: invalid-header-string string ;
! This could be much smarter. ! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ; " " split1-last swap or "<" ?head drop ">" ?tail drop ;
: utf8-mime-header ( -- alist )
{
{ "MIME-Version" "1.0" }
{ "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" }
} ;
: email>headers ( email -- hashtable ) : email>headers ( email -- hashtable )
[ [
{ {
@ -205,7 +218,7 @@ ERROR: invalid-header-string string ;
} cleave } cleave
now timestamp>rfc822 "Date" set now timestamp>rfc822 "Date" set
message-id "Message-Id" set message-id "Message-Id" set
] { } make-assoc ; ] { } make-assoc utf8-mime-header append ;
: (send-email) ( headers email -- ) : (send-email) ( headers email -- )
[ [