refactor(qualifications): update basic qualification blocking routines (WIP)
This commit is contained in:
parent
43dbe18110
commit
f22252ecc3
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- 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 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
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user