5 files changed, 60 insertions(+), 4 deletions(-)

M Email.hs
M Util.hs
M cheogram-smtp.cabal
M gateway.hs
M test/EmailTest.hs

@@ 4,6 4,7 @@ import BasicPrelude
 import Prelude ()
 import Data.Char                                 (isAscii, isAlphaNum)
 import Control.Error                             (headZ)
+import Data.Time.Clock                           (UTCTime)
 import Control.Lens 
 	(Const, Leftmost, filtered, firstOf, view, _Right, set, at)
 import qualified Data.Attoparsec.ByteString.Lazy as Atto


@@ 98,9 99,10 @@ emailToStanza toJid email =
 
 messageToEmail ::
 	   MIME.Domain
+	-> UTCTime
 	-> XMPP.Message
 	-> Maybe (MIME.Mailbox, MIME.MIMEMessage)
-messageToEmail fromDomain message@XMPP.Message {
+messageToEmail fromDomain now message@XMPP.Message {
 		XMPP.messageFrom = Just from,
 		XMPP.messageTo = Just (XMPP.JID (Just toNode) _ _)
 	} | Just bodyTxt <- getBody message,


@@ 109,13 111,17 @@ messageToEmail fromDomain message@XMPP.Message {
 			set MIME.headerTo [toAddress] $
 			set MIME.headerFrom [fromMailbox] $
 			set (MIME.headers . at (s"Subject")) subjectHeader $
+			set MIME.headerDate (Just dateHeader) $
 			MIME.createTextPlainMessage bodyTxt
 		)
 	where
+	dateHeader = fromMaybe now $ parseXMPPTime =<<
+		XML.attributeText (s"{urn:xmpp:delay}stamp") =<<
+		child (s"{urn:xmpp:delay}delay") message
 	subjectHeader = MIME.encodeEncodedWords <$> getSubject message
 	fromMailbox = jidToMailbox from fromDomain
 	unescapedToNode = encodeUtf8 $ unescapeJid $ XMPP.strNode toNode
-messageToEmail _ _ = Nothing
+messageToEmail _ _ _ = Nothing
 
 -- copied from purebred-email
 -- See https://github.com/purebred-mua/purebred-email/issues/39

@@ 8,6 8,8 @@ import Control.Concurrent
 	(ThreadId, forkFinally, myThreadId, throwTo)
 import Data.Void                       (absurd)
 import Control.Error                   (exceptT)
+import Data.Time.Clock                 (UTCTime)
+import Data.Time.Format                (parseTimeM, defaultTimeLocale)
 import qualified Control.Exception     as Ex
 import qualified Data.Attoparsec.Text  as Atto
 import qualified Data.Text             as Text


@@ 143,3 145,7 @@ bareTxt :: XMPP.JID -> Text
 bareTxt (XMPP.JID (Just node) domain _) =
 	mconcat [XMPP.strNode node, s"@", XMPP.strDomain domain]
 bareTxt (XMPP.JID Nothing domain _) = XMPP.strDomain domain
+
+parseXMPPTime :: Text -> Maybe UTCTime
+parseXMPPTime =
+	parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" . textToString

@@ 29,6 29,7 @@ common defs
                        stm-containers        >= 1.1.0 && < 1.2,
                        stm-delay             >=0.1 && <0.2,
                        text                  >=1.2 && <1.3,
+                       time                  >=1.5 && <2.0,
                        unexceptionalio-trans >=0.5 && <0.6,
                        uuid                  >= 1.3.13 && < 1.4,
                        xml-types             >=0.3 && <0.4

@@ 5,6 5,7 @@ import BasicPrelude
 import Control.Concurrent              (threadDelay)
 import Control.Error                   (exceptT)
 import Network                         (PortID (PortNumber))
+import Data.Time.Clock                 (getCurrentTime)
 import qualified Data.ByteString.Lazy  as LByteString
 import qualified Focus
 import qualified StmContainers.Map     as STMMap


@@ 75,8 76,9 @@ messageHandler ::
 	   MIME.Domain
 	-> XMPP.Message
 	-> XMPP.XMPP ()
-messageHandler fromDomain message =
-	forM_ (messageToEmail fromDomain message) $ \(from, mail) ->
+messageHandler fromDomain message = do
+	now <- liftIO getCurrentTime
+	forM_ (messageToEmail fromDomain now message) $ \(from, mail) ->
 		liftIO $ Mail.sendmailCustom "/usr/sbin/sendmail" [
 			"-t", "-i",
 			"-f", textToString $ decodeUtf8 $

@@ 95,14 95,17 @@ unit_messageToEmail =
 	fmap (MIME.renderMessage . snd) (
 		messageToEmail
 		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		date
 		message
 	)
 	@?=
 	Just email
 	where
+	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
 	email = s"MIME-Version: 1.0\r\n\
 	\To: t@example.com\r\n\
 	\From: f%40example%2Ecom@gateway.example.com\r\n\
+	\date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\
 	\Content-Transfer-Encoding: base64\r\n\
 	\Content-Disposition: inline\r\n\
 	\Content-Type: text/plain; charset=utf-8\r\n\


@@ 126,15 129,18 @@ unit_messageToEmailWithSubject =
 	fmap (MIME.renderMessage . snd) (
 		messageToEmail
 		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		date
 		message
 	)
 	@?=
 	Just email
 	where
+	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
 	email = s"MIME-Version: 1.0\r\n\
 	\To: t@example.com\r\n\
 	\From: f%40example%2Ecom@gateway.example.com\r\n\
 	\Subject: =?utf-8?B?5LiW55WM?=\r\n\
+	\date: Mon, 01 Jan 1990 00:00:00 +0000\r\n\
 	\Content-Transfer-Encoding: base64\r\n\
 	\Content-Disposition: inline\r\n\
 	\Content-Type: text/plain; charset=utf-8\r\n\


@@ 157,3 163,38 @@ unit_messageToEmailWithSubject =
 			]
 		]
 	}
+
+unit_messageToEmailWithDelay :: IO ()
+unit_messageToEmailWithDelay =
+	fmap (MIME.renderMessage . snd) (
+		messageToEmail
+		(MIME.DomainLiteral $ encodeUtf8 $ s"gateway.example.com")
+		date
+		message
+	)
+	@?=
+	Just email
+	where
+	Just date = parseXMPPTime (s"1990-01-01T00:00:00Z")
+	email = s"MIME-Version: 1.0\r\n\
+	\To: t@example.com\r\n\
+	\From: f%40example%2Ecom@gateway.example.com\r\n\
+	\date: Sun, 22 Feb 2009 00:10:00 +0000\r\n\
+	\Content-Transfer-Encoding: base64\r\n\
+	\Content-Disposition: inline\r\n\
+	\Content-Type: text/plain; charset=utf-8\r\n\
+	\\r\n\
+	\5LiW55WMCi4K\r\n"
+	message = (XMPP.emptyMessage XMPP.MessageNormal) {
+		XMPP.messageTo =
+			XMPP.parseJID $ s"t\\40example.com@gateway.example.com",
+		XMPP.messageFrom = XMPP.parseJID $ s"f@example.com",
+		XMPP.messagePayloads = [
+			XML.Element (fromString "{urn:xmpp:delay}delay") [(
+				s"{urn:xmpp:delay}stamp",
+				[XML.ContentText $ s"2009-02-22T00:10:00Z"]
+			)] [],
+			XML.Element (fromString "{jabber:component:accept}body")
+			[] [XML.NodeContent $ XML.ContentText $ s"世界\n.\n"]
+		]
+	}