From 996e6a0ce563bda96638863efd40ce38fce8ac2b Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 12 Jun 2024 11:47:23 +0200 Subject: [PATCH] fix(avs): repeated avs sync enqueue no longe violates duplicate db uniqueness constraints --- src/Handler/Admin.hs | 2 +- src/Handler/Profile.hs | 4 ++-- src/Handler/Users.hs | 38 +++++++++++++++++++++++--------------- src/Handler/Utils/Avs.hs | 38 +++++++++++++++++++++----------------- 4 files changed, 47 insertions(+), 35 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 53c5d6116..f15ddd5aa 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -95,7 +95,7 @@ handleAdminProblems mbProblemTable = do (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Right AvsLicenceDifferences{..}) -> do let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld - queueAvsUpdateByAID problemIds $ Just nowaday + void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday return $ Right ( Set.size avsLicenceDiffRevokeAll , Set.size avsLicenceDiffGrantVorfeld diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 21c0570a8..0515e8daa 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1270,6 +1270,6 @@ getAdminUserSyncLdapR uuid = do getAdminUserSyncAvsR :: CryptoUUIDUser -> Handler Html getAdminUserSyncAvsR uuid = do uid <- decrypt uuid - queueAvsUpdateByUID (Set.singleton uid) Nothing - addMessageI Success $ MsgSynchroniseAvsUserQueued 1 + n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing + addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n redirectUltDest $ AdminUserR uuid diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 9bfc6f7f7..9d9f8ad82 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -62,19 +62,20 @@ hijackUserForm = \csrf -> do -- instance HasUser (DBRow (Entity USer)) where -- hasUser = _entityVal -data UserAction = UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor | UserAvsSync +data UserAction = UserAvsSync | UserLdapSync | UserAddSupervisor | UserSetSupervisor | UserRemoveSupervisor deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) nullaryPathPiece ''UserAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''UserAction id -data UserActionData = UserLdapSyncData +data UserActionData = UserAvsSyncData + | UserLdapSyncData | UserHijack | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text } | UserRemoveSupervisorData - | UserAvsSyncData + deriving (Eq, Ord, Read, Show, Generic) isNotSetSupervisor :: UserActionData -> Bool @@ -369,8 +370,8 @@ postUsersR = do addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do - queueAvsUpdateByUID userSet Nothing - addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet + n <- runDB $ queueAvsUpdateByUID userSet Nothing + addMessageI Success . MsgSynchroniseAvsUserQueued $ fromIntegral n redirectKeepGetParams UsersR (UserHijack, Set.lookupMin -> Just uid) -> hijackUser uid >>= sendResponse @@ -404,16 +405,23 @@ postUsersR = do runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) addMessageI Success MsgSynchroniseLdapAllUsersQueued redirect UsersR - AllUsersAvsSync -> do - nowaday <- liftIO getCurrentTime <&> utctDay - n <- runDB $ Ex.insertSelectCount $ do - usr <- Ex.from $ Ex.table @User - return (AvsSync - Ex.<# (usr Ex.^. UserId) - Ex.<&> E.now_ - -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock - Ex.<&> E.justVal nowaday - ) + AllUsersAvsSync -> do + now <- liftIO getCurrentTime + let nowaday = utctDay now + n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser + ( do + usr <- Ex.from $ Ex.table @User + return (AvsSync + Ex.<# (usr Ex.^. UserId) + Ex.<&> E.val now + -- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock + Ex.<&> E.justVal nowaday + ) + ) (\current excluded -> + [ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime) + , AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause) + ] + ) queueJob' JobSynchroniseAvsQueue addMessageI Success $ MsgSynchroniseAvsAllUsersQueued n redirect UsersR diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 97adb5cd9..69c8afa16 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -61,7 +61,7 @@ import Handler.Utils.Memcached import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import Servant.Client.Core.ClientError (ClientError) @@ -648,24 +648,28 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do ] +queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> DB Int64 +queueAvsUpdateByUID uids = queueAvsUpdateAux (E.table @User) (E.^. UserId) (\usr -> usr E.^. UserId `E.in_` E.vals uids) -queueAvsUpdateByUID :: (MonoFoldable mono, UserId ~ Element mono) => mono -> Maybe Day -> Handler () -queueAvsUpdateByUID uids pause = do - now <- liftIO getCurrentTime - runDB $ putMany [AvsSync uid now pause | uid <- toList uids] - queueJob' JobSynchroniseAvsQueue +queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> DB Int64 +queueAvsUpdateByAID aids = queueAvsUpdateAux (E.table @UserAvs) (E.^. UserAvsUser) (\usrAvs -> usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids) -queueAvsUpdateByAID :: (MonoFoldable mono, AvsPersonId ~ Element mono) => mono -> Maybe Day -> Handler () -queueAvsUpdateByAID aids pause = do - now <- liftIO getCurrentTime - runDB $ do - uids <- E.select $ do - usrAvs <- E.from $ E.table @UserAvs - E.where_ $ usrAvs E.^. UserAvsPersonId `E.in_` E.vals aids - -- E.&&. (E.isNothing pause E.||. pause E.>. E.dayMaybe (usrAvs E.?. UserAvsLastSynch)) -- pause is checked later on in JobSynchroniseAvsQueue - return $ usrAvs E.^. UserAvsUser - putMany [AvsSync uid now pause | E.Value uid <- uids] - queueJob' JobSynchroniseAvsQueue +-- queueAvsUpdateAux :: E.From (E.SqlExpr (Entity ent)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value UserId)) -> (E.SqlExpr (Entity ent) -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64 +queueAvsUpdateAux :: E.From t -> (t -> E.SqlExpr (E.Value UserId)) -> (t -> E.SqlExpr (E.Value Bool)) -> Maybe Day -> DB Int64 +queueAvsUpdateAux tbl prj fltr pause = do + now <- liftIO getCurrentTime + n <- E.insertSelectWithConflictCount UniqueAvsSyncUser + ( do + usr <- E.from tbl + E.where_ $ fltr usr + return (AvsSync E.<# prj usr E.<&> E.val now E.<&> E.val pause) + ) (\current excluded -> + [ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime) + , AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause) + ] + ) + runDBJobs' $ queueDBJob JobSynchroniseAvsQueue + return n -- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo;