465 lines
16 KiB
Haskell
465 lines
16 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving
|
|
, UndecidableInstances
|
|
#-}
|
|
|
|
module Mail
|
|
( -- * Structured MIME emails
|
|
module Network.Mail.Mime
|
|
-- * MailT
|
|
, MailT, defMailT
|
|
, MailSmtpData(..), MailContext(..), MailLanguages(..)
|
|
, MonadMail(..)
|
|
, getMailMessageRender, getMailMsgRenderer
|
|
-- * YesodMail
|
|
, VerpMode(..)
|
|
, YesodMail(..)
|
|
, MailException(..)
|
|
-- * Monadically constructing Mail
|
|
, PrioritisedAlternatives
|
|
, ToMailPart(..)
|
|
, addAlternatives, provideAlternative, providePreferredAlternative
|
|
, addPart
|
|
, MonadHeader(..)
|
|
, MailHeader
|
|
, MailObjectId
|
|
, replaceMailHeader, addMailHeader, removeMailHeader
|
|
, replaceMailHeaderI, addMailHeaderI
|
|
, setSubjectI, setMailObjectId, setMailObjectId'
|
|
, setDate, setDateCurrent
|
|
, setMailSmtpData
|
|
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
|
|
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
|
|
|
|
import Network.Mail.Mime hiding (addPart, addAttachment)
|
|
import qualified Network.Mail.Mime as Mime (addPart)
|
|
|
|
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(..), MonadReader(..), MonadState(..), modify)
|
|
import Control.Monad.Fail
|
|
|
|
import GHC.Generics (Generic)
|
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
|
|
|
import Data.Sequence (Seq)
|
|
import qualified Data.Sequence as Seq
|
|
|
|
import Data.Set (Set)
|
|
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(..))
|
|
import Utils.Lens.TH
|
|
import Control.Lens hiding (from)
|
|
|
|
import Text.Blaze.Renderer.Utf8
|
|
|
|
import Data.UUID (UUID)
|
|
import qualified Data.UUID as UUID
|
|
import qualified Data.UUID.V4 as UUID
|
|
import Data.UUID.Cryptographic.ImplicitNamespace
|
|
|
|
import Data.Binary (Binary)
|
|
|
|
import GHC.TypeLits (KnownSymbol)
|
|
|
|
import Network.BSD (getHostName)
|
|
|
|
import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
|
|
import Data.Time.LocalTime (ZonedTime(..))
|
|
|
|
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 (Options(..))
|
|
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 GHC.Exts (IsList)
|
|
|
|
makeLenses_ ''Mail
|
|
makeLenses_ ''Part
|
|
|
|
|
|
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
|
|
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
|
|
, MonadIO, 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 Monoid (MailSmtpData) where
|
|
mempty = memptydefault
|
|
mappend = mappenddefault
|
|
|
|
newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
|
|
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
|
deriving newtype (FromJSON, ToJSON, IsList)
|
|
|
|
instance Default MailLanguages where
|
|
def = MailLanguages []
|
|
|
|
instance Hashable MailLanguages
|
|
|
|
data MailContext = MailContext
|
|
{ mcLanguages :: MailLanguages
|
|
, mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
} ''MailContext
|
|
|
|
instance Hashable MailContext
|
|
instance Default MailContext where
|
|
def = MailContext { mcLanguages = def
|
|
, mcDateTimeFormat = def
|
|
}
|
|
|
|
makeLenses_ ''MailContext
|
|
|
|
class (MonadHandler m, MonadState Mail m) => MonadMail m where
|
|
askMailLanguages :: m MailLanguages
|
|
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 <*> (mailLanguages <$> 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
|
|
, MonadBaseControl IO 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
|
|
, MonadBaseControl IO m
|
|
, MonadLogger m
|
|
) => MailContext -> MailT m a -> m a
|
|
mailT = defMailT
|
|
|
|
defaultMailLayout :: ( MonadHandler m
|
|
, HandlerSite m ~ site
|
|
) => WidgetT site IO () -> m Html
|
|
defaultMailLayout wgt = do
|
|
PageContent{..} <- liftHandlerT $ 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)
|
|
, MonadBaseControl IO m
|
|
, MonadLogger 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 Monoid (PrioritisedAlternatives m) where
|
|
mempty = memptydefault
|
|
mappend = mappenddefault
|
|
|
|
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 (HandlerT site IO) a) where
|
|
type MailPartReturn site (StateT Part (HandlerT site IO) a) = a
|
|
toMailPart = mapStateT liftHandlerT
|
|
|
|
instance YesodMail site => ToMailPart site LT.Text where
|
|
toMailPart text = do
|
|
_partType .= "text/plain; charset=utf-8"
|
|
_partEncoding .= QuotedPrintableText
|
|
_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 .= "text/html; charset=utf-8"
|
|
_partEncoding .= QuotedPrintableText
|
|
_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 .= "application/json; charset=utf-8"
|
|
_partEncoding .= QuotedPrintableText
|
|
_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 part = do
|
|
(ret, part') <- runStateT (toMailPart part) initialPart
|
|
modify . Mime.addPart $ pure part'
|
|
return ret
|
|
|
|
initialPart :: Part
|
|
initialPart = Part
|
|
{ partType = "text/plain"
|
|
, partEncoding = None
|
|
, partFilename = Nothing
|
|
, partHeaders = []
|
|
, partContent = mempty
|
|
}
|
|
|
|
|
|
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
|
|
|
|
setMailObjectId :: ( MonadHeader m
|
|
, YesodMail (HandlerSite m)
|
|
) => m MailObjectId
|
|
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
|
|
|
|
setMailObjectId' :: ( MonadHeader m
|
|
, YesodMail (HandlerSite m)
|
|
, MonadCrypto m
|
|
, HasCryptoUUID plain m
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
, KnownSymbol (CryptoIDNamespace UUID plain)
|
|
, Binary plain
|
|
) => plain -> m MailObjectId
|
|
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
|
|
|
|
|
|
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 "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time)
|
|
replaceMailHeader "Date" . Just $ pack timeStr
|
|
|
|
|
|
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
|
|
setMailSmtpData = do
|
|
Address _ from <- 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 }
|