refactor(qualification): work on blocking WIP
This commit is contained in:
parent
64ea50ebf6
commit
a0295c7654
@ -468,7 +468,7 @@ max, min :: PersistField a
|
||||
max a b = bool a b $ b E.>. a
|
||||
min a b = bool a b $ b E.<. a
|
||||
|
||||
-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by greatest/least
|
||||
-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least
|
||||
greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
|
||||
greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b)
|
||||
|
||||
|
||||
@ -651,7 +651,10 @@ postLmsR sid qsh = do
|
||||
(LmsActRestartData{..}, selectedUsers) -> do
|
||||
let usersList = Set.toList selectedUsers
|
||||
delUsers <- runDB $ do
|
||||
when (lmsActRestartUnblock == Just True) $ do
|
||||
when (lmsActRestartUnblock == Just True && ) $ do
|
||||
authBy <- maybeAuthId
|
||||
TODO
|
||||
let unblock = toMaybe (lmsActRestartUnblock == Just True) (nowaday, "Manueller LMS Neustart", authBy)
|
||||
unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
|
||||
[ QualificationUserQualification ==. qid
|
||||
, QualificationUserUser <-. usersList
|
||||
@ -666,8 +669,8 @@ postLmsR sid qsh = do
|
||||
, QualificationUserUser <-. usersList
|
||||
, QualificationUserBlockedDue ==. Nothing
|
||||
, QualificationUserValidUntil <. cutoff
|
||||
] []
|
||||
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
|
||||
] []
|
||||
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing Nothing
|
||||
|
||||
fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
|
||||
|
||||
|
||||
@ -62,12 +62,11 @@ selectValidQualifications qid mbUids nowaday =
|
||||
------------------------
|
||||
|
||||
|
||||
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
|
||||
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
|
||||
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, Text, Maybe UserId) -> UserId -> DB () -- may also unblock
|
||||
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do
|
||||
Entity quid _ <- upsert
|
||||
QualificationUser
|
||||
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
||||
, qualificationUserBlockedDue = Nothing
|
||||
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
||||
, qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal
|
||||
, qualificationUserLastNotified = toMidnight qualificationUserLastRefresh
|
||||
, ..
|
||||
@ -76,10 +75,15 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
|
||||
[ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal]
|
||||
] ++
|
||||
[ QualificationUserValidUntil =. qualificationUserValidUntil
|
||||
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||
, QualificationUserBlockedDue =. Nothing
|
||||
, 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, ..}
|
||||
|
||||
audit TransactionQualificationUserEdit
|
||||
{ transactionQualificationUser = quid
|
||||
, transactionQualification = qualificationUserQualification
|
||||
@ -131,10 +135,26 @@ qualificationUserBlocking ::
|
||||
, MonadHandler m
|
||||
, MonadCatch m
|
||||
, Num n
|
||||
) => QualificationId -> [UserId] -> Bool -> Maybe QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
|
||||
|
||||
qualificationUserBlocking qid uids notify qb = do
|
||||
qualificationUserBlocking qid uids unblock reason notify qb = do
|
||||
authUsr <- liftHandler maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
-- TODO: filter by blocked selectList ???
|
||||
|
||||
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
|
||||
|
||||
|
||||
oks <- updateWhereCount -- prevents storage of transactionQualificatioUser
|
||||
( [ QualificationUserBlockedDue !=. Nothing | isNothing qb -- only unblock blocked qualification; allow overwrite for existing blocks
|
||||
] ++
|
||||
|
||||
@ -815,30 +815,25 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
|
||||
unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
|
||||
updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
|
||||
updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
|
||||
E.insertSelectWithConflict
|
||||
UniqueQualificationUser
|
||||
(E.from $ \qualificationUser -> do
|
||||
E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId
|
||||
return $ QualificationUser
|
||||
E.<# E.val newUserId
|
||||
E.<&> (qualificationUser E.^. QualificationUserQualification)
|
||||
E.<&> (qualificationUser E.^. QualificationUserValidUntil)
|
||||
E.<&> (qualificationUser E.^. QualificationUserLastRefresh)
|
||||
E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
|
||||
E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
|
||||
E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal)
|
||||
E.<&> (qualificationUser E.^. QualificationUserLastNotified)
|
||||
)
|
||||
(\current excluded ->
|
||||
[ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil
|
||||
, QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
|
||||
, QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld
|
||||
, QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
|
||||
, QualificationUserScheduleRenewal E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal
|
||||
, QualificationUserLastNotified E.=. combineWith current excluded E.greatest QualificationUserLastNotified
|
||||
]
|
||||
)
|
||||
deleteWhere [ QualificationUserUser ==. oldUserId ]
|
||||
usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
|
||||
E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
|
||||
E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId
|
||||
)
|
||||
E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId
|
||||
return (oldQual, newQual)
|
||||
forM_ usrQualis $ \case
|
||||
(Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
|
||||
(Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
|
||||
updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
|
||||
update newQKey
|
||||
[ QualificationUserValidUntil =. (max `on` view _qualificationUserValidUntil ) oldQUsr newQUsr
|
||||
, QualificationUserLastRefresh =. (max `on` view _qualificationUserLastRefresh ) oldQUsr newQUsr
|
||||
, QualificationUserFirstHeld =. (min `on` view _qualificationUserFirstHeld ) oldQUsr newQUsr
|
||||
, QualificationUserScheduleRenewal =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr
|
||||
, QualificationUserLastNotified =. (max `on` view _qualificationUserLastNotified ) oldQUsr newQUsr
|
||||
]
|
||||
delete oldQKey
|
||||
-- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed
|
||||
|
||||
-- Supervision is fully merged
|
||||
E.insertSelectWithConflict
|
||||
|
||||
Loading…
Reference in New Issue
Block a user