From ccfeda0ae8015c99e370c5e76ff2af16731cef07 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Sun, 23 Feb 2020 19:34:18 -0500 Subject: [PATCH] Add Date header, from delayed deliver if present else now --- Email.hs | 10 ++++++++-- Util.hs | 6 ++++++ cheogram-smtp.cabal | 1 + gateway.hs | 6 ++++-- test/EmailTest.hs | 41 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 60 insertions(+), 4 deletions(-) diff --git a/Email.hs b/Email.hs index 4b192ad..043f1d7 100644 --- a/Email.hs +++ b/Email.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 diff --git a/Util.hs b/Util.hs index 3673a9d..2e5c52a 100644 --- a/Util.hs +++ b/Util.hs @@ -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 diff --git a/cheogram-smtp.cabal b/cheogram-smtp.cabal index 17e0091..1cd579f 100644 --- a/cheogram-smtp.cabal +++ b/cheogram-smtp.cabal @@ -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 diff --git a/gateway.hs b/gateway.hs index f2fc536..a3bde14 100644 --- a/gateway.hs +++ b/gateway.hs @@ -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 $ diff --git a/test/EmailTest.hs b/test/EmailTest.hs index 042b947..f88f1f4 100644 --- a/test/EmailTest.hs +++ b/test/EmailTest.hs @@ -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"] + ] + } -- 2.45.2