356 lines
12 KiB
Haskell
356 lines
12 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, GeneralizedNewtypeDeriving
|
|
, DerivingStrategies
|
|
, FlexibleInstances
|
|
, MultiParamTypeClasses
|
|
, UndecidableInstances
|
|
, DeriveGeneric
|
|
, TemplateHaskell
|
|
, OverloadedStrings
|
|
, RecordWildCards
|
|
, FlexibleContexts
|
|
, TypeFamilies
|
|
, ViewPatterns
|
|
, NamedFieldPuns
|
|
#-}
|
|
|
|
module Mail
|
|
( -- * Structured MIME emails
|
|
module Network.Mail.Mime
|
|
-- * MailT
|
|
, MailT, mailT
|
|
, MailSmtpData(..), MailLanguages(..)
|
|
, MonadMail(..)
|
|
-- * YesodMail
|
|
, VerpMode(..)
|
|
, YesodMail(..)
|
|
, MailException(..)
|
|
-- * Monadically constructing Mail
|
|
, PrioritisedAlternatives
|
|
, ToMailPart(..)
|
|
, addAlternatives, provideAlternative, providePreferredAlternative
|
|
, addPart
|
|
, MonadHeader(..)
|
|
, MailHeader
|
|
, MailObjectId
|
|
, replaceMailHeader, addMailHeader, removeMailHeader
|
|
, replaceMailHeaderI, addMailHeaderI
|
|
, setSubjectI, setMailObjectId, setMailObjectId'
|
|
, setDateCurrent
|
|
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
|
|
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
|
|
import qualified ClassyPrelude.Yesod as Yesod (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(..), execRWST)
|
|
import Control.Monad.Trans.State (StateT(..), execStateT, State, 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.Foldable as Foldable
|
|
|
|
import qualified Data.Text.Lazy as LT
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
|
|
import Utils.Lens.TH
|
|
import Control.Lens
|
|
|
|
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 Data.Time.Format
|
|
|
|
import Network.HaskellNet.SMTP (SMTPConnection)
|
|
import qualified Network.HaskellNet.SMTP as SMTP
|
|
|
|
import qualified Text.Hamlet as Shakespeare (Translate, Render)
|
|
|
|
import Data.Aeson (Options(..))
|
|
import Data.Aeson.TH
|
|
import Utils.PathPiece (splitCamel)
|
|
|
|
|
|
makeLenses_ ''Mail
|
|
makeLenses_ ''Part
|
|
|
|
|
|
newtype MailT m a = MailT { unMailT :: RWST MailLanguages 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 MailLanguages
|
|
)
|
|
|
|
instance (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)
|
|
deriving newtype (FromJSON, ToJSON)
|
|
|
|
instance Default MailLanguages where
|
|
def = MailLanguages []
|
|
|
|
class (MonadHandler m, MonadState Mail m) => MonadMail m where
|
|
askMailLanguages :: m MailLanguages
|
|
tellMailSmtpData :: MailSmtpData -> m ()
|
|
|
|
instance MonadHandler m => MonadMail (MailT m) where
|
|
askMailLanguages = ask
|
|
tellMailSmtpData = tell
|
|
|
|
data VerpMode = VerpNone
|
|
| Verp { verpSeparator, verpAtReplacement :: Char }
|
|
deriving (Eq, Show, Read)
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
|
, sumEncoding = UntaggedValue
|
|
} ''VerpMode
|
|
|
|
getMessageRender :: ( MonadMail m
|
|
, HandlerSite m ~ site
|
|
, RenderMessage site msg
|
|
) => m (msg -> Text)
|
|
getMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
|
|
|
|
|
|
data MailException = MailNotAvailable
|
|
| MailNoSenderSpecified
|
|
| MailNoRecipientsSpecified
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance Exception MailException
|
|
|
|
|
|
class 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
|
|
, YesodMail (HandlerSite m)
|
|
, MonadBaseControl IO m
|
|
) => MailLanguages -- ^ Languages in priority order
|
|
-> MailT m a
|
|
-> m a
|
|
mailT ls (MailT mail) = do
|
|
fromAddress <- defaultFromAddress
|
|
(ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
|
|
mail' <- liftIO $ LBS.toStrict <$> renderMail' 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 $ liftIO . SMTP.sendMail
|
|
returnPath
|
|
recipients
|
|
mail'
|
|
|
|
|
|
data PrioritisedAlternatives m = PrioritisedAlternatives
|
|
{ preferredAlternative :: Last (m Part)
|
|
, otherAlternatives :: Seq (m Part)
|
|
} deriving (Generic)
|
|
|
|
instance Monoid (PrioritisedAlternatives m) where
|
|
mempty = memptydefault
|
|
mappend = mappenddefault
|
|
|
|
class ToMailPart site a where
|
|
toMailPart :: (MonadHandler m, HandlerSite m ~ site) => a -> StateT Part m ()
|
|
|
|
instance ToMailPart site (StateT Part (HandlerT site IO) ()) where
|
|
toMailPart = mapStateT liftHandlerT
|
|
|
|
instance ToMailPart site LT.Text where
|
|
toMailPart text = do
|
|
_partType .= "text/plain"
|
|
_partEncoding .= QuotedPrintableText
|
|
_partContent .= encodeUtf8 text
|
|
|
|
instance ToMailPart site Text where
|
|
toMailPart = toMailPart . LT.fromStrict
|
|
|
|
instance ToMailPart site Html where
|
|
toMailPart html = do
|
|
_partType .= "text/html"
|
|
_partEncoding .= QuotedPrintableText
|
|
_partContent .= renderMarkup html
|
|
|
|
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Shakespeare.Translate msg -> a) where
|
|
toMailPart act = do
|
|
mr <- Yesod.getMessageRender
|
|
toMailPart $ act (toHtml . mr)
|
|
|
|
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site ((msg -> Text) -> a) where
|
|
toMailPart act = do
|
|
mr <- Yesod.getMessageRender
|
|
toMailPart $ act mr
|
|
|
|
instance ToMailPart site a => ToMailPart site (Shakespeare.Render (Route site) -> a) where
|
|
toMailPart act = do
|
|
ur <- getUrlRenderParams
|
|
toMailPart $ act ur
|
|
|
|
|
|
addAlternatives :: Monad m
|
|
=> Writer (PrioritisedAlternatives m) ()
|
|
-> MailT m ()
|
|
addAlternatives provided = MailT $ do
|
|
let PrioritisedAlternatives{..} = execWriter provided
|
|
alternatives <- lift . sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
|
|
modify $ Mime.addPart alternatives
|
|
|
|
provideAlternative, providePreferredAlternative
|
|
:: (MonadHandler 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 :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) => a -> MailT m ()
|
|
addPart part = MailT $ do
|
|
part' <- lift $ execStateT (toMailPart part) initialPart
|
|
modify . Mime.addPart $ pure part'
|
|
|
|
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 =<< (getMessageRender <*> pure msg)
|
|
|
|
|
|
setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
|
|
setSubjectI = replaceMailHeaderI "Subject"
|
|
|
|
setMailObjectUUID :: (MonadHandler m, YesodMail (HandlerSite m)) => UUID -> MailT m MailObjectId
|
|
setMailObjectUUID uuid = do
|
|
domain <- mailObjectIdDomain
|
|
oidHeader <- objectIdHeader
|
|
let objectId = UUID.toText uuid <> "@" <> domain
|
|
replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
|
|
return objectId
|
|
|
|
setMailObjectId :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m MailObjectId
|
|
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
|
|
|
|
setMailObjectId' :: ( MonadHandler m
|
|
, YesodMail (HandlerSite m)
|
|
, MonadCrypto m
|
|
, HasCryptoUUID plain m
|
|
, MonadCryptoKey m ~ CryptoIDKey
|
|
, KnownSymbol (CryptoIDNamespace UUID plain)
|
|
, Binary plain
|
|
) => plain -> MailT m MailObjectId
|
|
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
|
|
|
|
|
|
setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
|
|
setDateCurrent = do
|
|
now <- liftIO getCurrentTime
|
|
tz <- mailDateTZ
|
|
let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz now) (timeZoneForUTCTime tz now)
|
|
replaceMailHeader "Date" . Just $ pack timeStr
|