fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

refactor(qualifications): update basic qualification blocking routines (WIP)

Browse Source
This commit is contained in:
Steffen Jost 2023-06-22 16:10:06 +00:00
parent 43dbe18110
commit f22252ecc3
3 changed files with 111 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Database/Esqueleto/Utils.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later

204
src/Handler/Utils/Qualification.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
module Handler.Utils.Qualification module Handler.Utils.Qualification
( module Handler.Utils.Qualification ( module Handler.Utils.Qualification
@ -10,58 +11,66 @@ module Handler.Utils.Qualification
import Import import Import
-- import Data.Time.Calendar (CalendarDiffDays(..)) -- 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.Experimental as E -- might need TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Handler.Utils.DateTime (toMidnight) 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 -- No longer possible, needs all QualificationUserBlocks to decide! Easy to work without
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockUntil = QualificationUserBlock{..} -- isValidQualification :: HasQualificationUser a => Day -> a -> Bool
where -- isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld
qualificationUserBlockReason = qualificationBlockedReasonText reason -- ,q ^. hasQualificationUser . _qualificationUserValidUntil)
-- && isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue)
isValidQualification :: HasQualificationUser a => Day -> a -> Bool
isValidQualification d q = d `inBetween` (q ^. hasQualificationUser . _qualificationUserFirstHeld
,q ^. hasQualificationUser . _qualificationUserValidUntil)
&& isNothing (q ^. hasQualificationUser . _qualificationUserBlockedDue)
------------------ ------------------
-- SQL Snippets -- -- SQL Snippets --
------------------ ------------------
-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date -- 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 :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification nowaday = \qualUser -> validQualification nowaday qualUser =
(E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
,qualUser E.^. QualificationUserValidUntil)) -- currently valid ,qualUser E.^. QualificationUserValidUntil)) -- currently valid
E.&&. (E.notExists $ E.from $ \qualUserBlock -> do E.&&. quserBlock False nowaday qualUser
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
)
-- | Variant of `validQualification` for outer joins
validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool) validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
validQualification' nowaday qualUser = validQualification' nowaday qualUser =
(E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
,qualUser E.?. QualificationUserValidUntil)) -- currently valid ,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 :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser]
selectValidQualifications qid mbUids nowaday = 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 :: 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 Entity quid _ <- upsert
QualificationUser QualificationUser
{ qualificationUserFirstHeld = qualificationUserLastRefresh { qualificationUserFirstHeld = qualificationUserLastRefresh
@ -95,11 +104,13 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
, QualificationUserLastRefresh =. qualificationUserLastRefresh , QualificationUserLastRefresh =. qualificationUserLastRefresh
] ]
) )
whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do
block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlackFrom ] _ <- error "TODO: Continue here!"
whenIsJust block $ \qub -> -- whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do
unless (qub ^. _qualificationUserBlockUnblock) $ -- block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlockFrom ]
insert QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..} -- whenIsJust block $ \qub ->
-- unless (qub ^. _qualificationUserBlockUnblock) $ -- TODO does not work like this anymore
-- insert_ QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..}
audit TransactionQualificationUserEdit audit TransactionQualificationUserEdit
{ transactionQualificationUser = quid { transactionQualificationUser = quid
@ -154,72 +165,75 @@ qualificationUserBlocking ::
, Num n , Num n
) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m 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 authUsr <- liftHandler maybeAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let nowaday = utctDay now 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 unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now]
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
forM_ toChange' $ \(_, E.Value uid) -> do
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
audit TransactionQualificationUserBlocking audit TransactionQualificationUserBlocking
{ -- transactionQualificationUser = quid { -- transactionQualificationUser = quid
transactionQualification = qid transactionQualification = qid
, transactionUser = uid , transactionUser = uid
, transactionQualificationBlock = qb , transactionQualificationBlock = error "TODO" -- CONTINUE HERE
} }
return $ fromIntegral oks return $ fromIntegral $ length toChange
qualificationUserUnblockByReason :: -- no longer needed
( AuthId (HandlerSite m) ~ Key User -- qualificationUserUnblockByReason ::
, IsPersistBackend (YesodPersistBackend (HandlerSite m)) -- ( AuthId (HandlerSite m) ~ Key User
, BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend -- , IsPersistBackend (YesodPersistBackend (HandlerSite m))
, BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m)) -- , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
, PersistQueryWrite (YesodPersistBackend (HandlerSite m)) -- , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
, PersistUniqueWrite (YesodPersistBackend (HandlerSite m)) -- , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
, HasInstanceID (HandlerSite m) InstanceId -- , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
, YesodAuthPersist (HandlerSite m) -- , HasInstanceID (HandlerSite m) InstanceId
, HasAppSettings (HandlerSite m) -- , YesodAuthPersist (HandlerSite m)
, MonadHandler m -- , HasAppSettings (HandlerSite m)
, MonadCatch m -- , MonadHandler m
, Num n -- , MonadCatch m
) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -- , Num n
qualificationUserUnblockByReason qid uids reason = do -- ) => QualificationId -> [UserId] -> Text -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
blockedUsers <- selectList [ QualificationUserQualification ==. qid -- qualificationUserUnblockByReason qid uids reason = do
, QualificationUserBlockedDue !=. Nothing -- blockedUsers <- selectList [ QualificationUserQualification ==. qid
, QualificationUserUser <-. uids -- , QualificationUserBlockedDue !=. Nothing
] [Asc QualificationUserId] -- , QualificationUserUser <-. uids
let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers -- ] [Asc QualificationUserId]
oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ] -- let toUnblock = filter (\quent -> Just reason == quent ^? _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedReason) blockedUsers
[ QualificationUserBlockedDue =. Nothing ] -- oks <- updateWhereCount [ QualificationUserId <-. (view _entityKey <$> toUnblock) ]
forM_ toUnblock $ \ubl -> do -- [ QualificationUserBlockedDue =. Nothing ]
audit TransactionQualificationUserBlocking -- forM_ toUnblock $ \ubl -> do
{ -- transactionQualificationUser = quid -- audit TransactionQualificationUserBlocking
transactionQualification = qid -- { -- transactionQualificationUser = quid
, transactionUser = ubl ^. _entityVal . _qualificationUserUser -- transactionQualification = qid
, transactionQualificationBlock = Nothing -- , transactionUser = ubl ^. _entityVal . _qualificationUserUser
} -- , transactionQualificationBlock = Nothing
return $ fromIntegral oks -- }
-- return $ fromIntegral oks

2
src/Jobs/Handler/LMS.hs
View File

@ -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 -- SPDX-License-Identifier: AGPL-3.0-or-later