-- SPDX-FileCopyrightText: 2022-23 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 (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) 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) )) ) -- 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 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 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{qualificationValidDuration=Just renewalMonths} -> do cutoff <- maybe (liftIO getCurrentTime) return renewalTime quEntsAll <- selectValidQualifications qid uids cutoff let cutoffday = utctDay cutoff maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do let newValidTo = addGregorianMonthsRollOver (toInteger 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 uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify] 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