553 lines
19 KiB
Haskell
553 lines
19 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving
|
|
, UndecidableInstances
|
|
#-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Mail
|
|
( -- * Structured MIME emails
|
|
module Network.Mail.Mime
|
|
-- * MailT
|
|
, MailT, defMailT
|
|
, MailSmtpData(..)
|
|
, _MailSmtpDataSet
|
|
, MailContext(..)
|
|
, MonadMail(..)
|
|
, getMailMessageRender, getMailMsgRenderer
|
|
-- * YesodMail
|
|
, VerpMode(..)
|
|
, YesodMail(..)
|
|
, MailException(..)
|
|
-- * Monadically constructing Mail
|
|
, PrioritisedAlternatives
|
|
, ToMailPart(..)
|
|
, addAlternatives, provideAlternative, providePreferredAlternative
|
|
, addPart, addPart', modifyPart, partIsAttachment
|
|
, MonadHeader(..)
|
|
, MailHeader
|
|
, MailObjectId
|
|
, replaceMailHeader, addMailHeader, removeMailHeader
|
|
, replaceMailHeaderI, addMailHeaderI
|
|
, setSubjectI
|
|
, setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
|
|
, setDate, setDateCurrent
|
|
, setMailSmtpData
|
|
, _addressName, _addressEmail
|
|
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
|
|
, _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
|
|
|
|
import Model.Types.Languages
|
|
|
|
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.RWS (RWST(..))
|
|
import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
|
|
import Control.Monad.Trans.Writer (execWriter, 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.Text as Text
|
|
|
|
import qualified Data.Foldable as Foldable
|
|
|
|
import qualified Data.Text.Lazy as LT
|
|
import qualified Data.Text.Lazy.Builder as LTB
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT)
|
|
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(..))
|
|
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 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 Control.Monad.Trans.Maybe (MaybeT(..))
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen)
|
|
import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
|
|
import qualified Data.ByteArray as ByteArray (convert)
|
|
import Crypto.MAC.HMAC (hmac, HMAC)
|
|
import Crypto.Hash.Algorithms (SHAKE128)
|
|
|
|
|
|
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
|
|
|
|
|
|
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 Text
|
|
} 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
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
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
|
|
}
|
|
|
|
makeLenses_ ''MailContext
|
|
|
|
class (MonadHandler m, MonadState Mail m) => MonadMail m where
|
|
askMailLanguages :: m Languages
|
|
askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
|
|
tellMailSmtpData :: MailSmtpData -> m ()
|
|
|
|
instance MonadHandler m => MonadMail (MailT m) where
|
|
askMailLanguages = view _mcLanguages
|
|
askMailDateTimeFormat = (view _mcDateTimeFormat ??)
|
|
tellMailSmtpData = tell
|
|
|
|
data VerpMode = VerpNone
|
|
| Verp { verpSeparator, verpAtReplacement :: Char }
|
|
deriving (Eq, Show, Read, Generic)
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
, sumEncoding = UntaggedValue
|
|
} ''VerpMode
|
|
|
|
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, Typeable)
|
|
|
|
instance Exception MailException
|
|
|
|
|
|
class Yesod site => YesodMail site where
|
|
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
|
|
defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
|
|
|
|
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
|
|
mailObjectIdDomain = pack <$> liftIO getHostName
|
|
|
|
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
|
|
|
|
mailVerp :: ( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
) => m VerpMode
|
|
mailVerp = return VerpNone
|
|
|
|
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, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)
|
|
mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
|
|
-- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
|
|
ret <$ case smtpData of
|
|
MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
|
|
MailSmtpData{ smtpRecipients }
|
|
| Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
|
|
MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
|
|
, smtpRecipients = (map unpack . toList -> recipients)
|
|
} -> mailSmtp $ \conn -> do
|
|
$logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
|
|
liftIO $ SMTP.sendMail
|
|
returnPath
|
|
recipients
|
|
mail'
|
|
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
|
|
mappend = (<>)
|
|
|
|
class YesodMail site => ToMailPart site a where
|
|
type MailPartReturn site a :: *
|
|
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 (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)
|
|
|
|
|
|
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
|
|
modifyHeaders :: (Headers -> Headers) -> m ()
|
|
objectIdHeader :: m MailHeader
|
|
|
|
instance MonadHandler m => MonadHeader (MailT m) where
|
|
modifyHeaders f = MailT . modify $ over _mailHeaders f
|
|
objectIdHeader = return "Message-ID"
|
|
|
|
instance MonadHandler m => MonadHeader (StateT Part m) where
|
|
modifyHeaders f = _partHeaders %= f
|
|
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
|
|
|
|
|
|
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"
|
|
|
|
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 :: HMAC (SHAKE128 64)
|
|
seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj
|
|
setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString)
|
|
|
|
|
|
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"
|
|
]
|
|
|
|
|
|
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m ()
|
|
setMailSmtpData = do
|
|
Address _ from <- maybeT (throwM MailNoSenderSpecified) $ asum
|
|
[ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
|
|
, use _mailFrom
|
|
]
|
|
recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
|
|
|
|
tell $ mempty { smtpRecipients = recps }
|
|
|
|
verpMode <- mailVerp
|
|
if
|
|
| Verp{..} <- verpMode
|
|
, [recp] <- Set.toList recps
|
|
-> let (user, domain) = Text.breakOn "@" from
|
|
verp = mconcat
|
|
[ user
|
|
, Text.singleton verpSeparator
|
|
, Text.replace "@" (Text.singleton verpAtReplacement) recp
|
|
, domain
|
|
]
|
|
in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
|
|
| otherwise
|
|
-> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
|