-- 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 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.DateTime (toMidnight) import Handler.Utils.Widgets (statusHtml) statusQualificationBlock :: Bool -> Html statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s -- needs refactoring, probbably no longer helpful mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} where qualificationUserBlockReason = qualificationBlockedReasonText 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 quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool) quserToNotify quser cutoff = -- recently invalid or... ( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil E.&&. E.notExists (do qualUserBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff E.&&. E.notExists (do -- block is the most recent block qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock) qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff ) ) ) E.||. E.exists (do -- ...recently blocked qualUserBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) -- block is not an unblock E.&&. E.day (qualUserBlock E.^. QualificationUserBlockFrom) E.<. quser E.^. QualificationUserValidUntil -- block was essential during validity E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified -- block has not yet been communicated E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff -- block is already active E.&&. E.notExists (do -- block is the most recent block qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)) qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff ) ) -- condition to ensure that the lastes 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.^. QualificationUserBlockFrom E.<=. cutoff E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom E.&&. newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser ) -- 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 ) 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 -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser] selectValidQualifications :: ( MonadIO m , BackendCompatible SqlBackend backend , PersistQueryRead backend , PersistUniqueRead backend ) => QualificationId -> Maybe [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser] selectValidQualifications qid mbUids cutoff = -- cutoff <- utctDay <$> liftIO getCurrentTime E.select $ do qUser <- E.from $ E.table @QualificationUser E.where_ $ (qUser E.^. QualificationUserQualification E.==. E.val qid) E.&&. validQualification cutoff qUser -- E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids 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 -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do Entity quid _ <- upsert QualificationUser { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal , qualificationUserLastNotified = toMidnight qualificationUserLastRefresh , .. } ( [ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal] ] ++ [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) audit TransactionQualificationUserEdit { transactionQualificationUser = quid , transactionQualification = qualificationUserQualification , transactionUser = qualificationUserUser , transactionQualificationValidUntil = qualificationUserValidUntil , transactionQualificationScheduleRenewal = mbScheduleRenewal } -- | 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 UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int renewValidQualificationUsers qid 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 now <- maybe (liftIO getCurrentTime) return renewalTime quEntsAll <- selectValidQualifications qid (Just uids) now let nowaday = utctDay now maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday 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 =. nowaday ] audit TransactionQualificationUserEdit { transactionQualificationUser = quId , transactionQualification = qualificationUserQualification , transactionUser = qualificationUserUser , transactionQualificationValidUntil = newValidTo , transactionQualificationScheduleRenewal = Nothing } return $ length quEnts _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. -- | Block or unblock some users for a given reason 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 -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do 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 (not 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 (not unblock) blockTime qualUser -- only unblock blocked qualification and vice versa return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) let newBlocks = [ (quid, uid, qub) | (E.Value quid, E.Value uid) <- toChange , let qub = QualificationUserBlock { qualificationUserBlockQualificationUser = quid , qualificationUserBlockUnblock = unblock , qualificationUserBlockFrom = blockTime , qualificationUserBlockReason = reason , qualificationUserBlockBlocker = authUsr } ] E.insertMany_ (trd3 <$> newBlocks) unless notify $ updateWhere [QualificationUserId <-. (fst3 <$> newBlocks)] [QualificationUserLastNotified =. now] 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 -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do now <- 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 now) (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