diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 78cf1ab1d..a0c5cb6f5 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index af3b1fd75..d569a1d5c 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -1,7 +1,8 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} module Handler.Utils.Qualification ( module Handler.Utils.Qualification @@ -10,58 +11,66 @@ module Handler.Utils.Qualification import Import -- import Data.Time.Calendar (CalendarDiffDays(..)) -import Database.Persist.Sql (updateWhereCount) +-- 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) +-- needs refactoring, probbably no longer helpful +mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationUserId -> QualificationUserBlock +mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} + where + qualificationUserBlockReason = qualificationBlockedReasonText reason + qualificationUserBlockUnblock = False + qualificationUserBlockBlocker = Nothing -mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> Maybe Day -> QualificationUserBlock -mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockUntil = QualificationUserBlock{..} - where - qualificationUserBlockReason = qualificationBlockedReasonText reason - - -isValidQualification :: HasQualificationUser a => Day -> a -> Bool -isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld - ,q ^. hasQualificationUser . _qualificationUserValidUntil) - && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) +-- No longer possible, needs all QualificationUserBlocks to decide! Easy to work without +-- isValidQualification :: HasQualificationUser a => Day -> a -> Bool +-- isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld +-- ,q ^. hasQualificationUser . _qualificationUserValidUntil) +-- && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue) ------------------ -- SQL Snippets -- ------------------ -- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date --- validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) --- validQualification nowaday = \qualUser -> --- (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld --- ,qualUser E.^. QualificationUserValidUntil)) -- currently valid --- E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue) -- not blocked +quserBlockAux :: Bool -> Day -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) +quserBlockAux negCond nowaday checkQualUserId = 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.<=. E.val nowaday) + 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.<=. E.val nowaday + E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom + ) + +-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked +quserBlock :: Bool -> Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) +quserBlock negCond aday qualUser = quserBlockAux negCond aday (E.==. (qualUser E.^. QualificationUserId)) + +-- | Variant of `isBlocked` for outer joins +quserBlock' :: Bool -> Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) +quserBlock' negCond aday qualUser = quserBlockAux negCond aday (E.=?. (qualUser E.?. QualificationUserId)) validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool) -validQualification nowaday = \qualUser -> +validQualification nowaday qualUser = (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld ,qualUser E.^. QualificationUserValidUntil)) -- currently valid - E.&&. (E.notExists $ E.from $ \qualUserBlock -> do - E.where_ $ E.not (qualUserBlock E.^. QualificationUserBlockUnblock) - E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val nowaday - E.&&. qualUserBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId - E.&&. E.notExists $ E.from $ \qualUserUnblock -> do - E.where_ (qualUserUnblock E.^. QualificationUserBlockUnblock) - E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.<=. E.val nowaday - E.&&. qualUserUnblock E.^. QualificationUserBlockFrom E.>=. qualUserBlock E.^. QualificationUserBlockFrom - E.&&. qualUserUnBlock E.^. QualificationUserBlockQualificationUser E.==. qualUser E.^. QualificationUserId - ) - + E.&&. quserBlock False nowaday qualUser +-- | Variant of `validQualification` for outer joins validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) validQualification' nowaday qualUser = (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld ,qualUser E.?. QualificationUserValidUntil)) -- currently valid - E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue) -- not blocked - + E.&&. quserBlock' False nowaday qualUser selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser] selectValidQualifications qid mbUids nowaday = @@ -80,7 +89,7 @@ selectValidQualifications qid mbUids nowaday = upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, Text, Maybe UserId) -> UserId -> DB () -- may also unblock -upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do +upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal _mbUnblockBecause qualificationUserUser = do Entity quid _ <- upsert QualificationUser { qualificationUserFirstHeld = qualificationUserLastRefresh @@ -95,11 +104,13 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef , QualificationUserLastRefresh =. qualificationUserLastRefresh ] ) - whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do - block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlackFrom ] - whenIsJust block $ \qub -> - unless (qub ^. _qualificationUserBlockUnblock) $ - insert QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} + + _ <- error "TODO: Continue here!" + -- whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do + -- block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ] + -- whenIsJust block $ \qub -> + -- unless (qub ^. _qualificationUserBlockUnblock) $ -- TODO does not work like this anymore + -- insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} audit TransactionQualificationUserEdit { transactionQualificationUser = quid @@ -154,72 +165,75 @@ qualificationUserBlocking :: , Num n ) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserBlocking qid uids unblock reason notify qb = do +qualificationUserBlocking qid uids unblock reason notify = do authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime let nowaday = utctDay now - -- TODO: filter by blocked selectList ??? + -- -- 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) nowaday qualificationUser -- only unblock blocked qualification and vice versa + -- return $ QualificationUserBlock + -- E.<# qualificationUser E.^. QualificationUserId + -- E.<&> E.val unblock + -- E.<&> E.val nowaday + -- 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) nowaday qualUser -- only unblock blocked qualification and vice versa + return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser) + let toChange = E.unValue . fst <$> toChange' + E.insertMany_ $ map (\quid -> QualificationUserBlock + { qualificationUserBlockQualificationUser = quid + , qualificationUserBlockUnblock = unblock + , qualificationUserBlockFrom = nowaday + , qualificationUserBlockReason = reason + , qualificationUserBlockBlocker = authUsr + }) toChange - E.insertSelect . E.from $ \qualificationUser -> do - E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid - E.&&. qualificationUser E.^. QualificationUserUser E.in_ E.valList uid - E.&&. -- TODO: latest entry is just sql for - return $ QualificationUserBlock - E.<# qualificationUser E.^. QualificationUserId - E.<&> E.val unblock - E.<&> E.val nowaday - E.<&> E.val reason - E.<&> E.val authUsr + unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now] - - oks <- updateWhereCount -- prevents storage of transactionQualificatioUser - ( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks - ] ++ - [ QualificationUserQualification ==. qid - , QualificationUserUser <-. uids - ] - ) - (guardMonoid (not notify) - [ QualificationUserLastNotified =. now - ] ++ - [ QualificationUserBlockedDue =. qb - ]) - forM_ uids $ \uid -> do + forM_ toChange' $ \(_, E.Value uid) -> do audit TransactionQualificationUserBlocking { -- transactionQualificationUser = quid transactionQualification = qid , transactionUser = uid - , transactionQualificationBlock = qb + , transactionQualificationBlock = error "TODO" -- CONTINUE HERE } - return $ fromIntegral oks + return $ fromIntegral $ length toChange -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] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserUnblockByReason qid uids reason = do - blockedUsers <- selectList [ QualificationUserQualification ==. qid - , QualificationUserBlockedDue !=. Nothing - , QualificationUserUser <-. uids - ] [Asc QualificationUserId] - let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers - oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ] - [ QualificationUserBlockedDue =. Nothing ] - forM_ toUnblock $ \ubl -> do - audit TransactionQualificationUserBlocking - { -- transactionQualificationUser = quid - transactionQualification = qid - , transactionUser = ubl ^. _entityVal . _qualificationUserUser - , transactionQualificationBlock = Nothing - } - return $ fromIntegral oks \ No newline at end of file +-- no longer needed +-- 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] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +-- qualificationUserUnblockByReason qid uids reason = do +-- blockedUsers <- selectList [ QualificationUserQualification ==. qid +-- , QualificationUserBlockedDue !=. Nothing +-- , QualificationUserUser <-. uids +-- ] [Asc QualificationUserId] +-- let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers +-- oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ] +-- [ QualificationUserBlockedDue =. Nothing ] +-- forM_ toUnblock $ \ubl -> do +-- audit TransactionQualificationUserBlocking +-- { -- transactionQualificationUser = quid +-- transactionQualification = qid +-- , transactionUser = ubl ^. _entityVal . _qualificationUserUser +-- , transactionQualificationBlock = Nothing +-- } +-- return $ fromIntegral oks \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1795167c0..f366630ec 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later