638 lines
24 KiB
Haskell
638 lines
24 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving
|
|
, UndecidableInstances
|
|
#-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Mail
|
|
( -- * Structured MIME emails
|
|
module Network.Mail.Mime
|
|
-- * MailT
|
|
, MailT, defMailT
|
|
, MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
|
|
, _MailSmtpDataSet
|
|
, MailContext(..)
|
|
, MonadMail(..)
|
|
, getMailMessageRender, getMailMsgRenderer
|
|
-- * YesodMail
|
|
, YesodMail(..)
|
|
, MailException(..)
|
|
-- * Monadically constructing Mail
|
|
, PrioritisedAlternatives
|
|
, ToMailPart(..)
|
|
, NamedMailPart(..)
|
|
, addAlternatives, provideAlternative, providePreferredAlternative
|
|
, addPart, addPart', modifyPart, partIsAttachment
|
|
, MonadHeader(..)
|
|
, MailHeader
|
|
, MailObjectId
|
|
, replaceMailHeader, addMailHeader, removeMailHeader, getMailHeaders, lookupMailHeader, mapMailHeader
|
|
, replaceMailHeaderI, addMailHeaderI
|
|
, setSubjectI, mapSubject
|
|
, setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
|
|
, getMailObjectId
|
|
, setDate, setDateCurrent
|
|
, getMailSmtpData
|
|
, _addressName, _addressEmail
|
|
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
|
|
, _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
|
|
|
|
import Data.Kind (Type)
|
|
|
|
import Model.Types.Languages
|
|
import Model.Types.Csv
|
|
import Model.Types.File
|
|
|
|
import Network.Mail.Mime hiding (addPart, addAttachment)
|
|
import qualified Network.Mail.Mime as Mime (addPart)
|
|
|
|
import Settings.Mime
|
|
|
|
import Data.Monoid (Last(..))
|
|
-- import Control.Monad.Trans.Maybe (MaybeT(..))
|
|
import Control.Monad.Trans.RWS (RWST(..))
|
|
import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
|
|
import Control.Monad.Trans.Writer (execWriter, execWriterT, Writer)
|
|
import Control.Monad.RWS.Class (MonadWriter(..), MonadState(..), modify)
|
|
import Control.Monad.Fail
|
|
import Control.Monad.Base
|
|
import Control.Monad.Catch
|
|
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
import qualified Data.Sequence as Seq
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Data.Foldable as Foldable
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as LT
|
|
import qualified Data.Text.Lazy.Builder as LTB
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import qualified Data.ByteString as BS
|
|
|
|
import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc, maybeT, guardM, adjustAssoc)
|
|
import Utils.Lens.TH
|
|
|
|
import Control.Lens hiding (from)
|
|
import Control.Lens.Extras (is)
|
|
|
|
import Text.Blaze.Renderer.Utf8
|
|
|
|
import Data.UUID (UUID)
|
|
import qualified Data.UUID as UUID
|
|
import Data.UUID.Cryptographic.ImplicitNamespace
|
|
|
|
import Data.Binary (Binary)
|
|
import qualified Data.Binary as Binary
|
|
|
|
import "network-bsd" Network.BSD (getHostName)
|
|
|
|
import Data.Time.Zones (utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
|
|
import Data.Time.LocalTime (ZonedTime(..), TimeZone(..), utcToZonedTime, utc)
|
|
import Data.Time.Format (rfc822DateFormat)
|
|
|
|
import Network.HaskellNet.SMTP (SMTPConnection)
|
|
import qualified Network.HaskellNet.SMTP as SMTP
|
|
|
|
import qualified Text.Hamlet as Hamlet (Translate)
|
|
import qualified Text.Shakespeare as Shakespeare (RenderUrl)
|
|
|
|
import qualified Data.Aeson as Aeson
|
|
import qualified Data.Aeson.Encode.Pretty as Aeson
|
|
import qualified Data.Yaml as Yaml
|
|
import Data.Aeson.TH
|
|
import Utils.PathPiece (splitCamel)
|
|
import Utils.DateTime
|
|
|
|
import Data.Universe.Instances.Reverse ()
|
|
import Data.Universe.Instances.Reverse.JSON ()
|
|
import Data.Universe.Instances.Reverse.Hashable ()
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Control.Monad.Random (MonadRandom(..))
|
|
import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
|
|
import qualified Data.ByteArray as ByteArray (convert)
|
|
import Crypto.MAC.KMAC (KMAC)
|
|
import qualified Crypto.MAC.KMAC as KMAC
|
|
import Crypto.Hash.Algorithms (SHAKE128)
|
|
|
|
import Language.Haskell.TH (nameBase)
|
|
|
|
import Network.Mail.Mime.Instances()
|
|
|
|
import Data.Char (isLatin1)
|
|
import Data.Text.Lazy.Encoding (decodeUtf8')
|
|
import System.FilePath (takeFileName)
|
|
import Network.HTTP.Types.Header (hETag)
|
|
import Web.HttpApiData (ToHttpApiData(toHeader))
|
|
|
|
|
|
makeLenses_ ''Address
|
|
makeLenses_ ''Mail
|
|
makeLenses_ ''Part
|
|
|
|
_partFilename :: Traversal' Part Text
|
|
_partFilename = _partDisposition . dispositionFilename
|
|
where
|
|
dispositionFilename :: Traversal' Disposition Text
|
|
dispositionFilename f (AttachmentDisposition t) = AttachmentDisposition <$> f t
|
|
dispositionFilename f (InlineDisposition t) = InlineDisposition <$> f t
|
|
dispositionFilename _ DefaultDisposition = pure DefaultDisposition
|
|
|
|
_mailHeader :: CI ByteString -> Traversal' Mail Text
|
|
_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
|
|
|
|
_mailReplyTo' :: Lens' Mail Text
|
|
_mailReplyTo' = _mailHeaders . _headerReplyTo'
|
|
|
|
_headerReplyTo' :: Lens' Headers Text
|
|
-- Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
|
|
_headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
|
|
where
|
|
replyto = "Reply-To"
|
|
|
|
_mailReplyTo :: Lens' Mail Address
|
|
_mailReplyTo = _mailHeaders . _headerReplyTo
|
|
|
|
_headerReplyTo :: Lens' Headers Address
|
|
-- Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
|
|
_headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
|
|
where
|
|
replyto = "Reply-To"
|
|
-- _addressEmail :: Lens' Address Text might help to simplify this code?
|
|
|
|
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
|
|
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
|
|
, MonadIO, MonadLogger, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
|
|
, MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext
|
|
)
|
|
|
|
instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
|
|
type MonadCryptoKey (MailT m) = CryptoIDKey
|
|
cryptoIDKey f = lift (cryptoIDKey return) >>= f
|
|
|
|
data MailSmtpData = MailSmtpData
|
|
{ smtpEnvelopeFrom :: Last Text
|
|
, smtpRecipients :: Set Address
|
|
} deriving (Eq, Ord, Show, Read, Generic)
|
|
|
|
instance Semigroup MailSmtpData where
|
|
(<>) = mappenddefault
|
|
|
|
instance Monoid MailSmtpData where
|
|
mempty = memptydefault
|
|
mappend = (<>)
|
|
|
|
_MailSmtpDataSet :: Getter MailSmtpData Bool
|
|
_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
|
|
[ is (_Wrapped . _Nothing) smtpEnvelopeFrom
|
|
, Set.null smtpRecipients
|
|
]
|
|
|
|
|
|
data MailContext = MailContext
|
|
{ mcLanguages :: Languages
|
|
, mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
|
|
, mcCsvOptions :: CsvOptions
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
} ''MailContext
|
|
|
|
instance Hashable MailContext
|
|
instance NFData MailContext
|
|
instance Default MailContext where
|
|
def = MailContext
|
|
{ mcLanguages = def
|
|
, mcDateTimeFormat = def
|
|
, mcCsvOptions = def
|
|
}
|
|
|
|
makeLenses_ ''MailContext
|
|
|
|
makeLenses_ ''MailSmtpData
|
|
|
|
class (MonadHandler m, MonadState Mail m) => MonadMail m where
|
|
askMailLanguages :: m Languages
|
|
askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
|
|
askMailCsvOptions :: m CsvOptions
|
|
tellMailSmtpData :: MailSmtpData -> m ()
|
|
|
|
instance MonadHandler m => MonadMail (MailT m) where
|
|
askMailLanguages = view _mcLanguages
|
|
askMailDateTimeFormat = (view _mcDateTimeFormat ??)
|
|
askMailCsvOptions = view _mcCsvOptions
|
|
tellMailSmtpData = tell
|
|
|
|
getMailMessageRender :: ( MonadMail m
|
|
, HandlerSite m ~ site
|
|
, RenderMessage site msg
|
|
) => m (msg -> Text)
|
|
getMailMessageRender = renderMessage <$> getYesod <*> (view _Wrapped <$> askMailLanguages)
|
|
|
|
getMailMsgRenderer :: forall site m.
|
|
( MonadMail m
|
|
, HandlerSite m ~ site
|
|
) => m (MsgRendererS site)
|
|
getMailMsgRenderer = do
|
|
mr <- getMailMessageRender
|
|
return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text)
|
|
|
|
|
|
data MailException = MailNotAvailable
|
|
| MailNoSenderSpecified
|
|
| MailNoRecipientsSpecified
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
instance Exception MailException
|
|
|
|
|
|
class Yesod site => YesodMail site where
|
|
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
|
defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
|
|
|
|
envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
|
envelopeFromAddress = addressEmail <$> defaultFromAddress
|
|
|
|
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
|
mailObjectIdDomain = pack <$> liftIO getHostName
|
|
|
|
-- | Use replyTo instead for all senders within mailObjectIdDomain
|
|
useReplyToInstead :: (MonadHandler m, HandlerSite m ~ site) => m Bool
|
|
useReplyToInstead = return True -- not changeing the sender is the save choice
|
|
|
|
mailRerouteTo :: (MonadHandler m, HandlerSite m ~ site) => m (Maybe Address)
|
|
mailRerouteTo = return Nothing -- all mail will be sent to this address instead, if set (for test-instances)
|
|
|
|
mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
|
|
mailDateTZ = return utcTZ
|
|
|
|
mailSmtp :: ( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
, MonadUnliftIO m
|
|
, MonadThrow m
|
|
) => (SMTPConnection -> m a) -> m a
|
|
mailSmtp _ = throwM MailNotAvailable
|
|
|
|
mailT :: ( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
, MonadUnliftIO m
|
|
, MonadLogger m
|
|
, MonadThrow m
|
|
) => MailContext -> MailT m a -> m a
|
|
|
|
default mailT :: ( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
, MonadUnliftIO m
|
|
, MonadThrow m
|
|
) => MailContext -> MailT m a -> m a
|
|
mailT = defMailT
|
|
|
|
defaultMailLayout :: ( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
)
|
|
=> WidgetFor site () -> m Html
|
|
defaultMailLayout wgt = do
|
|
PageContent{..} <- liftHandler $ widgetToPageContent wgt
|
|
msgs <- getMessages
|
|
withUrlRenderer [hamlet|
|
|
$newline never
|
|
$doctype 5
|
|
<html>
|
|
<head>
|
|
<title>#{pageTitle}
|
|
^{pageHead}
|
|
<body>
|
|
$forall (status, msg) <- msgs
|
|
<p class="message #{status}">#{msg}
|
|
^{pageBody}
|
|
|]
|
|
|
|
defMailT :: ( MonadHandler m
|
|
, YesodMail (HandlerSite m)
|
|
, MonadUnliftIO m
|
|
, MonadThrow m
|
|
) => MailContext
|
|
-> MailT m a
|
|
-> m a
|
|
defMailT ls (MailT mailC) = do
|
|
fromAddress <- defaultFromAddress
|
|
(ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
|
|
mail1 <- maybeT (return mail0) $ do
|
|
guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
|
|
domain <- mailObjectIdDomain
|
|
let sender = mail0 ^. _mailFrom
|
|
isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
|
|
$logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
|
|
guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
|
|
return $ mail0
|
|
& _mailFrom .~ fromAddress
|
|
& _mailReplyTo .~ sender
|
|
mailRerouteTo' <- mailRerouteTo
|
|
let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on enveloper, if rerouting is active
|
|
switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } )
|
|
switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)]
|
|
mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2
|
|
$logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail3
|
|
ret <$ case smtpData1 of
|
|
MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
|
|
MailSmtpData{ smtpRecipients }
|
|
| Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
|
|
MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
|
|
, smtpRecipients = (map (unpack . addressEmail) . toList -> recipients)
|
|
} -> mailSmtp $ \conn -> do
|
|
$logInfoS "Mail" $ "Submitting email: " <> tshow smtpData1
|
|
liftIO $ SMTP.sendMail
|
|
returnPath
|
|
recipients
|
|
mail3
|
|
conn
|
|
|
|
|
|
data PrioritisedAlternatives m = PrioritisedAlternatives
|
|
{ preferredAlternative :: Last (m Part)
|
|
, otherAlternatives :: Seq (m Part)
|
|
} deriving (Generic)
|
|
|
|
instance Semigroup (PrioritisedAlternatives m) where
|
|
(<>) = mappenddefault
|
|
|
|
instance Monoid (PrioritisedAlternatives m) where
|
|
mempty = memptydefault
|
|
|
|
class YesodMail site => ToMailPart site a where
|
|
type MailPartReturn site a :: Type
|
|
type MailPartReturn site a = ()
|
|
toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
|
|
|
|
instance YesodMail site => ToMailPart site (StateT Part (HandlerFor site) a) where
|
|
type MailPartReturn site (StateT Part (HandlerFor site) a) = a
|
|
toMailPart = mapStateT liftHandler
|
|
|
|
instance YesodMail site => ToMailPart site LT.Text where
|
|
toMailPart text = do
|
|
_partType .= decodeUtf8 typePlain
|
|
_partEncoding .= QuotedPrintableText
|
|
_partContent .= PartContent (encodeUtf8 text)
|
|
|
|
instance YesodMail site => ToMailPart site Text where
|
|
toMailPart = toMailPart . LT.fromStrict
|
|
|
|
instance YesodMail site => ToMailPart site LTB.Builder where
|
|
toMailPart = toMailPart . LTB.toLazyText
|
|
|
|
instance YesodMail site => ToMailPart site Html where
|
|
toMailPart html = do
|
|
_partType .= decodeUtf8 typeHtml
|
|
_partEncoding .= QuotedPrintableText
|
|
_partContent .= PartContent (renderMarkup html)
|
|
|
|
instance YesodMail site => ToMailPart site PureFile where
|
|
toMailPart file@File{fileTitle, fileModified} = do
|
|
_partDisposition .= AttachmentDisposition (pack $ takeFileName fileTitle)
|
|
_partType .= decodeUtf8 (mimeLookup $ pack fileTitle)
|
|
let
|
|
content :: LBS.ByteString
|
|
content = file ^. _pureFileContent . _Just
|
|
isLatin = either (const False) (all isLatin1) $ decodeUtf8' content
|
|
_partEncoding .= bool Base64 QuotedPrintableText isLatin
|
|
_partContent .= PartContent content
|
|
forM_ (file ^. _FileReference . _1 . _fileReferenceContent) $ \fRefContent ->
|
|
replaceMailHeader (CI.original hETag) . Just . decodeUtf8 . toHeader $ etagFileReference # fRefContent
|
|
replaceMailHeader (CI.original hLastModified) . Just . pack . formatTime defaultTimeLocale rfc822DateFormat $ utcToZonedTime utc fileModified
|
|
|
|
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
|
|
type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
|
|
toMailPart act = do
|
|
mr <- lift getMailMessageRender
|
|
toMailPart $ act (toHtml . mr)
|
|
|
|
instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
|
|
type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a
|
|
toMailPart act = do
|
|
mr <- lift getMailMsgRenderer
|
|
toMailPart $ act mr
|
|
|
|
instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where
|
|
type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a
|
|
toMailPart act = do
|
|
ur <- getUrlRenderParams
|
|
toMailPart $ act ur
|
|
|
|
instance YesodMail site => ToMailPart site Aeson.Value where
|
|
toMailPart val = do
|
|
_partType .= decodeUtf8 typeJson
|
|
_partEncoding .= QuotedPrintableText
|
|
_partContent .= PartContent (Aeson.encodePretty val)
|
|
|
|
instance YesodMail site => ToMailPart site YamlValue where
|
|
toMailPart val = do
|
|
_partType .= "text/vnd.yaml"
|
|
_partEncoding .= QuotedPrintableText
|
|
_partContent .= PartContent (fromStrict $ Yaml.encode val)
|
|
|
|
|
|
data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
|
|
|
|
instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
|
|
type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
|
|
toMailPart nmp = do
|
|
r <- toMailPart $ namedPart nmp
|
|
_partDisposition .= disposition nmp
|
|
return r
|
|
|
|
|
|
addAlternatives :: (MonadMail m)
|
|
=> Writer (PrioritisedAlternatives m) ()
|
|
-> m ()
|
|
addAlternatives provided = do
|
|
let PrioritisedAlternatives{..} = execWriter provided
|
|
alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
|
|
modify $ Mime.addPart alternatives
|
|
|
|
provideAlternative, providePreferredAlternative
|
|
:: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
|
|
=> a
|
|
-> Writer (PrioritisedAlternatives m) ()
|
|
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
|
|
providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
|
|
|
|
addPart :: ( MonadMail m
|
|
, HandlerSite m ~ site
|
|
, ToMailPart site a
|
|
) => a -> m (MailPartReturn site a)
|
|
addPart = addPart' . toMailPart
|
|
|
|
addPart' :: MonadMail m
|
|
=> StateT Part m a
|
|
-> m a
|
|
addPart' part = do
|
|
(ret, part') <- runStateT part initialPart
|
|
modify . Mime.addPart $ pure part'
|
|
return ret
|
|
|
|
initialPart :: Part
|
|
initialPart = Part
|
|
{ partType = decodeUtf8 defaultMimeType
|
|
, partEncoding = Base64
|
|
, partDisposition = DefaultDisposition
|
|
, partHeaders = []
|
|
, partContent = PartContent mempty
|
|
}
|
|
|
|
modifyPart :: (MonadMail m, HandlerSite m ~ site, YesodMail site)
|
|
=> StateT Part (HandlerFor site) a
|
|
-> StateT Part m a
|
|
modifyPart = toMailPart
|
|
|
|
partIsAttachment :: (Textual t, MonadMail m, HandlerSite m ~ site, YesodMail site)
|
|
=> t
|
|
-> StateT Part m ()
|
|
partIsAttachment (repack -> fName) = modifyPart $ _partDisposition .= AttachmentDisposition fName
|
|
|
|
|
|
class MonadHandler m => MonadHeader m where
|
|
stateHeaders :: forall a. (Headers -> (a, Headers)) -> m a
|
|
modifyHeaders :: (Headers -> Headers) -> m ()
|
|
modifyHeaders f = stateHeaders $ ((), ) . f
|
|
objectIdHeader :: m MailHeader
|
|
|
|
instance MonadHandler m => MonadHeader (MailT m) where
|
|
stateHeaders = MailT . zoom _mailHeaders . state
|
|
objectIdHeader = return "Message-ID"
|
|
|
|
instance MonadHandler m => MonadHeader (StateT Part m) where
|
|
stateHeaders = zoom _partHeaders . state
|
|
objectIdHeader = return "Content-ID"
|
|
|
|
|
|
type MailHeader = ByteString
|
|
type MailObjectId = Text
|
|
|
|
|
|
replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m ()
|
|
replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC
|
|
|
|
addMailHeader :: MonadHeader m => MailHeader -> Text -> m ()
|
|
addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c)
|
|
|
|
removeMailHeader :: MonadHeader m => MailHeader -> m ()
|
|
removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
|
|
|
|
getMailHeaders :: MonadHeader m => MailHeader -> m [Text]
|
|
getMailHeaders header = stateHeaders $ \hdrs -> (, hdrs) . map (view _2) $ filter (views _1 (== header)) hdrs
|
|
|
|
lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
|
|
lookupMailHeader = fmap listToMaybe . getMailHeaders
|
|
|
|
mapMailHeader :: MonadHeader m => MailHeader -> (Text -> Text) -> m ()
|
|
mapMailHeader header f = modifyHeaders $ adjustAssoc f header
|
|
|
|
replaceMailHeaderI :: ( RenderMessage site msg
|
|
, MonadMail m
|
|
, HandlerSite m ~ site
|
|
, MonadHeader m
|
|
) => MailHeader -> msg -> m ()
|
|
replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg
|
|
|
|
addMailHeaderI :: ( RenderMessage site msg
|
|
, MonadMail m
|
|
, HandlerSite m ~ site
|
|
, MonadHeader m
|
|
) => MailHeader -> msg -> m ()
|
|
addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg)
|
|
|
|
|
|
setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
|
|
setSubjectI = replaceMailHeaderI "Subject"
|
|
|
|
mapSubject :: MonadHeader m => (Text -> Text) -> m ()
|
|
mapSubject = mapMailHeader "Subject"
|
|
|
|
setMailObjectUUID :: ( MonadHeader m
|
|
, YesodMail (HandlerSite m)
|
|
) => UUID -> m MailObjectId
|
|
setMailObjectUUID uuid = do
|
|
domain <- mailObjectIdDomain
|
|
oidHeader <- objectIdHeader
|
|
let objectId = UUID.toText uuid <> "@" <> domain
|
|
replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
|
|
return objectId
|
|
|
|
setMailObjectIdRandom :: ( MonadHeader m
|
|
, YesodMail (HandlerSite m)
|
|
) => m MailObjectId
|
|
setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom
|
|
|
|
setMailObjectIdCrypto :: ( MonadHeader m
|
|
, YesodMail (HandlerSite m)
|
|
, HasCryptoUUID plain m
|
|
) => plain -> m MailObjectId
|
|
setMailObjectIdCrypto = setMailObjectUUID . ciphertext <=< encrypt
|
|
|
|
setMailObjectIdPseudorandom :: ( MonadHeader m
|
|
, YesodMail (HandlerSite m)
|
|
, Binary obj
|
|
, MonadSecretBox m
|
|
) => obj -> m MailObjectId
|
|
-- | Designed to leak no information about the `secretBoxKey` or the given object
|
|
setMailObjectIdPseudorandom obj = do
|
|
sbKey <- secretBoxKey
|
|
let
|
|
seed :: KMAC (SHAKE128 128)
|
|
seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj
|
|
setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString)
|
|
|
|
getMailObjectId :: ( MonadHeader m, YesodMail (HandlerSite m) ) => m (Maybe MailObjectId)
|
|
getMailObjectId = fmap (fmap stripBrackets) . lookupMailHeader =<< objectIdHeader
|
|
where stripBrackets val = fromMaybe val $
|
|
Text.stripSuffix ">" =<< Text.stripPrefix "<" val
|
|
|
|
|
|
setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
|
|
setDateCurrent = setDate =<< liftIO getCurrentTime
|
|
|
|
setDate :: (MonadHandler m, YesodMail (HandlerSite m)) => UTCTime -> MailT m ()
|
|
setDate time = do
|
|
tz <- mailDateTZ
|
|
let timeStr = formatTime defaultTimeLocale rfc822DateFormat $ ZonedTime (utcToLocalTimeTZ tz time) (rfc822zone $ timeZoneForUTCTime tz time)
|
|
replaceMailHeader "Date" . Just $ pack timeStr
|
|
where
|
|
rfc822zone tz'
|
|
| tz' `elem` rfc822zones = tz'
|
|
| otherwise = tz' { timeZoneName = "" }
|
|
rfc822zones =
|
|
[ TimeZone 0 False "UT"
|
|
, TimeZone 0 False "GMT"
|
|
, TimeZone (-5 * 60) False "EST"
|
|
, TimeZone (-4 * 60) True "EDT"
|
|
, TimeZone (-6 * 60) False "CST"
|
|
, TimeZone (-5 * 60) True "CDT"
|
|
, TimeZone (-7 * 60) False "MST"
|
|
, TimeZone (-6 * 60) True "MDT"
|
|
, TimeZone (-8 * 60) False "PST"
|
|
, TimeZone (-7 * 60) True "PDT"
|
|
]
|
|
|
|
|
|
getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData
|
|
getMailSmtpData = execWriterT $ do
|
|
from <- envelopeFromAddress
|
|
recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
|
|
|
|
tell $ mempty
|
|
{ smtpRecipients = recps
|
|
, smtpEnvelopeFrom = Last $ Just from
|
|
}
|