M Email.hs => Email.hs +8 -2
@@ 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
M Util.hs => Util.hs +6 -0
@@ 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
M cheogram-smtp.cabal => cheogram-smtp.cabal +1 -0
@@ 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
M gateway.hs => gateway.hs +4 -2
@@ 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 $
M test/EmailTest.hs => test/EmailTest.hs +41 -0
@@ 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"]
+ ]
+ }