From f31476206724f968c806d27d6dd70d72fa0006e0 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 26 Jun 2024 20:38:16 +0400 Subject: [PATCH] core: add known server api --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 57 ++++++++++++++++++++-------------- src/Simplex/Chat/Controller.hs | 1 + 4 files changed, 37 insertions(+), 25 deletions(-) diff --git a/cabal.project b/cabal.project index a3d236d611..bb2b32364c 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 9459964d204d0717f04cecf3473c2387461905ae + tag: 5021f78a7e231fb3764f3bc3865c6902dcaebebc source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index bd60bcdc36..d9f1884d8a 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."9459964d204d0717f04cecf3473c2387461905ae" = "0yrcdc07q86kaw35y3pk52chgmxhv5yc348wd2fw89p7lfqcgwwy"; + "https://github.com/simplex-chat/simplexmq.git"."5021f78a7e231fb3764f3bc3865c6902dcaebebc" = "0yrcdc07q86kaw35y3pk52chgmxhv5yc348wd2fw89p7lfqcgwwy"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index ebbf7a11d6..6bd13848a2 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -309,12 +309,12 @@ newChatController agentServers :: ChatConfig -> IO InitialAgentServers agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do users <- withTransaction chatStore getUsers - smp' <- getUserServers users SPSMP - xftp' <- getUserServers users SPXFTP + smp' <- getUsersServers users SPSMP + xftp' <- getUsersServers users SPXFTP pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg} where - getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p))) - getUserServers users protocol = case users of + getUsersServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p))) + getUsersServers users protocol = case users of [] -> pure $ M.fromList [(1, cfgServers protocol defServers)] _ -> M.fromList <$> initialServers where @@ -1309,19 +1309,21 @@ processChatCommand' vr = \case withStore (\db -> Just <$> getConnectionEntity db vr user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing) pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessages = map ntfMsgInfo msgs} APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do - ChatConfig {defaultServers} <- asks config - servers <- withStore' (`getProtocolServers` user) - let defServers = cfgServers p defaultServers - servers' = fromMaybe (L.map toServerCfg defServers) $ nonEmpty servers - pure $ CRUserProtoServers user $ AUPS $ UserProtoServers p servers' defServers - where - toServerCfg server = ServerCfg {server, preset = True, tested = Nothing, enabled = SEEnabled} + (srvCfgs, defServers) <- getUserServers user p + pure $ CRUserProtoServers user $ AUPS $ UserProtoServers p srvCfgs defServers GetUserProtoServers aProtocol -> withUser $ \User {userId} -> processChatCommand $ APIGetUserProtoServers userId aProtocol - APISetUserProtoServers userId (APSC p (ProtoServersConfig servers)) -> withUserId userId $ \user -> withServerProtocol p $ do - withStore $ \db -> overwriteProtocolServers db user servers + APISetUserProtoServers userId (APSC p (ProtoServersConfig srvsCfg)) -> withUserId userId $ \user -> withServerProtocol p $ do + withStore $ \db -> overwriteProtocolServers db user srvsCfg cfg <- asks config - lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ activeAgentServers cfg p servers + lift $ withAgent' $ \a -> setProtocolServers a (aUserId user) $ activeAgentServers cfg p srvsCfg + ok user + APIAddKnownProtoServer userId (AProtoServerWithAuth p newSrv) -> withUserId userId $ \user -> withServerProtocol p $ do + (srvCfgs, _) <- getUserServers user p + when (protoServer newSrv `elem` map (\ServerCfg {server} -> protoServer server) (L.toList srvCfgs)) $ + throwChatError (CECommandError "server already configured") + let newSrvCfg = ServerCfg {server = newSrv, preset = False, tested = Nothing, enabled = SEKnown} + withStore $ \db -> overwriteProtocolServers db user (L.toList srvCfgs <> [newSrvCfg]) ok user SetUserProtoServers serversConfig -> withUser $ \User {userId} -> processChatCommand $ APISetUserProtoServers userId serversConfig @@ -2256,16 +2258,16 @@ processChatCommand' vr = \case GetAgentServersSummary userId -> withUserId userId $ \user -> do agentServersSummary <- lift $ withAgent' getAgentServersSummary users <- withStore' getUsers - smpServers <- getUserServers user SPSMP - xftpServers <- getUserServers user SPXFTP + smpServers <- getUserSrvs user SPSMP + xftpServers <- getUserSrvs user SPXFTP let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers pure $ CRAgentServersSummary user presentedServersSummary where - getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => User -> SProtocolType p -> CM [ProtocolServer p] - getUserServers users protocol = do + getUserSrvs :: forall p. (ProtocolTypeI p, UserProtocol p) => User -> SProtocolType p -> CM [ProtocolServer p] + getUserSrvs user protocol = do ChatConfig {defaultServers} <- asks config let defServers = cfgServers protocol defaultServers - servers <- map (\ServerCfg {server} -> server) <$> withStore' (`getProtocolServers` users) + servers <- map (\ServerCfg {server} -> server) <$> withStore' (`getProtocolServers` user) let srvs = if null servers then L.toList defServers else servers pure $ map protoServer srvs ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_ @@ -2858,6 +2860,16 @@ processChatCommand' vr = \case msgInfo <- withStore' (`getLastRcvMsgInfo` connId) CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) +getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => User -> SProtocolType p -> CM (NonEmpty (ServerCfg p), NonEmpty (ProtoServerWithAuth p)) +getUserServers user p = do + ChatConfig {defaultServers} <- asks config + servers <- withStore' (`getProtocolServers` user) + let defServers = cfgServers p defaultServers + userServers = fromMaybe (L.map defServerCfg defServers) $ nonEmpty servers + pure (userServers, defServers) + where + defServerCfg server = ServerCfg {server, preset = True, tested = Nothing, enabled = SEEnabled} + contactCITimed :: Contact -> CM (Maybe CITimed) contactCITimed ct = sndContactCITimed False ct Nothing @@ -3242,10 +3254,8 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} S.toList $ S.fromList $ concatMap (\FD.FileChunk {replicas} -> map (\FD.FileChunkReplica {server} -> server) replicas) chunks getUnknownSrvs :: [XFTPServer] -> CM [XFTPServer] getUnknownSrvs srvs = do - ChatConfig {defaultServers = DefaultAgentServers {xftp = defXftp}} <- asks config - storedSrvs <- map (\ServerCfg {server} -> protoServer server) <$> withStore' (`getProtocolServers` user) - let defXftp' = L.map protoServer defXftp - knownSrvs = fromMaybe defXftp' $ nonEmpty storedSrvs + (srvCfgs, _) <- getUserServers user SPXFTP + let knownSrvs = map (\ServerCfg {server} -> protoServer server) (L.toList srvCfgs) pure $ filter (`notElem` knownSrvs) srvs ipProtectedForSrvs :: [XFTPServer] -> CM Bool ipProtectedForSrvs srvs = do @@ -7441,6 +7451,7 @@ chatCommandP = "/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP), "/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP), "/_servers " *> (APISetUserProtoServers <$> A.decimal <* A.space <*> srvCfgP), + "/_known server " *> (APIAddKnownProtoServer <$> A.decimal <* A.space <*> strP), "/smp " *> (SetUserProtoServers . APSC SPSMP . ProtoServersConfig . map toServerCfg <$> protocolServersP), "/smp default" $> SetUserProtoServers (APSC SPSMP $ ProtoServersConfig []), "/xftp " *> (SetUserProtoServers . APSC SPXFTP . ProtoServersConfig . map toServerCfg <$> protocolServersP), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 04eae4e792..595a583165 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -344,6 +344,7 @@ data ChatCommand | APIGetUserProtoServers UserId AProtocolType | GetUserProtoServers AProtocolType | APISetUserProtoServers UserId AProtoServersConfig + | APIAddKnownProtoServer UserId AProtoServerWithAuth | SetUserProtoServers AProtoServersConfig | APITestProtoServer UserId AProtoServerWithAuth | TestProtoServer AProtoServerWithAuth