chore(mail): supervisor info messages (WIP)
This commit is contained in:
Steffen Jost
parent
0cad77c32c
commit
6f1a4020ba
@ -19,4 +19,5 @@ PrintCourse: Kurse
|
||||
PrintQualification: Qualifikation
|
||||
PrintPDF !ident-ok: PDF
|
||||
PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
|
||||
PrintLmsUser: E-Learning Benachrichtigung?
|
||||
PrintLmsUser: E-Learning Id
|
||||
PrintJobs: Druckaufräge
|
||||
@ -19,4 +19,5 @@ PrintCourse: Course
|
||||
PrintQualification: Qualification
|
||||
PrintPDF: PDF
|
||||
PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
|
||||
PrintLmsUser: E-learning notification?
|
||||
PrintLmsUser: E-learning id
|
||||
PrintJobs: Print jobs
|
||||
@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: Keine
|
||||
|
||||
#utils.hs + templates
|
||||
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:
|
||||
@ -148,3 +148,11 @@ MailUserSystemFunctionsNoFunctions: None
|
||||
|
||||
#utils.hs + templates
|
||||
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:
|
||||
@ -519,6 +519,7 @@ postLmsR sid qsh = do
|
||||
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
|
||||
| Just d <- lastLetterDate -> dateTimeCell d
|
||||
| otherwise -> i18nCell MsgPrintJobUnacknowledged
|
||||
lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)]))
|
||||
cAckDates = case letterDates of
|
||||
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
|
||||
<h1>
|
||||
@ -531,10 +532,10 @@ postLmsR sid qsh = do
|
||||
^{formatTimeW SelFormatDateTime ackdate}
|
||||
$nothing
|
||||
_{MsgPrintJobUnacknowledged}
|
||||
$maybe _lu <- lmsident
|
||||
$maybe lu <- lprLink
|
||||
<p>
|
||||
<a href=@{PrintCenterR}>
|
||||
Link to PrintJob
|
||||
<a href=@{lu}>
|
||||
_{MsgPrintJobs}
|
||||
|]
|
||||
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
|
||||
_ -> mempty
|
||||
|
||||
@ -197,53 +197,53 @@ mkPJTable = do
|
||||
dbtProj = dbtProjFilteredPostId
|
||||
dbtColonnade = mconcat
|
||||
[ 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 "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
|
||||
, sortable (Just "pj-filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
|
||||
t = r ^. resultPrintJob . _entityVal . _printJobFilename
|
||||
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
|
||||
, sortable (Just "pj-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 "pj-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 "pj-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 "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t
|
||||
, sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
|
||||
, sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey
|
||||
t = r ^. resultPrintJob . _entityVal . _printJobFilename
|
||||
in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
|
||||
, sortable (Just "name") (i18nCell MsgPrintJobName) $ \( view $ resultPrintJob . _entityVal . _printJobName -> n) -> textCell n
|
||||
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "sender") (i18nCell MsgPrintSender) $ \(preview resultSender -> u) -> maybeCell u $ cellHasUserLink AdminUserR
|
||||
, sortable (Just "course") (i18nCell MsgPrintCourse) $ \(preview $ resultCourse . _entityVal -> c) -> maybeCell c courseCell
|
||||
, sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
|
||||
, sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap textCell (getLmsIdent <$> l)
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ single ("pj-name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
|
||||
, single ("pj-filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
|
||||
, single ("pj-created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
|
||||
, single ("pj-acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
|
||||
, single ("pj-recipient" , sortUserNameBareM queryRecipient)
|
||||
, single ("pj-sender" , sortUserNameBareM querySender )
|
||||
, single ("pj-course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
||||
, single ("pj-qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
||||
, single ("pj-lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
|
||||
[ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
|
||||
, single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
|
||||
, single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
|
||||
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
|
||||
, single ("recipient" , sortUserNameBareM queryRecipient)
|
||||
, single ("sender" , sortUserNameBareM querySender )
|
||||
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
|
||||
, single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
|
||||
, single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single ("pj-name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
|
||||
, single ("pj-filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
||||
, single ("pj-created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
--, single ("pj-created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
, single ("pj-recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
|
||||
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
|
||||
, single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
|
||||
, single ("pj-lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
|
||||
[ single ("name" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobName))
|
||||
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
||||
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||
, single ("sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
|
||||
, single ("course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
|
||||
, single ("qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
|
||||
, single ("lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
|
||||
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ prismAForm (singletonFilter "pj-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 "pj-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 "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName)
|
||||
, prismAForm (singletonFilter "filename" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobFilename)
|
||||
, prismAForm (singletonFilter "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)
|
||||
-- )
|
||||
, prismAForm (singletonFilter "pj-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 "pj-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 "pj-lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser)
|
||||
, prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient)
|
||||
, prismAForm (singletonFilter "sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
|
||||
, prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
|
||||
, prismAForm (singletonFilter "qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
|
||||
, 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)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
|
||||
@ -275,7 +275,7 @@ mkPJTable = do
|
||||
(First (Just act), jobMap) <- inp
|
||||
let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
|
||||
return (act, jobSet)
|
||||
psValidator = def & defaultSorting [SortAscBy "pj-created"]
|
||||
psValidator = def & defaultSorting [SortAscBy "created"]
|
||||
& defaultFilter (singletonMap "acknowledged" [toPathPiece False])
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
|
||||
|
||||
@ -9,12 +9,12 @@ module Handler.Utils.Mail
|
||||
, addFileDB
|
||||
, addHtmlMarkdownAlternatives
|
||||
, addHtmlMarkdownAlternatives'
|
||||
, addHtmlMarkdownAlternatives''
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Pandoc
|
||||
import Handler.Utils.Files
|
||||
import Handler.Utils.Widgets (nameHtml')
|
||||
|
||||
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.Shakespeare as Shakespeare (RenderUrl)
|
||||
import qualified Text.CI as CI
|
||||
|
||||
|
||||
addRecipientsDB :: ( MonadMail m
|
||||
@ -56,12 +57,24 @@ userMailT :: ( MonadHandler m
|
||||
) => UserId -> MailT m () -> m ()
|
||||
userMailT uid mAct = do
|
||||
-- now <- liftIO getCurrentTime
|
||||
underling <- liftHandler . runDB $ getJust uid
|
||||
superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
|
||||
let receivers = if null superVs
|
||||
then [uid]
|
||||
else userSupervisorSupervisor . entityVal <$> superVs
|
||||
-- underling <- liftHandler . runDB $ getJust uid
|
||||
forM_ receivers $ \svr -> do
|
||||
undercopy = uid `elem` receivers
|
||||
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
|
||||
{ userLanguages
|
||||
, userDateTimeFormat
|
||||
@ -77,17 +90,28 @@ userMailT uid mAct = do
|
||||
SelFormatTime -> userTimeFormat
|
||||
, mcCsvOptions = userCsvOptions
|
||||
}
|
||||
--bsExplainSupervisor = $(ihamletFile "templates/mail/supervisorPrefix.hamlet") -- TODO
|
||||
--explanationSupervisor = File { fileTitle = "SupervisorInfo.txt"
|
||||
-- , fileModified = no
|
||||
-- , fileContent = Just $ yield bsExplainSupervisor
|
||||
-- }
|
||||
supername = supervisor ^. _userDisplayName -- nameHtml' supervisor
|
||||
infoSupervisor = [ihamlet|
|
||||
<h2>_{MsgMailSupervisorNote}
|
||||
<p>
|
||||
_{MsgMailSupervisorBody undername supername} #
|
||||
<a href=@{NewsR}>
|
||||
FRADrive
|
||||
.
|
||||
$if undercopy
|
||||
_{MsgMailSupervisorCopy undermail}
|
||||
$else
|
||||
_{MsgMailSupervisorNoCopy}
|
||||
|]
|
||||
mailT ctx $ do
|
||||
_mailTo .= pure (userAddress supervisor)
|
||||
mAct
|
||||
unless (uid==svr) $ -- do
|
||||
mapSubject ("[SUPERVISOR]"<>) -- changing subject is easy
|
||||
--addPart explanationSupervisor -- adding an attachment is also easy
|
||||
if uid==svr
|
||||
then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
|
||||
else do
|
||||
mapSubject ("[SUPERVISOR]" <>)
|
||||
addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
|
||||
|
||||
|
||||
|
||||
_userMailTdirect :: ( MonadHandler m
|
||||
@ -152,7 +176,7 @@ instance ToMailHtml site a => ToMailHtml site (Shakespeare.RenderUrl (Route site
|
||||
ur <- getUrlRenderParams
|
||||
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
|
||||
, ToMailPart (HandlerSite m) Html
|
||||
, ToMailHtml (HandlerSite m) a
|
||||
@ -170,36 +194,18 @@ addHtmlMarkdownAlternatives html' = do
|
||||
{ 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
|
||||
, ToMailPart (HandlerSite m) (NamedMailPart Html)
|
||||
, ToMailHtml (HandlerSite m) a
|
||||
) => Text -> a -> m ()
|
||||
addHtmlMarkdownAlternatives' fn html' = do
|
||||
addHtmlMarkdownAlternatives' fn html' = do
|
||||
html <- toMailHtml html'
|
||||
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
|
||||
|
||||
addAlternatives $ do
|
||||
providePreferredAlternative $ NamedMailPart { namedPart = html, disposition = AttachmentDisposition fn }
|
||||
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (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"))
|
||||
providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition $ fn <> ".html", namedPart = html }
|
||||
whenIsJust markdown $ provideAlternative . NamedMailPart (InlineDisposition (fn <> ".txt"))
|
||||
where
|
||||
writerOptions = markdownWriterOptions
|
||||
{ P.writerReferenceLinks = True
|
||||
|
||||
@ -89,6 +89,9 @@ nameHtml displayName surname
|
||||
|]
|
||||
[] -> 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,
|
||||
-- but also wrap the name with a mailto-link
|
||||
nameEmailHtml :: UserEmail -> Text -> Text -> Html
|
||||
|
||||
@ -24,25 +24,8 @@ import Jobs.Handler.SendNotification.Allocation
|
||||
import Jobs.Handler.SendNotification.ExamOffice
|
||||
import Jobs.Handler.SendNotification.CourseRegistered
|
||||
import Jobs.Handler.SendNotification.SubmissionEdited
|
||||
import Jobs.Handler.SendNotification.Qualification
|
||||
import Jobs.Handler.SendNotification.Qualification
|
||||
|
||||
dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
|
||||
dispatchJobSendNotification jRecipient jNotification = JobHandlerException $
|
||||
dispatchJobSendNotification jRecipient jNotification = JobHandlerException $
|
||||
$(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
|
||||
-}
|
||||
@ -88,7 +88,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
|
||||
|
||||
let printJobName = "RenewalPin"
|
||||
fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf"
|
||||
fileName = printJobName <> "_" <> (text2asciiAlphaNum . abbrvName) recipient <> ".pdf"
|
||||
lmsIdent = lmsUserIdent & getLmsIdent
|
||||
lmsUrl = "https://drive.fraport.de"
|
||||
lmsLogin = lmsUrl <> "/?login=" <> lmsIdent
|
||||
@ -113,14 +113,14 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
||||
| otherwise = do
|
||||
userMailT jRecipient $ do
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationRenewal qname
|
||||
setSubjectI $ MsgMailSubjectQualificationRenewal qname
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
whenIsJust attachment $ \afile ->
|
||||
addPart (File { fileTitle = Text.unpack fileName
|
||||
, fileModified = now
|
||||
, fileContent = Just $ yield $ LBS.toStrict afile
|
||||
} :: PureFile)
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
|
||||
return True
|
||||
|
||||
notifyOk <- pdfRenewal pdfMeta >>= \case
|
||||
|
||||
@ -10,25 +10,19 @@ import Import
|
||||
|
||||
import Handler.Utils.Mail
|
||||
import Handler.Utils.DateTime
|
||||
import Text.Hamlet
|
||||
-- import Handler.Utils.I18n
|
||||
|
||||
dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX
|
||||
dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do
|
||||
_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"
|
||||
setSubjectI MsgMailTestSubject
|
||||
now <- liftIO getCurrentTime
|
||||
nDT <- formatTimeMail SelFormatDateTime now
|
||||
nD <- formatTimeMail SelFormatDate now
|
||||
nT <- formatTimeMail SelFormatTime now
|
||||
addHtmlMarkdownAlternatives $ \(MsgRenderer mr) -> [shamlet|
|
||||
addHtmlMarkdownAlternatives' "part1" $ \(MsgRenderer mr) -> [shamlet|
|
||||
<h2>
|
||||
#{mr MsgMailTestContent}
|
||||
|
||||
@ -39,31 +33,23 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
|
||||
<li>#{nD}
|
||||
<li>#{nT}
|
||||
|]
|
||||
addHtmlMarkdownAlternatives' "addOne" $ \(MsgRenderer mr) -> [shamlet|
|
||||
<h2>Repetition just for Testing
|
||||
addHtmlMarkdownAlternatives' "part2" $ \(MsgRenderer _mr) -> [shamlet|
|
||||
<h2>Second part, just for testing
|
||||
<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>
|
||||
#{mr MsgMailTestDateTime}
|
||||
<ul>
|
||||
<li>#{nDT}
|
||||
<li>#{nD}
|
||||
<li>#{nT}
|
||||
|]
|
||||
addHtmlMarkdownAlternatives'' "addTwo" $ \(MsgRenderer mr) -> [shamlet|
|
||||
<h2>Repetition just for Testing
|
||||
<p>
|
||||
#{mr MsgMailTestContent}
|
||||
|
||||
<p>
|
||||
#{mr MsgMailTestDateTime}
|
||||
_{MsgMailTestDateTime}
|
||||
<ul>
|
||||
<li>#{nDT}
|
||||
<li>#{nD}
|
||||
<li>#{nT}
|
||||
|]
|
||||
addHtmlMarkdownAlternatives' "part3" trdmsg
|
||||
-- let test = $(i18nHamletFile "test")
|
||||
-- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user