122 lines
5.9 KiB
Haskell
122 lines
5.9 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
|
|
|
|
module Jobs.Handler.SendNotification.Qualification
|
|
( dispatchNotificationQualificationExpiry
|
|
, dispatchNotificationQualificationExpired
|
|
, dispatchNotificationQualificationRenewal
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Print
|
|
import Handler.Utils
|
|
import Jobs.Handler.SendNotification.Utils
|
|
|
|
-- import Handler.Info (FAQItem(..))
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Text.Hamlet
|
|
|
|
|
|
dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
|
|
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
|
|
(recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
|
|
<$> getJust jRecipient
|
|
<*> getJust nQualification
|
|
|
|
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
|
let entRecipient = Entity jRecipient recipient
|
|
qname = CI.original qualificationName
|
|
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
|
|
|
|
$logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
|
|
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
|
|
|
editNotifications <- mkEditNotifications jRecipient
|
|
|
|
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
|
|
|
|
|
dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
|
|
dispatchNotificationQualificationExpired nQualification jRecipient = do
|
|
encRecipient :: CryptoUUIDUser <- encrypt jRecipient
|
|
encRecShort <- encrypt jRecipient
|
|
dbRes <- runDB $ (,,)
|
|
<$> get jRecipient
|
|
<*> get nQualification
|
|
<*> getBy (UniqueQualificationUser nQualification jRecipient)
|
|
|
|
case dbRes of
|
|
( Just User{..}, Just Qualification{..}, Just (Entity quId QualificationUser{..})) -> do
|
|
now <- liftIO getCurrentTime
|
|
qub_entry <- entityVal <<$>> runDB (selectRelevantBlock now quId)
|
|
let block = filterMaybe (not . qualificationUserBlockUnblock) qub_entry
|
|
urender <- getUrlRender
|
|
let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block
|
|
qname = CI.original qualificationName
|
|
qshort = CI.original qualificationShorthand
|
|
letter = LetterExpireQualificationF
|
|
{ leqfHolderCFN = encRecShort
|
|
, leqfHolderID = jRecipient
|
|
, leqfHolderDN = userDisplayName
|
|
, leqfHolderSN = userSurname
|
|
, leqfExpiry = Just expDay
|
|
, leqfId = nQualification
|
|
, leqfName = qname
|
|
, leqfShort = qshort
|
|
, leqfSchool = qualificationSchool
|
|
, leqfUrl = pure . urender $ ForProfileDataR encRecipient
|
|
}
|
|
if expDay > utctDay qualificationUserLastNotified
|
|
then do
|
|
notifyOk <- sendEmailOrLetter jRecipient letter
|
|
if notifyOk
|
|
then do
|
|
runDB $ update quId [QualificationUserLastNotified =. now]
|
|
$logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
|
|
else
|
|
$logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
|
|
else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
|
|
_ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
|
|
|
|
|
|
-- NOTE: Renewal expects that LmsUser already exists for recipient
|
|
dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
|
|
dispatchNotificationQualificationRenewal nQualification jRecipient = do
|
|
encRecipient :: CryptoUUIDUser <- encrypt jRecipient
|
|
query <- runDB $ (,,,)
|
|
<$> get jRecipient
|
|
<*> get nQualification
|
|
<*> getBy (UniqueQualificationUser nQualification jRecipient)
|
|
<*> getBy (UniqueLmsQualificationUser nQualification jRecipient)
|
|
case query of
|
|
(Just User{userDisplayName, userSurname}, Just Qualification{..}, Just (Entity _ QualificationUser{..}), Just(Entity luid LmsUser{..})) -> do
|
|
let qname = CI.original qualificationName
|
|
letter = LetterRenewQualificationF
|
|
{ lmsLogin = lmsUserIdent
|
|
, lmsPin = lmsUserPin
|
|
, qualHolderID = jRecipient
|
|
, qualHolderDN = userDisplayName
|
|
, qualHolderSN = userSurname
|
|
, qualExpiry = qualificationUserValidUntil
|
|
, qualId = nQualification
|
|
, qualName = qname
|
|
, qualShort = CI.original qualificationShorthand
|
|
, qualSchool = qualificationSchool
|
|
, qualDuration = qualificationValidDuration
|
|
}
|
|
$logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
|
|
notifyOk <- sendEmailOrLetter jRecipient letter
|
|
when notifyOk $ do
|
|
now <- liftIO getCurrentTime
|
|
runDB $ update luid [ LmsUserNotified =. Just now]
|
|
(_, Nothing, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: Qualification " <> tshow nQualification <> " does not exist!"
|
|
(Nothing, _, _, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: User does not exist!"
|
|
(_, _, Nothing, _) -> $logErrorS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: QualificationUser does not exist, i.e. user does not have this qualification!"
|
|
(_, _, _, Nothing) -> $logWarnS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal failed: LmsUser does not exist!"
|
|
|