fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(mail): supervisor email reroute working

Browse Source
This commit is contained in:
Steffen Jost 2022-11-08 12:25:49 +01:00
parent 6f1a4020ba
commit 3e848976df
2 changed files with 31 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
src/Handler/Utils/Mail.hs
View File

@ -14,7 +14,7 @@ module Handler.Utils.Mail
import Import import Import
import Handler.Utils.Pandoc import Handler.Utils.Pandoc
import Handler.Utils.Files import Handler.Utils.Files
import Handler.Utils.Widgets (nameHtml') import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -22,9 +22,8 @@ import qualified Data.Conduit.Combinators as C
import qualified Text.Pandoc as P import qualified Text.Pandoc as P
import qualified Text.Hamlet as Hamlet (Translate) import qualified Text.Hamlet as Hamlet
import qualified Text.Shakespeare as Shakespeare (RenderUrl) import qualified Text.Shakespeare as Shakespeare (RenderUrl)
import qualified Text.CI as CI
addRecipientsDB :: ( MonadMail m addRecipientsDB :: ( MonadMail m
@ -56,42 +55,43 @@ userMailT :: ( MonadHandler m
, MonadUnliftIO m , MonadUnliftIO m
) => UserId -> MailT m () -> m () ) => UserId -> MailT m () -> m ()
userMailT uid mAct = do userMailT uid mAct = do
-- now <- liftIO getCurrentTime (underling, receivers) <- liftHandler . runDB $ do
underling <- liftHandler . runDB $ getJust uid underling <- getJustEntity uid
superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
let receivers = if null superVs let superIds = userSupervisorSupervisor . entityVal <$> superVs
then [uid] supers <- if null superIds then pure [underling] else selectList [UserId <-. superIds] []
else userSupervisorSupervisor . entityVal <$> superVs return (underling, if null supers then [underling] else supers)
undercopy = uid `elem` receivers let undercopy = uid `elem` (entityKey <$> receivers)
undername = underling ^. _userDisplayName -- nameHtml' underling undername = underling ^. _userDisplayName -- nameHtml' underling
undermail = CI.original $ underling ^. _userEmail undermail = CI.original $ underling ^. _userEmail
infoSupervised = \(MsgRenderer mr) -> [shamlet| infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
<h2>#{mr MsgMailSupervisedNote} <h2>_{MsgMailSupervisedNote}
<p> <p>
#{mr MsgMailSupervisedBody} _{MsgMailSupervisedBody}
<ul> <ul>
$forall svr <- superVs $forall svr <- receivers
<li> <li>
#{nameHtml' svr} #{nameHtml' svr}
|] |]
forM_ receivers $ \svr -> do forM_ receivers $ \Entity
supervisor@User { entityKey = svr
{ userLanguages , entityVal = supervisor@User{ userLanguages
, userDateTimeFormat , userDateTimeFormat
, userDateFormat , userDateFormat
, userTimeFormat , userTimeFormat
, userCsvOptions , userCsvOptions
} <- liftHandler . runDB $ getJust svr }
} -> do
let ctx = MailContext let ctx = MailContext
{ mcLanguages = fromMaybe def userLanguages { mcLanguages = fromMaybe def userLanguages
, mcDateTimeFormat = \case , mcDateTimeFormat = \case
SelFormatDateTime -> userDateTimeFormat SelFormatDateTime -> userDateTimeFormat
SelFormatDate -> userDateFormat SelFormatDate -> userDateFormat
SelFormatTime -> userTimeFormat SelFormatTime -> userTimeFormat
, mcCsvOptions = userCsvOptions , mcCsvOptions = userCsvOptions
} }
supername = supervisor ^. _userDisplayName -- nameHtml' supervisor supername = supervisor ^. _userDisplayName -- nameHtml' supervisor
infoSupervisor = [ihamlet| infoSupervisor :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
<h2>_{MsgMailSupervisorNote} <h2>_{MsgMailSupervisorNote}
<p> <p>
_{MsgMailSupervisorBody undername supername} # _{MsgMailSupervisorBody undername supername} #

9
src/Jobs/Handler/SendTestEmail.hs
View File

@ -36,10 +36,9 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
addHtmlMarkdownAlternatives' "part2" $ \(MsgRenderer _mr) -> [shamlet| addHtmlMarkdownAlternatives' "part2" $ \(MsgRenderer _mr) -> [shamlet|
<h2>Second part, just for testing <h2>Second part, just for testing
<p> <p>
Please ignore this part of the message send by Please ignore this part of the message.
<a href=@{NewsR}>
FRADrive
|] |]
-- Compiles as well: let trdmsg :: HtmlUrlI18n _ (Route UniWorX) = [ihamlet|
let trdmsg :: HtmlUrlI18n UniWorXJobsHandlerMessage (Route UniWorX) = [ihamlet| let trdmsg :: HtmlUrlI18n UniWorXJobsHandlerMessage (Route UniWorX) = [ihamlet|
<h2>Third part, again only for tests <h2>Third part, again only for tests
<p> <p>
@ -48,6 +47,10 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
<li>#{nDT} <li>#{nDT}
<li>#{nD} <li>#{nD}
<li>#{nT} <li>#{nT}
<p>
Message was sent to you by
<a href=@{NewsR}>
FRADrive
|] |]
addHtmlMarkdownAlternatives' "part3" trdmsg addHtmlMarkdownAlternatives' "part3" trdmsg
-- let test = $(i18nHamletFile "test") -- let test = $(i18nHamletFile "test")