blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

core: optimize group deletion (delays deletion of unused contacts) (#2560)

Browse Source 
* core: optimize group deletion (wip)

* delay deletion of unused contacts

* clean up, fix test

* rename field

* remove from type, more checks, remove ctx

* remove space

* rename functions

* rename

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
spaced4ndy
2023-06-12 13:45:39 +04:00
committed by GitHub
parent d4f9429fc1
commit 425c7b947f
8 changed files with 109 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+20 -8
View File
@@ -121,6 +121,7 @@ defaultChatConfig =
testView = False,
initialCleanupManagerDelay = 30 * 1000000, -- 30 seconds
cleanupManagerInterval = 30 * 60, -- 30 minutes
cleanupManagerStepDelay = 3 * 1000000, -- 3 seconds
ciExpirationInterval = 30 * 60 * 1000000 -- 30 minutes
}
@@ -867,7 +868,7 @@ processChatCommand = \case
Just _ -> pure []
Nothing -> do
conns <- withStore $ \db -> getContactConnections db userId ct
withStore' (\db -> deleteContactWithoutGroups db user ct)
withStore' (\db -> setContactDeleted db user ct)
`catchError` (toView . CRChatError (Just user))
pure $ map aConnId conns
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
@@ -2358,15 +2359,16 @@ cleanupManager :: forall m. ChatMonad m => m ()
cleanupManager = do
interval <- asks (cleanupManagerInterval . config)
runWithoutInitialDelay interval
delay <- asks (initialCleanupManagerDelay . config)
liftIO $ threadDelay' delay
initialDelay <- asks (initialCleanupManagerDelay . config)
liftIO $ threadDelay' initialDelay
stepDelay <- asks (cleanupManagerStepDelay . config)
forever $ do
flip catchError (toView . CRChatError Nothing) $ do
waitChatStarted
users <- withStoreCtx' (Just "cleanupManager, getUsers 1") getUsers
let (us, us') = partition activeUser users
forM_ us $ cleanupUser interval
forM_ us' $ cleanupUser interval
forM_ us $ cleanupUser interval stepDelay
forM_ us' $ cleanupUser interval stepDelay
cleanupMessages `catchError` (toView . CRChatError Nothing)
liftIO $ threadDelay' $ diffToMicroseconds interval
where
@@ -2376,13 +2378,21 @@ cleanupManager = do
let (us, us') = partition activeUser users
forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchError` (toView . CRChatError (Just u))
forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchError` (toView . CRChatError (Just u))
cleanupUser cleanupInterval user =
cleanupUser cleanupInterval stepDelay user = do
cleanupTimedItems cleanupInterval user `catchError` (toView . CRChatError (Just user))
liftIO $ threadDelay' stepDelay
cleanupDeletedContacts user `catchError` (toView . CRChatError (Just user))
liftIO $ threadDelay' stepDelay
cleanupTimedItems cleanupInterval user = do
ts <- liftIO getCurrentTime
let startTimedThreadCutoff = addUTCTime cleanupInterval ts
timedItems <- withStoreCtx' (Just "cleanupManager, getTimedItems") $ \db -> getTimedItems db user startTimedThreadCutoff
forM_ timedItems $ \(itemRef, deleteAt) -> startTimedItemThread user itemRef deleteAt `catchError` const (pure ())
cleanupDeletedContacts user = do
contacts <- withStore' (`getDeletedContacts` user)
forM_ contacts $ \ct ->
withStore' (\db -> deleteContactWithoutGroups db user ct)
`catchError` (toView . CRChatError (Just user))
cleanupMessages = do
ts <- liftIO getCurrentTime
let cutoffTs = addUTCTime (- (30 * nominalDay)) ts
@@ -4295,7 +4305,9 @@ throwChatError = throwError . ChatError
deleteMembersConnections :: ChatMonad m => User -> [GroupMember] -> m ()
deleteMembersConnections user members = do
let memberConns = mapMaybe (\GroupMember {activeConn} -> activeConn) members
let memberConns =
filter (\Connection {connStatus} -> connStatus /= ConnDeleted) $
mapMaybe (\GroupMember {activeConn} -> activeConn) members
deleteAgentConnectionsAsync user $ map aConnId memberConns
forM_ memberConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
@@ -4719,7 +4731,6 @@ withStoreCtx ctx_ action = do
ChatController {chatStore} <- ask
liftEitherError ChatErrorStore $ case ctx_ of
Nothing -> withTransaction chatStore (runExceptT . action) `E.catch` handleInternal ""
Just _ -> withTransaction chatStore (runExceptT . action) `E.catch` handleInternal ""
-- uncomment to debug store performance
-- Just ctx -> do
-- t1 <- liftIO getCurrentTime
@@ -4728,6 +4739,7 @@ withStoreCtx ctx_ action = do
-- t2 <- liftIO getCurrentTime
-- putStrLn $ "withStoreCtx end :: " <> show t2 <> " :: " <> ctx <> " :: duration=" <> show (diffToMilliseconds $ diffUTCTime t2 t1)
-- pure r
Just _ -> withTransaction chatStore (runExceptT . action) `E.catch` handleInternal ""
where
handleInternal :: String -> E.SomeException -> IO (Either StoreError a)
handleInternal ctxStr e = pure . Left . SEInternalError $ show e <> ctxStr