-- SPDX-FileCopyrightText: 2022-25 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} module Handler.Utils.Qualification ( module Handler.Utils.Qualification ) where import Import import qualified Data.Text as Text -- import Data.Time.Calendar (CalendarDiffDays(..)) import Database.Persist.Sql (deleteWhereCount) -- (updateWhereCount) import qualified Database.Esqueleto.Experimental as E -- might need TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E import Handler.Utils.Widgets (statusHtml) import Handler.Utils.Memcached import Handler.Utils.DateTime (addLocalDays) retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) retrieveQualification qid = liftHandler $ $(memcachedByHere) (Just . Right $ 7 * diffHour) qid $ runDBRead $ get qid {- This experiment proves that a newtype-wrapper is entirely ignored by the derived Binary instance, since regardless whether the prime or unprimed version is used, the same QualificationId leads to a hit: newtype MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- unnecessary, also see top comment in Handler.Utils.Memcached deriving newtype (Eq, Ord, Show, Binary) instance NFData MemcachedQualification where rnf MemcachedQualification{..} = rnf unMemachedQualification -- note that data does not work as expected either, the binary instance is only distinguished by the addition of another element data MemcachedQualification = MemcachedQualification { unMemachedQualification :: QualificationId } -- , someId :: Text } -- with Text works OK deriving (Eq, Ord, Show, Generic, Binary) instance NFData MemcachedQualification where rnf MemcachedQualification{..} = rnf (unMemachedQualification, someId) retrieveQualification :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) retrieveQualification qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) (MemcachedQualification qid) $ do $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} with Newtype-wrapper.|] runDBRead $ get qid retrieveQualification' :: (MonadHandler m, HandlerSite m ~ UniWorX) => QualificationId -> m (Maybe Qualification) retrieveQualification' qid = liftHandler $ memcachedBy (Just . Right $ 7 * diffHour) qid $ do $logWarnS "CACHE-MISS" [st|Retrieve Qualification #{tshow qid} directly without a wrapper.|] runDBRead $ get qid -} -- | Compute new valid date from old one and from validDuration in months -- Mainly to document which add months functions to use computeNewValidDate :: Integral a => a -> Day -> Day computeNewValidDate = addGregorianMonthsClip . toInteger computeNewValidDate' :: CalendarDiffDays -> Day -> Day computeNewValidDate' = addGregorianDurationClip statusQualificationBlock :: Bool -> Html statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s -- needs refactoring, probbably no longer helpful mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} where qualificationUserBlockReason = tshow reason qualificationUserBlockUnblock = False qualificationUserBlockBlocker = Nothing -- somewhat dangerous, if not used with latest effective block isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld ,qu ^. hasQualificationUser . _qualificationUserValidUntil) && all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb ------------------ -- SQL Snippets -- ------------------ -- | Recently became invalid or blocked and not yet notified; assumes that second argument is latest active block (if exists), also checks validity with respect to given timestamp quserToNotify :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value Bool) quserToNotify cutoff quser qblock = -- either recently become invalid with no prior block or recently blocked -- has expired without being blocked quser E.^. QualificationUserScheduleRenewal E.&&. (( quser E.^. QualificationUserValidUntil E.<. E.val (utctDay cutoff) E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified) E.&&. E.not__ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked ) E.||. ( -- was recently blocked E.isFalse (qblock E.?. QualificationUserBlockUnblock) E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified) )) -- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do newerBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff E.&&. E.just(newerBlock E.^. QualificationUserBlockId) E.!=. qualBlock E.?. QualificationUserBlockId E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom) E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins E.&&. (newerBlock E.^. QualificationUserBlockFrom E.=?. qualBlock E.?. QualificationUserBlockFrom) )) ) -- | condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended -- variant for inner joins isLatestBlockBefore' :: E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool) isLatestBlockBefore' qualBlock cutoff = (cutoff E.>. qualBlock E.^. QualificationUserBlockFrom) E.&&. E.notExists (do newerBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.==. qualBlock E.^. QualificationUserBlockQualificationUser E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff E.&&. newerBlock E.^. QualificationUserBlockId E.!=. qualBlock E.^. QualificationUserBlockId E.&&. (( newerBlock E.^. QualificationUserBlockFrom E.>. qualBlock E.^. QualificationUserBlockFrom) E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins E.&&. (newerBlock E.^. QualificationUserBlockFrom E.==. qualBlock E.^. QualificationUserBlockFrom) )) ) -- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_` quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do qualUserBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff) E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser) E.&&. E.notExists (do qualUserUnblock <- E.from $ E.table @QualificationUserBlock E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock) E.&&. checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser) E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. cutoff E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>=. qualUserBlock E.^. QualificationUserBlockFrom -- in case of identical timestamps, the unblock trumps the block ) whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock)) -- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing -- | Variant of `isBlocked` for outer joins quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) qualificationValid = flip validQualification validQualification :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) validQualification cutoff qualUser = (E.val (utctDay cutoff) `E.between` (qualUser E.^. QualificationUserFirstHeld ,qualUser E.^. QualificationUserValidUntil)) -- currently valid E.&&. quserBlock False cutoff qualUser -- | Variant of `validQualification` for outer joins validQualification' :: UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) validQualification' cutoff qualUser = (E.justVal (utctDay cutoff) `E.between` (qualUser E.?. QualificationUserFirstHeld ,qualUser E.?. QualificationUserValidUntil)) -- currently valid E.&&. quserBlock' False cutoff qualUser -- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser] -- selectValidQualifications :: -- ( MonadIO m -- , BackendCompatible SqlBackend backend -- , PersistQueryRead backend -- , PersistUniqueRead backend -- ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser] selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser] selectValidQualifications qid uids cutoff = -- cutoff <- utctDay <$> liftIO getCurrentTime E.select $ do qUser <- E.from $ E.table @QualificationUser E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid) E.&&. qUser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. validQualification cutoff qUser -- whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids) pure qUser selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock)) selectRelevantBlock cutoff quid = selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom] ------------------------ -- Complete Functions -- ------------------------ upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking upsertQualificationUser qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do let qualificationUserLastRefresh = utctDay startTime Entity quid _ <- upsert QualificationUser { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal , qualificationUserLastNotified = utctDayMidnight qualificationUserLastRefresh , .. } ( [ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal] ] ++ [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) authUsr <- liftHandler maybeAuthId insert_ $ QualificationUserBlock quid True startTime reason authUsr audit TransactionQualificationUserEdit { transactionQualificationUser = quid , transactionQualification = qualificationUserQualification , transactionUser = qualificationUserUser , transactionQualificationValidUntil = qualificationUserValidUntil , transactionQualificationScheduleRenewal = mbScheduleRenewal , transactionNote = canonical $ Just reason } -- | Renew an existing valid qualification, ignoring all blocks otherwise -- renewValidQualificationUsers :: QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> DB Int -- not general enough for use in YesodJobDB renewValidQualificationUsers :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) , PersistQueryWrite (YesodPersistBackend (HandlerSite m)) , PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) , HasInstanceID (HandlerSite m) InstanceId , YesodAuthPersist (HandlerSite m) , HasAppSettings (HandlerSite m) , MonadHandler m , MonadCatch m ) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int renewValidQualificationUsers qid reason renewalTime uids = -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed? -- E.update $ \qu -> do -- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only -- E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid ) -- E.&&. (qu E.^. QualificationUserUser `E.in_` E.valList uids) get qid >>= \case Just Qualification{qualificationElearningRenews=False} | Just (Right (QualificationRenewELearningBy _)) <- reason -> return 0 Just Qualification{qualificationValidDuration=Just renewalMonths} -> do cutoff <- maybe (liftIO getCurrentTime) return renewalTime quEntsAll <- selectValidQualifications qid uids cutoff let cutoffday = utctDay cutoff maxValidTo = computeNewValidDate (renewalMonths `div` 2) cutoffday -- earliest renewal: only if less than half the valid duration remains! quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do let newValidTo = computeNewValidDate renewalMonths qualificationUserValidUntil update quId [ QualificationUserValidUntil =. newValidTo , QualificationUserLastRefresh =. cutoffday ] audit TransactionQualificationUserEdit { transactionQualificationUser = quId , transactionQualification = qualificationUserQualification , transactionUser = qualificationUserUser , transactionQualificationValidUntil = newValidTo , transactionQualificationScheduleRenewal = Nothing , transactionNote = qualificationChangeReasonText <$> reason } return $ length quEnts _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. -- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used) qualificationUserBlocking :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) , PersistQueryWrite (YesodPersistBackend (HandlerSite m)) , PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) , HasInstanceID (HandlerSite m) InstanceId , YesodAuthPersist (HandlerSite m) , HasAppSettings (HandlerSite m) , MonadHandler m , MonadCatch m , Num n ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify, "#Users:" <> tshow (length uids), tshow uids] -- this message can get very long on test systems authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime let blockTime = fromMaybe now mbBlockTime -- -- Code would work, but problematic -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do -- E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid -- E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid -- E.&&. quserBlock unblock blockTime qualificationUser -- only unblock blocked qualification and vice versa -- return $ QualificationUserBlock -- E.<# qualificationUser E.^. QualificationUserId -- E.<&> E.val unblock -- E.<&> E.val blockTime -- E.<&> E.val reason -- E.<&> E.val authUsr toChange <- E.select $ do qualUser <- E.from $ E.table @QualificationUser E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid E.&&. qualUser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. quserBlock unblock blockTime qualUser -- only unblock blocked qualification and vice versa return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) let newBlocks = map (\(E.Value quid, E.Value uid) -> (uid, QualificationUserBlock { qualificationUserBlockQualificationUser = quid , qualificationUserBlockUnblock = unblock , qualificationUserBlockFrom = blockTime , qualificationUserBlockReason = reason , qualificationUserBlockBlocker = authUsr })) toChange E.insertMany_ (snd <$> newBlocks) unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. addUTCTime 1 blockTime] forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking { transactionQualification = qid , transactionUser = uid , transactionQualificationBlock = qub } return $ fromIntegral $ length newBlocks qualificationUserUnblockByReason :: ( AuthId (HandlerSite m) ~ Key User , IsPersistBackend (YesodPersistBackend (HandlerSite m)) , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) , PersistQueryWrite (YesodPersistBackend (HandlerSite m)) , PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) , HasInstanceID (HandlerSite m) InstanceId , YesodAuthPersist (HandlerSite m) , HasAppSettings (HandlerSite m) , MonadHandler m , MonadCatch m , Num n ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime toUnblock <- E.select $ do quser <- E.from $ E.table @QualificationUser E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid E.&&. quser E.^. QualificationUserUser `E.in_` E.valList uids E.&&. quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason)) return $ quser E.^. QualificationUserUser qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify ----------- -- Forms -- ----------- qualificationOption :: Entity Qualification -> Option QualificationId qualificationOption (Entity qid Qualification{..}) = let qsh = ciOriginal $ unSchoolKey qualificationSchool in Option{ optionDisplay = ciOriginal qualificationName <> " (" <> qsh <> ")" , optionExternalValue = toPathPiece $ ciOriginal qualificationShorthand <> "___" <> qsh -- both a publicly known already , optionInternalValue = qid } qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId qualificationsOptionList = mkOptionList . map qualificationOption {- Should we encrypt the external value or simply rely on uniqueness? --TODO: still used in Handler.Admin.Avs qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do cQualId :: CryptoUUIDQualification <- encrypt qualId return $ Option { optionDisplay = ciOriginal $ qualificationName qual , optionInternalValue = qualId , optionExternalValue = tshow cQualId } -} ----------------- -- LMS related -- ----------------- data LmsOrphanReason = LmsOrphanReasonManualTermination | LmsOrphanReasonB | LmsOrphanReasonC deriving (Eq, Ord, Enum, Bounded, Generic) deriving anyclass (Universe, Finite, NFData) -- NOTE: it is intentional not to have an embedRenderMessage here; within the DB, we allow arbitrary text, but we do match on these ones to recognise certain functions -- so do not change values here without a proper migration instance Show LmsOrphanReason where show LmsOrphanReasonManualTermination = "Manuell abgebrochen" show LmsOrphanReasonB = "B" show LmsOrphanReasonC = "C" -- | Remove user from e-learning for given qualification and add to LmsOrphan dated back for immediate deletion. Calls audit terminateLms :: LmsOrphanReason -> QualificationId -> [UserId] -> DB Int terminateLms _ _ [] = return 0 terminateLms reason qid uids = do now <- liftIO getCurrentTime orphanDelDays <- getsYesod $ view $ _appLmsConf . _lmsOrphanDeletionDays let delSeenFirst = addLocalDays (negate orphanDelDays) now tReason = Just $ tshow reason lusers <- selectList [LmsUserQualification ==. qid, LmsUserUser <-. uids] [] -- relies on UniqueLmsQualificationUser if null lusers then return 0 else do forM_ lusers $ \Entity{entityVal=LmsUser{..}} -> do void $ upsertBy (UniqueLmsOrphan lmsUserQualification lmsUserIdent) LmsOrphan { lmsOrphanQualification = lmsUserQualification , lmsOrphanIdent = lmsUserIdent , lmsOrphanSeenFirst = delSeenFirst -- ensure fast deletion, since users might still to e-learning , lmsOrphanSeenLast = now -- ensure fast deletion -- fromMaybe now $ lmsUserLastReceived , lmsOrphanDeletedLast = Nothing , lmsOrphanResultLast = lmsUserStatus & lmsStatus2State , lmsOrphanReason = tReason } -- update should not happen, but just in case ensure fast deletion [ LmsOrphanSeenFirst =. delSeenFirst , LmsOrphanSeenLast =. now , LmsOrphanReason =. tReason ] audit TransactionLmsTerminated { transactionQualification = lmsUserQualification , transactionLmsIdent = lmsUserIdent , transactionLmsUser = lmsUserUser , transactionNote = tReason } fromIntegral <$> deleteWhereCount [LmsUserId <-. fmap entityKey lusers]