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: different roles for different protocols (#5185)

Browse Source 
* core: different roles for different protocols

* include current conditions in responses

* fix

* fix test

* fix

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny
2024-11-15 12:08:15 +00:00
committed by GitHub
co-authored by spaced4ndy
parent ff8e29c0eb
commit feb687d3b8
8 changed files with 104 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+15 -13
View File
@@ -150,7 +150,8 @@ operatorSimpleXChat =
serverDomains = ["simplex.im"],
conditionsAcceptance = CARequired Nothing,
enabled = True,
roles = allRoles
smpRoles = allRoles,
xftpRoles = allRoles
}
operatorFlux :: NewServerOperator
@@ -163,7 +164,8 @@ operatorFlux =
serverDomains = ["simplexonflux.com"],
conditionsAcceptance = CARequired Nothing,
enabled = False,
roles = ServerRoles {storage = False, proxy = True}
smpRoles = ServerRoles {storage = False, proxy = True},
xftpRoles = allRoles
}
defaultChatConfig :: ChatConfig
@@ -420,7 +422,7 @@ newChatController
getServers p users opDomains = do
let rs' = rndServers p rs
fmap M.fromList $ forM users $ \u ->
(aUserId u,) . agentServerCfgs opDomains rs' <$> getUpdateUserServers db p presetOps rs' u
(aUserId u,) . agentServerCfgs p opDomains rs' <$> getUpdateUserServers db p presetOps rs' u
updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig
updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} =
@@ -643,10 +645,10 @@ processChatCommand' vr = \case
forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash} ->
when (n == displayName) . throwChatError $
if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""}
opDomains <- operatorDomains . fst <$> withFastStore getServerOperators
opDomains <- operatorDomains . serverOperators <$> withFastStore getServerOperators
rs <- asks randomServers
let smp = agentServerCfgs opDomains (rndServers SPSMP rs) smpServers
xftp = agentServerCfgs opDomains (rndServers SPXFTP rs) xftpServers
let smp = agentServerCfgs SPSMP opDomains (rndServers SPSMP rs) smpServers
xftp = agentServerCfgs SPXFTP opDomains (rndServers SPXFTP rs) xftpServers
auId <- withAgent (\a -> createUser a smp xftp)
ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure
user <- withFastStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
@@ -1601,10 +1603,10 @@ processChatCommand' vr = \case
lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server)
TestProtoServer srv -> withUser $ \User {userId} ->
processChatCommand $ APITestProtoServer userId srv
APIGetServerOperators -> uncurry CRServerOperators <$> withFastStore getServerOperators
APIGetServerOperators -> CRServerOperatorConditions <$> withFastStore getServerOperators
APISetServerOperators operatorsEnabled -> withFastStore $ \db -> do
liftIO $ setServerOperators db operatorsEnabled
uncurry CRServerOperators <$> getServerOperators db
CRServerOperatorConditions <$> getServerOperators db
APIGetUserServers userId -> withUserId userId $ \user -> withFastStore $ \db ->
CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
APISetUserServers userId userServers -> withUserId userId $ \user -> do
@@ -1617,8 +1619,8 @@ processChatCommand' vr = \case
rs <- asks randomServers
lift $ withAgent' $ \a -> do
let auId = aUserId user
setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPSMP rs) smpServers
setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPXFTP rs) xftpServers
setProtocolServers a auId $ agentServerCfgs SPSMP opDomains (rndServers SPSMP rs) smpServers
setProtocolServers a auId $ agentServerCfgs SPXFTP opDomains (rndServers SPXFTP rs) xftpServers
ok_
APIValidateServers userId userServers -> withUserId userId $ \user ->
CRUserServersValidation user <$> validateAllUsersServers userId userServers
@@ -1641,7 +1643,7 @@ processChatCommand' vr = \case
APIAcceptConditions condId opIds -> withFastStore $ \db -> do
currentTs <- liftIO getCurrentTime
acceptConditions db condId opIds currentTs
uncurry CRServerOperators <$> getServerOperators db
CRServerOperatorConditions <$> getServerOperators db
APISetChatItemTTL userId newTTL_ -> withUserId userId $ \user ->
checkStoreNotChanged $
withChatLock "setChatItemTTL" $ do
@@ -3777,9 +3779,9 @@ getKnownAgentServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p ->
getKnownAgentServers p user = do
rs <- asks randomServers
withStore $ \db -> do
opDomains <- operatorDomains . fst <$> getServerOperators db
opDomains <- operatorDomains . serverOperators <$> getServerOperators db
srvs <- liftIO $ getProtocolServers db p user
pure $ L.toList $ agentServerCfgs opDomains (rndServers p rs) srvs
pure $ L.toList $ agentServerCfgs p opDomains (rndServers p rs) srvs
protoServer' :: ServerCfg p -> ProtocolServer p
protoServer' ServerCfg {server} = protoServer server