SMTP supports Unicode subjects and contents

diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
index e3638bd96918fcb527f4448bf0270e6542cc7504..8a9107b905ff5a65cd85005fb17a3e531bd2d7ed 100644 (file)
--- a/basis/smtp/smtp-tests.factor
+++ b/basis/smtp/smtp-tests.factor
@@ -15,7 +15,7 @@ IN: smtp.tests
 
 [ { "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
 ] 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>" }
+        { "MIME-Version" "1.0" }
         { "Subject" "Factor rules" }
         { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
     }

diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index c17db13b014ea3573ecffdfc6d61a4fa0f6f61be..2ffc2e6db34ad87c425494b7e2237103ccce8bec 100644 (file)
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -92,9 +92,8 @@ M: message-contains-dot summary ( obj -- string )
     [ message-contains-dot ] when ;
 
 : send-body ( body -- )
-    string-lines
-    validate-message
-    [ write crlf ] each
+    utf8 encode
+    >base64-lines write crlf
     "." command ;
 
 : quit ( -- )
@@ -167,6 +166,13 @@ M: plain-auth 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 ;
 
 : validate-header ( string -- string' )
@@ -175,7 +181,7 @@ ERROR: invalid-header-string string ;
 
 : write-header ( key value -- )
     [ validate-header write ]
-    [ ": " write validate-header write ] bi* crlf ;
+    [ ": " write validate-header encode-header write ] bi* crlf ;
 
 : write-headers ( assoc -- )
     [ write-header ] assoc-each ;
@@ -195,6 +201,13 @@ ERROR: invalid-header-string string ;
     ! This could be much smarter.
     " " 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 )
     [
         {
@@ -205,7 +218,7 @@ ERROR: invalid-header-string string ;
         } cleave
         now timestamp>rfc822 "Date" set
         message-id "Message-Id" set
-    ] { } make-assoc ;
+    ] { } make-assoc utf8-mime-header append ;
 
 : (send-email) ( headers email -- )
     [