From a0295c76549b9a235a5f41d395721ecfe215cf20 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 13 Jun 2023 16:43:44 +0000 Subject: [PATCH] refactor(qualification): work on blocking WIP --- src/Database/Esqueleto/Utils.hs | 2 +- src/Handler/LMS.hs | 9 ++++--- src/Handler/Utils/Qualification.hs | 36 +++++++++++++++++++------ src/Handler/Utils/Users.hs | 43 +++++++++++++----------------- 4 files changed, 54 insertions(+), 36 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 7064697e4..78cf1ab1d 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -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) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index a96c3a839..b7638b482 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -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] diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index ccd08868a..bffbad258 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -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 ] ++ diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 087a543a7..fb19f07a7 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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