smtp: make content-type configurable

basis/smtp/authors.txt

@@ -1,3 +1,5 @@
 Elie Chaftari
 Dirk Vleugels
 Slava Pestov
+Doug Coleman
+Daniel Ehrenberg

basis/smtp/server/server.factor

@@ -36,6 +36,7 @@ SYMBOL: data-mode
 
 : process ( -- )
     read-crlf {
+        { [ dup not ] [ f ] }
         {
             [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
             [ "220 and..?\r\n" write flush t ]

basis/smtp/smtp-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel quotations help.syntax help.markup
-io.sockets strings calendar ;
+io.sockets strings calendar io.encodings.utf8 ;
 IN: smtp
 
 HELP: smtp-domain
@@ -41,7 +41,9 @@ HELP: email
         { { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." }
         { { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
         { { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
-        { { $slot "subject" } " The subject of the e-mail. A string." }
+        { { $slot "subject" } "The subject of the e-mail. A string." }
+        { { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } }
+        { { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } }
         { { $slot "body" } " The body of the e-mail. A string." }
     }
 "The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."

basis/smtp/smtp-tests.factor

@@ -16,7 +16,7 @@ IN: smtp.tests
 [ { "hello" "." "world" } validate-message ] must-fail
 
 [ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
-    "hello\nworld" [ send-body ] with-string-writer
+    T{ email { body "hello\nworld" } } [ send-body ] with-string-writer
 ] unit-test
 
 [ { "500 syntax error" } <response> check-response ]
@@ -51,7 +51,7 @@ IN: smtp.tests
 [
     {
         { "Content-Transfer-Encoding" "base64" }
-        { "Content-Type" "Text/plain; charset=utf-8" }
+        { "Content-Type" "text/plain; charset=UTF-8" }
         { "From" "Doug <erg@factorcode.org>" }
         { "MIME-Version" "1.0" }
         { "Subject" "Factor rules" }

basis/smtp/smtp.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
-! Slava Pestov, Doug Coleman.
+! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces make io io.encodings.string
-io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
-io.encodings.ascii kernel logging sequences combinators
-splitting assocs strings math.order math.parser random system
-calendar summary calendar.format accessors sets hashtables
-base64 debugger classes prettyprint io.crlf ;
+USING: arrays namespaces make io io.encodings.string io.encodings.utf8
+io.encodings.iana io.timeouts io.sockets io.sockets.secure
+io.encodings.ascii kernel logging sequences combinators splitting
+assocs strings math.order math.parser random system calendar summary
+calendar.format accessors sets hashtables base64 debugger classes
+prettyprint io.crlf words ;
 IN: smtp
 
 SYMBOL: smtp-domain
@@ -44,6 +44,8 @@ TUPLE: email
     { cc array }
     { bcc array }
     { subject string }
+    { content-type string initial: "text/plain" }
+    { encoding word initial: utf8 }
     { body string } ;
 
 : <email> ( -- email ) email new ; inline
@@ -85,8 +87,8 @@ M: message-contains-dot summary ( obj -- string )
     "." over member?
     [ message-contains-dot ] when ;
 
-: send-body ( body -- )
-    utf8 encode
+: send-body ( email -- )
+    [ body>> ] [ encoding>> ] bi encode
     >base64-lines write crlf
     "." command ;
 
@@ -195,24 +197,23 @@ 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-content-type ( email -- content-type )
+    [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
 
-: email>headers ( email -- hashtable )
+: email>headers ( email -- assoc )
     [
+        now timestamp>rfc822 "Date" set
+        message-id "Message-Id" set
+        "1.0" "MIME-Version" set
+        "base64" "Content-Transfer-Encoding" set
         {
             [ from>> "From" set ]
             [ to>> ", " join "To" set ]
             [ cc>> ", " join [ "Cc" set ] unless-empty ]
             [ subject>> "Subject" set ]
+            [ email-content-type "Content-Type" set ]
         } cleave
-        now timestamp>rfc822 "Date" set
-        message-id "Message-Id" set
-    ] { } make-assoc utf8-mime-header append ;
+    ] { } make-assoc ;
 
 : (send-email) ( headers email -- )
     [
@@ -227,7 +228,7 @@ ERROR: invalid-header-string string ;
         data get-ok
         swap write-headers
         crlf
-        body>> send-body get-ok
+        send-body get-ok
         quit get-ok
     ] with-smtp-connection ;