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

chore(mail): supervisor info messages (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2022-11-07 17:52:33 +01:00
parent 0cad77c32c
commit 6f1a4020ba
11 changed files with 124 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -19,4 +19,5 @@ PrintCourse: Kurse
PrintQualification: Qualifikation PrintQualification: Qualifikation
PrintPDF !ident-ok: PDF PrintPDF !ident-ok: PDF
PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
PrintLmsUser: E-Learning Benachrichtigung? PrintLmsUser: E-Learning Id
PrintJobs: Druckaufräge

3
messages/uniworx/categories/print/en-eu.msg
View File

@ -19,4 +19,5 @@ PrintCourse: Course
PrintQualification: Qualification PrintQualification: Qualification
PrintPDF: PDF PrintPDF: PDF
PrintManualRenewal: Manual sending of an apron driver's licence renewal letter PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
PrintLmsUser: E-learning notification? PrintLmsUser: E-learning id
PrintJobs: Print jobs

8
messages/uniworx/categories/send/send_notifications/de-de-formal.msg
View File

@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: Keine
#utils.hs + templates #utils.hs + templates
MailEditNotifications: Benachrichtigungen ein-/ausschalten MailEditNotifications: Benachrichtigungen ein-/ausschalten
#supervisor
MailSupervisorNote: Hinweis für Ansprechpartner
MailSupervisorBody undername@Text supername@Text: Sie erhalten diese Nachricht, da #{supername} als Ansprechpartner für #{undername} eingetragen ist in
MailSupervisorCopy undermail@Text: Diese Nachricht ist eine Kopie einer Nachricht, welche an #{undermail} gesendet wurde.
MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eingentlichen Empfänger versandt! Für die Weiterleitung sind alle für diesen Empfänger in FRADrive eingetragenen Ansprechpartner verantwortlich!
MailSupervisedNote: Hinweis
MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet:

8
messages/uniworx/categories/send/send_notifications/en-eu.msg
View File

@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: None
#utils.hs + templates #utils.hs + templates
MailEditNotifications: Enable/Disable notifications MailEditNotifications: Enable/Disable notifications
#supervisor
MailSupervisorNote: Note to supervisor
MailSupervisorBody undername supername: You receive this message, since #{supername} is registered as supervisor for #{undername} in
MailSupervisorCopy undermail: This is a copy of a message originally sent to #{undermail}.
MailSupervisorNoCopy: Warning: This message was not sent to the original recipient! The FRADrive registered supervisor, i.e. you, is responsible for forwarding this message to the recipient!
MailSupervisedNote: Please Note
MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely:

7
src/Handler/LMS.hs
View File

@ -519,6 +519,7 @@ postLmsR sid qsh = do
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
| Just d <- lastLetterDate -> dateTimeCell d | Just d <- lastLetterDate -> dateTimeCell d
| otherwise -> i18nCell MsgPrintJobUnacknowledged | otherwise -> i18nCell MsgPrintJobUnacknowledged
lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
cAckDates = case letterDates of cAckDates = case letterDates of
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
<h1> <h1>
@ -531,10 +532,10 @@ postLmsR sid qsh = do
^{formatTimeW SelFormatDateTime ackdate} ^{formatTimeW SelFormatDateTime ackdate}
$nothing $nothing
_{MsgPrintJobUnacknowledged} _{MsgPrintJobUnacknowledged}
$maybe _lu <- lmsident $maybe lu <- lprLink
<p> <p>
<a href=@{PrintCenterR}> <a href=@{lu}>
Link to PrintJob _{MsgPrintJobs}
|] |]
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
_ -> mempty _ -> mempty

78
src/Handler/PrintCenter.hs
View File

@ -197,53 +197,53 @@ mkPJTable = do
dbtProj = dbtProjFilteredPostId dbtProj = dbtProjFilteredPostId
dbtColonnade = mconcat dbtColonnade = mconcat
[ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
, sortable (Just "pj-created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
, sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
, sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey , sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
t = r ^. resultPrintJob . _entityVal . _printJobFilename t = r ^. resultPrintJob . _entityVal . _printJobFilename
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t) in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
, sortable (Just "pj-name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n , sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
, sortable (Just "pj-recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
, sortable (Just "pj-course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell , sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
, sortable (Just "pj-qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell , sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
, sortable (Just "pj-lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l) , sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l)
] ]
dbtSorting = mconcat dbtSorting = mconcat
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) [ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
, single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
, single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, single ("pj-recipient" , sortUserNameBareM queryRecipient) , single ("recipient" , sortUserNameBareM queryRecipient)
, single ("pj-sender" , sortUserNameBareM querySender ) , single ("sender" , sortUserNameBareM querySender )
, single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName)) , single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
, single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
, single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) , single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
] ]
dbtFilter = mconcat dbtFilter = mconcat
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName)) [ single ("name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
, single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName)) , single ("sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName)) , single ("course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
, single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName)) , single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
, single ("pj-lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) , single ("lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) , single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "pj-name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName) [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
, prismAForm (singletonFilter "pj-filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename) , prismAForm (singletonFilter "filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename)
, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) , prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
--, prismAForm (singletonFilter "pj-created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) --, prismAForm (singletonFilter "created" . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
-- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- <*> aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)
-- ) -- )
, prismAForm (singletonFilter "pj-recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient) , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient)
, prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender) , prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
, prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse) , prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
, prismAForm (singletonFilter "pj-qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification) , prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
, prismAForm (singletonFilter "pj-lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser) , prismAForm (singletonFilter "lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser)
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged) , prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
] ]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
@ -275,7 +275,7 @@ mkPJTable = do
(First (Just act), jobMap) <- inp (First (Just act), jobMap) <- inp
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
return (act, jobSet) return (act, jobSet)
psValidator = def & defaultSorting [SortAscBy "pj-created"] psValidator = def & defaultSorting [SortAscBy "created"]
& defaultFilter (singletonMap "acknowledged" [toPathPiece False]) & defaultFilter (singletonMap "acknowledged" [toPathPiece False])
over _1 postprocess <$> dbTable psValidator DBTable{..} over _1 postprocess <$> dbTable psValidator DBTable{..}

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

@ -9,12 +9,12 @@ module Handler.Utils.Mail
, addFileDB , addFileDB
, addHtmlMarkdownAlternatives , addHtmlMarkdownAlternatives
, addHtmlMarkdownAlternatives' , addHtmlMarkdownAlternatives'
, addHtmlMarkdownAlternatives''
) where ) where
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 qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -24,6 +24,7 @@ import qualified Text.Pandoc as P
import qualified Text.Hamlet as Hamlet (Translate) import qualified Text.Hamlet as Hamlet (Translate)
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,12 +57,24 @@ userMailT :: ( MonadHandler m
) => UserId -> MailT m () -> m () ) => UserId -> MailT m () -> m ()
userMailT uid mAct = do userMailT uid mAct = do
-- now <- liftIO getCurrentTime -- now <- liftIO getCurrentTime
underling <- liftHandler . runDB $ getJust uid
superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
let receivers = if null superVs let receivers = if null superVs
then [uid] then [uid]
else userSupervisorSupervisor . entityVal <$> superVs else userSupervisorSupervisor . entityVal <$> superVs
-- underling <- liftHandler . runDB $ getJust uid undercopy = uid `elem` receivers
forM_ receivers $ \svr -> do undername = underling ^. _userDisplayName -- nameHtml' underling
undermail = CI.original $ underling ^. _userEmail
infoSupervised = \(MsgRenderer mr) -> [shamlet|
<h2>#{mr MsgMailSupervisedNote}
<p>
#{mr MsgMailSupervisedBody}
<ul>
$forall svr <- superVs
<li>
#{nameHtml' svr}
|]
forM_ receivers $ \svr -> do
supervisor@User supervisor@User
{ userLanguages { userLanguages
, userDateTimeFormat , userDateTimeFormat
@ -77,17 +90,28 @@ userMailT uid mAct = do
SelFormatTime -> userTimeFormat SelFormatTime -> userTimeFormat
, mcCsvOptions = userCsvOptions , mcCsvOptions = userCsvOptions
} }
--bsExplainSupervisor = $(ihamletFile "templates/mail/supervisorPrefix.hamlet") -- TODO supername = supervisor ^. _userDisplayName -- nameHtml' supervisor
--explanationSupervisor = File { fileTitle = "SupervisorInfo.txt" infoSupervisor = [ihamlet|
-- , fileModified = no <h2>_{MsgMailSupervisorNote}
-- , fileContent = Just $ yield bsExplainSupervisor <p>
-- } _{MsgMailSupervisorBody undername supername} #
<a href=@{NewsR}>
FRADrive
.
$if undercopy
_{MsgMailSupervisorCopy undermail}
$else
_{MsgMailSupervisorNoCopy}
|]
mailT ctx $ do mailT ctx $ do
_mailTo .= pure (userAddress supervisor) _mailTo .= pure (userAddress supervisor)
mAct mAct
unless (uid==svr) $ -- do if uid==svr
mapSubject ("[SUPERVISOR]"<>) -- changing subject is easy then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
--addPart explanationSupervisor -- adding an attachment is also easy else do
mapSubject ("[SUPERVISOR]" <>)
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
_userMailTdirect :: ( MonadHandler m _userMailTdirect :: ( MonadHandler m
@ -152,7 +176,7 @@ instance ToMailHtml site a => ToMailHtml site (Shakespeare.RenderUrl (Route site
ur <- getUrlRenderParams ur <- getUrlRenderParams
toMailHtml $ act ur toMailHtml $ act ur
-- | Adds another Text part as Html AND Markdown (receiver's choice) to an email. Subsequently added parts create attachments named "Att#####.html" and "Att#####.txt"
addHtmlMarkdownAlternatives :: ( MonadMail m addHtmlMarkdownAlternatives :: ( MonadMail m
, ToMailPart (HandlerSite m) Html , ToMailPart (HandlerSite m) Html
, ToMailHtml (HandlerSite m) a , ToMailHtml (HandlerSite m) a
@ -170,36 +194,18 @@ addHtmlMarkdownAlternatives html' = do
{ P.writerReferenceLinks = True { P.writerReferenceLinks = True
} }
-- | provide a name for the part -- | Like @addHtmlMarkdownAlternatives, but adds subseqeunt parts with "content-disposition: inline" and the provided filename, if inline display is not permitted (receiver's choice)
addHtmlMarkdownAlternatives' :: ( MonadMail m addHtmlMarkdownAlternatives' :: ( MonadMail m
, ToMailPart (HandlerSite m) (NamedMailPart Html) , ToMailPart (HandlerSite m) (NamedMailPart Html)
, ToMailHtml (HandlerSite m) a , ToMailHtml (HandlerSite m) a
) => Text -> a -> m () ) => Text -> a -> m ()
addHtmlMarkdownAlternatives' fn html' = do addHtmlMarkdownAlternatives' fn html' = do
html <- toMailHtml html' html <- toMailHtml html'
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
addAlternatives $ do addAlternatives $ do
providePreferredAlternative $ NamedMailPart { namedPart = html, disposition = AttachmentDisposition fn } providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition $ fn <> ".html", namedPart = html }
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt")) whenIsJust markdown $ provideAlternative . NamedMailPart (InlineDisposition (fn <> ".txt"))
where
writerOptions = markdownWriterOptions
{ P.writerReferenceLinks = True
}
-- | provide a name for the part
addHtmlMarkdownAlternatives'' :: ( MonadMail m
, ToMailPart (HandlerSite m) (NamedMailPart Html)
, ToMailHtml (HandlerSite m) a
) => Text -> a -> m ()
addHtmlMarkdownAlternatives'' fn html' = do
html <- toMailHtml html'
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
addAlternatives $ do
providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition fn, namedPart = html }
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
where where
writerOptions = markdownWriterOptions writerOptions = markdownWriterOptions
{ P.writerReferenceLinks = True { P.writerReferenceLinks = True

3
src/Handler/Utils/Widgets.hs
View File

@ -89,6 +89,9 @@ nameHtml displayName surname
|] |]
[] -> error "Data.Text.splitOn returned empty list in violation of specification." [] -> error "Data.Text.splitOn returned empty list in violation of specification."
nameHtml' :: HasUser u => u -> Html
nameHtml' u = nameHtml (u ^. _userDisplayName) (u ^. _userSurname)
-- | Like nameHtml just show a users displayname with hightlighted surname, -- | Like nameHtml just show a users displayname with hightlighted surname,
-- but also wrap the name with a mailto-link -- but also wrap the name with a mailto-link
nameEmailHtml :: UserEmail -> Text -> Text -> Html nameEmailHtml :: UserEmail -> Text -> Text -> Html

21
src/Jobs/Handler/SendNotification.hs
View File

@ -24,25 +24,8 @@ import Jobs.Handler.SendNotification.Allocation
import Jobs.Handler.SendNotification.ExamOffice import Jobs.Handler.SendNotification.ExamOffice
import Jobs.Handler.SendNotification.CourseRegistered import Jobs.Handler.SendNotification.CourseRegistered
import Jobs.Handler.SendNotification.SubmissionEdited import Jobs.Handler.SendNotification.SubmissionEdited
import Jobs.Handler.SendNotification.Qualification import Jobs.Handler.SendNotification.Qualification
dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ dispatchJobSendNotification jRecipient jNotification = JobHandlerException $
$(dispatchTH ''Notification) jNotification jRecipient $(dispatchTH ''Notification) jNotification jRecipient
{-
IDEAS:
1) change type of dispatchNotificationfunctions to take another argument in addition to
jRecipient jNotificiation
2) change mailT and sendPrintJob to account for supervisors
dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do
-- TODO: this is a bad idea, since all notifications use jRecipient to generate the message body,
-- thus supervisors would receive all notifications with their own name inside!
superVs <- runDB $ selectList [UserSupervisorUser ==. jRecipient, UserSupervisorRerouteNotifications ==. True] []
if null superVs
then $(dispatchTH ''Notification) jNotification jRecipient
else forM_ superVs $ \Entity { entityVal = UserSupervisor { userSupervisorSupervisor = svr } } ->
$(dispatchTH ''Notification) jNotification svr
-}

8
src/Jobs/Handler/SendNotification/Qualification.hs
View File

@ -88,7 +88,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
let printJobName = "RenewalPin" let printJobName = "RenewalPin"
fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf" fileName = printJobName <> "_" <> (text2asciiAlphaNum . abbrvName) recipient <> ".pdf"
lmsIdent = lmsUserIdent & getLmsIdent lmsIdent = lmsUserIdent & getLmsIdent
lmsUrl = "https://drive.fraport.de" lmsUrl = "https://drive.fraport.de"
lmsLogin = lmsUrl <> "/?login=" <> lmsIdent lmsLogin = lmsUrl <> "/?login=" <> lmsIdent
@ -113,14 +113,14 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
| otherwise = do | otherwise = do
userMailT jRecipient $ do userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectQualificationRenewal qname setSubjectI $ MsgMailSubjectQualificationRenewal qname
editNotifications <- mkEditNotifications jRecipient
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
whenIsJust attachment $ \afile -> whenIsJust attachment $ \afile ->
addPart (File { fileTitle = Text.unpack fileName addPart (File { fileTitle = Text.unpack fileName
, fileModified = now , fileModified = now
, fileContent = Just $ yield $ LBS.toStrict afile , fileContent = Just $ yield $ LBS.toStrict afile
} :: PureFile) } :: PureFile)
editNotifications <- mkEditNotifications jRecipient
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
return True return True
notifyOk <- pdfRenewal pdfMeta >>= \case notifyOk <- pdfRenewal pdfMeta >>= \case

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

@ -10,25 +10,19 @@ import Import
import Handler.Utils.Mail import Handler.Utils.Mail
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Text.Hamlet
-- import Handler.Utils.I18n -- import Handler.Utils.I18n
dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX
dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do
_mailTo .= [Address Nothing jEmail] _mailTo .= [Address Nothing jEmail]
-- TODO: remove me after the test!
addHtmlMarkdownAlternatives $ \(MsgRenderer _mr) -> [shamlet|
<h1>
Testheader
<p>
Dieser Abschnitt ist ein Test, ob mehrfache Mailparts ankommen.
|]
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailTestSubject setSubjectI MsgMailTestSubject
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
nDT <- formatTimeMail SelFormatDateTime now nDT <- formatTimeMail SelFormatDateTime now
nD <- formatTimeMail SelFormatDate now nD <- formatTimeMail SelFormatDate now
nT <- formatTimeMail SelFormatTime now nT <- formatTimeMail SelFormatTime now
addHtmlMarkdownAlternatives $ \(MsgRenderer mr) -> [shamlet| addHtmlMarkdownAlternatives' "part1" $ \(MsgRenderer mr) -> [shamlet|
<h2> <h2>
#{mr MsgMailTestContent} #{mr MsgMailTestContent}
@ -39,31 +33,23 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
<li>#{nD} <li>#{nD}
<li>#{nT} <li>#{nT}
|] |]
addHtmlMarkdownAlternatives' "addOne" $ \(MsgRenderer mr) -> [shamlet| addHtmlMarkdownAlternatives' "part2" $ \(MsgRenderer _mr) -> [shamlet|
<h2>Repetition just for Testing <h2>Second part, just for testing
<p> <p>
#{mr MsgMailTestContent} Please ignore this part of the message send by
<a href=@{NewsR}>
FRADrive
|]
let trdmsg :: HtmlUrlI18n UniWorXJobsHandlerMessage (Route UniWorX) = [ihamlet|
<h2>Third part, again only for tests
<p> <p>
#{mr MsgMailTestDateTime} _{MsgMailTestDateTime}
<ul>
<li>#{nDT}
<li>#{nD}
<li>#{nT}
|]
addHtmlMarkdownAlternatives'' "addTwo" $ \(MsgRenderer mr) -> [shamlet|
<h2>Repetition just for Testing
<p>
#{mr MsgMailTestContent}
<p>
#{mr MsgMailTestDateTime}
<ul> <ul>
<li>#{nDT} <li>#{nDT}
<li>#{nD} <li>#{nD}
<li>#{nT} <li>#{nT}
|] |]
addHtmlMarkdownAlternatives' "part3" trdmsg
-- let test = $(i18nHamletFile "test") -- let test = $(i18nHamletFile "test")
-- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup -- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup