~singpolyma/cheogram-smtp

ccfeda0ae8015c99e370c5e76ff2af16731cef07 β€” Stephen Paul Weber 3 years ago 7118cae
Add Date header, from delayed deliver if present else now
5 files changed, 60 insertions(+), 4 deletions(-)

M Email.hs
M Util.hs
M cheogram-smtp.cabal
M gateway.hs
M test/EmailTest.hs
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"]
		]
	}