149 lines
5.0 KiB
Haskell
149 lines
5.0 KiB
Haskell
module Handler.Utils.Mail
|
|
( addRecipientsDB
|
|
, userAddress, userAddressFrom
|
|
, userMailT
|
|
, addFileDB
|
|
, addHtmlMarkdownAlternatives
|
|
, addHtmlMarkdownAlternatives'
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils.Pandoc
|
|
import Handler.Utils.Files
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import qualified Text.Pandoc as P
|
|
|
|
import qualified Text.Hamlet as Hamlet (Translate)
|
|
import qualified Text.Shakespeare as Shakespeare (RenderUrl)
|
|
|
|
|
|
addRecipientsDB :: ( MonadMail m
|
|
, HandlerSite m ~ UniWorX
|
|
) => [Filter User] -> m ()
|
|
-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
|
|
addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
|
|
where
|
|
addRecipient (Entity _ User{userEmail, userDisplayName}) = do
|
|
let addr = Address (Just userDisplayName) $ CI.original userEmail
|
|
_mailTo %= flip snoc addr
|
|
|
|
userAddressFrom :: User -> Address
|
|
-- ^ Format an e-mail address suitable for usage in a @From@-header
|
|
--
|
|
-- Uses `userDisplayEmail`
|
|
userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
|
|
|
|
userAddress :: User -> Address
|
|
-- ^ Format an e-mail address suitable for usage as a recipient
|
|
--
|
|
-- Uses `userEmail`
|
|
userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
|
|
|
|
userMailT :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadThrow m
|
|
, MonadUnliftIO m
|
|
) => UserId -> MailT m a -> m a
|
|
userMailT uid mAct = do
|
|
user@User
|
|
{ userLanguages
|
|
, userDateTimeFormat
|
|
, userDateFormat
|
|
, userTimeFormat
|
|
, userCsvOptions
|
|
} <- liftHandler . runDB $ getJust uid
|
|
let
|
|
ctx = MailContext
|
|
{ mcLanguages = fromMaybe def userLanguages
|
|
, mcDateTimeFormat = \case
|
|
SelFormatDateTime -> userDateTimeFormat
|
|
SelFormatDate -> userDateFormat
|
|
SelFormatTime -> userTimeFormat
|
|
, mcCsvOptions = userCsvOptions
|
|
}
|
|
mailT ctx $ do
|
|
_mailTo .= pure (userAddress user)
|
|
mAct
|
|
|
|
addFileDB :: ( MonadMail m
|
|
, HandlerSite m ~ UniWorX
|
|
) => FileReference -> m (Maybe MailObjectId)
|
|
addFileDB fRef = runMaybeT $ do
|
|
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent'} <- return $ sourceFile fRef
|
|
fileContent <- liftHandler . runDB . runConduit $ fileContent' .| C.sinkLazy
|
|
lift . addPart $ do
|
|
_partType .= decodeUtf8 (mimeLookup fileName)
|
|
_partEncoding .= Base64
|
|
_partDisposition .= AttachmentDisposition fileName
|
|
_partContent .= PartContent fileContent
|
|
setMailObjectIdPseudorandom (fileName, fileContent) :: StateT Part (HandlerFor UniWorX) MailObjectId
|
|
|
|
|
|
class YesodMail site => ToMailHtml site a where
|
|
toMailHtml :: (MonadMail m, HandlerSite m ~ site) => a -> m Html
|
|
|
|
instance YesodMail site => ToMailHtml site Html where
|
|
toMailHtml = return
|
|
|
|
instance (ToMailHtml site a, RenderMessage site msg) => ToMailHtml site (Hamlet.Translate msg -> a) where
|
|
toMailHtml act = do
|
|
mr <- getMailMessageRender
|
|
toMailHtml $ act (toHtml . mr)
|
|
|
|
instance (ToMailHtml site a, site ~ site') => ToMailHtml site (MsgRendererS site' -> a) where
|
|
toMailHtml act = do
|
|
mr <- getMailMsgRenderer
|
|
toMailHtml $ act mr
|
|
|
|
instance ToMailHtml site a => ToMailHtml site (Shakespeare.RenderUrl (Route site) -> a) where
|
|
toMailHtml act = do
|
|
ur <- getUrlRenderParams
|
|
toMailHtml $ act ur
|
|
|
|
|
|
addHtmlMarkdownAlternatives :: ( MonadMail m
|
|
, ToMailPart (HandlerSite m) Html
|
|
, ToMailHtml (HandlerSite m) a
|
|
)
|
|
=> a -> m ()
|
|
addHtmlMarkdownAlternatives html' = do
|
|
html <- toMailHtml html'
|
|
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
|
|
|
|
addAlternatives $ do
|
|
providePreferredAlternative html
|
|
whenIsJust markdown provideAlternative
|
|
where
|
|
writerOptions = markdownWriterOptions
|
|
{ P.writerReferenceLinks = True
|
|
}
|
|
|
|
{-
|
|
addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
|
|
, MonadMail m
|
|
, ToMailPart (HandlerSite m) Html
|
|
, ToMailHtml (HandlerSite m) a
|
|
) => a -> m ()
|
|
addHtmlMarkdownAlternatives' = addHtmlMarkdownAlternatives
|
|
-}
|
|
|
|
-- For now failed attempt to use with i18nHaletFile or widgets:
|
|
addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
|
|
, MonadMail m
|
|
, YesodMail (HandlerSite m)
|
|
) => Html -> m ()
|
|
addHtmlMarkdownAlternatives' html = do
|
|
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
|
|
|
|
addAlternatives $ do
|
|
providePreferredAlternative html
|
|
whenIsJust markdown provideAlternative
|
|
where
|
|
writerOptions = markdownWriterOptions
|
|
{ P.writerReferenceLinks = True
|
|
}
|