This commit is contained in:
Gregor Kleen 2018-10-04 20:11:21 +02:00
parent 1beeea5aa6
commit 9040ff4d3d
3 changed files with 20 additions and 19 deletions

View File

@ -1323,7 +1323,7 @@ instance YesodMail UniWorX where
mailSmtp act = do mailSmtp act = do
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
withResource pool act withResource pool act
defaultMailAction ls mail = mailT ls $ do mailT ls mail = defMailT ls $ do
setMailObjectId setMailObjectId
setDateCurrent setDateCurrent

View File

@ -129,10 +129,10 @@ setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|]
performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) () performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) ()
performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do
$logDebugS "Jobs" "NotificationSubmissionRated" -- FIXME fail "NotificationSubmissionRated not implemented yet" -- TODO
performJob JobSendTestEmail{..} = do performJob JobSendTestEmail{..} = do
$logInfoS "Jobs" $ "Sending test-email to " <> jEmail $logInfoS "Jobs" $ "Sending test-email to " <> jEmail
defaultMailAction jLanguages $ do mailT jLanguages $ do
_mailTo .= [Address Nothing jEmail] _mailTo .= [Address Nothing jEmail]
setSubjectI MsgMailTestSubject setSubjectI MsgMailTestSubject
addPart (($ MsgMailTestContent) :: (UniWorXMessage -> Text) -> Text) -- FIXME addPart $ \(MsgRenderer mr) -> mr MsgMailTestContent

View File

@ -19,7 +19,7 @@ module Mail
( -- * Structured MIME emails ( -- * Structured MIME emails
module Network.Mail.Mime module Network.Mail.Mime
-- * MailT -- * MailT
, MailT, mailT , MailT, defMailT
, MailSmtpData(..), MailLanguages(..) , MailSmtpData(..), MailLanguages(..)
, MonadMail(..) , MonadMail(..)
-- * YesodMail -- * YesodMail
@ -99,6 +99,7 @@ import qualified Text.Hamlet as Shakespeare (Translate, Render)
import Data.Aeson (Options(..)) import Data.Aeson (Options(..))
import Data.Aeson.TH import Data.Aeson.TH
import Utils (MsgRendererS, getMsgRenderer)
import Utils.PathPiece (splitCamel) import Utils.PathPiece (splitCamel)
@ -186,19 +187,19 @@ class YesodMail site where
) => m VerpMode ) => m VerpMode
mailVerp = return VerpNone mailVerp = return VerpNone
defaultMailAction :: ( MonadHandler m mailT :: ( MonadHandler m
, HandlerSite m ~ site , HandlerSite m ~ site
, MonadBaseControl IO m , MonadBaseControl IO m
) => MailLanguages -> MailT m a -> m a ) => MailLanguages -> MailT m a -> m a
defaultMailAction = mailT mailT = defMailT
mailT :: ( MonadHandler m defMailT :: ( MonadHandler m
, YesodMail (HandlerSite m) , YesodMail (HandlerSite m)
, MonadBaseControl IO m , MonadBaseControl IO m
) => MailLanguages -- ^ Languages in priority order ) => MailLanguages -- ^ Languages in priority order
-> MailT m a -> MailT m a
-> m a -> m a
mailT ls (MailT mail) = do defMailT ls (MailT mail) = do
fromAddress <- defaultFromAddress fromAddress <- defaultFromAddress
(ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress) (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
mail' <- liftIO $ LBS.toStrict <$> renderMail' mail mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
@ -249,9 +250,9 @@ instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Shakesp
mr <- Yesod.getMessageRender mr <- Yesod.getMessageRender
toMailPart $ act (toHtml . mr) toMailPart $ act (toHtml . mr)
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site ((msg -> Text) -> a) where instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
toMailPart act = do toMailPart act = do
mr <- Yesod.getMessageRender mr <- getMsgRenderer
toMailPart $ act mr toMailPart $ act mr
instance ToMailPart site a => ToMailPart site (Shakespeare.Render (Route site) -> a) where instance ToMailPart site a => ToMailPart site (Shakespeare.Render (Route site) -> a) where