dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-03-30 20:45:49 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: update agent servers (#5215)

Browse Source
This commit is contained in:
Evgeny
2024-11-20 07:23:25 +00:00
committed by GitHub
parent 58c92ed004
commit 4e37efdc4a
1 changed files with 22 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

27
src/Simplex/Chat.hs
View File

@@ -1620,9 +1620,26 @@ processChatCommand' vr = \case
TestProtoServer srv -> withUser $ \User {userId} ->
processChatCommand $ APITestProtoServer userId srv
APIGetServerOperators -> CRServerOperatorConditions <$> withFastStore getServerOperators
APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do
liftIO $ setServerOperators db operatorsEnabled
CRServerOperatorConditions <$> getServerOperators db
APISetServerOperators operators -> do
as <- asks randomAgentServers
(opsConds, srvs) <- withFastStore $ \db -> do
liftIO $ setServerOperators db operators
opsConds <- getServerOperators db
let ops = serverOperators opsConds
ops' = map Just ops <> [Nothing]
opDomains = operatorDomains ops
liftIO $ fmap (opsConds,) . mapM (getServers db as ops' opDomains) =<< getUsers db
lift $ withAgent' $ \a -> forM_ srvs $ \(auId, (smp', xftp')) -> do
setProtocolServers a auId smp'
setProtocolServers a auId xftp'
pure $ CRServerOperatorConditions opsConds
where
getServers :: DB.Connection -> RandomAgentServers -> [Maybe ServerOperator] -> [(Text, ServerOperator)] -> User -> IO (UserId, (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP)))
getServers db as ops opDomains user = do
smpSrvs <- getProtocolServers db SPSMP user
xftpSrvs <- getProtocolServers db SPXFTP user
uss <- groupByOperator (ops, smpSrvs, xftpSrvs)
pure $ (aUserId user,) $ useServers as opDomains uss
APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db -> do
CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
APISetUserServers userId userServers -> withUserId userId $ \user -> do
@@ -2955,8 +2972,8 @@ processChatCommand' vr = \case
getUserOperatorServers :: DB.Connection -> User -> ExceptT StoreError IO (User, [UserOperatorServers])
getUserOperatorServers db user = do
uss <- liftIO . groupByOperator =<< getUserServers db user
pure (user, map updatedUserServers uss)
updatedUserServers uss = uss {operator = updatedOp <$> operator' uss} :: UserOperatorServers
pure (user, map updatedUserSrvs uss)
updatedUserSrvs uss = uss {operator = updatedOp <$> operator' uss} :: UserOperatorServers
updatedOp op = fromMaybe op $ find matchingOp $ mapMaybe operator' userServers
where
matchingOp op' = operatorId op' == operatorId op