From 5ddc454049c2db09fc28845f61aeededd0a3c226 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 27 Oct 2025 12:29:38 +0000 Subject: [PATCH] core: option to run client as chat relay; cli api to get, set relays (#6407) --- bots/src/API/Docs/Commands.hs | 2 + simplex-chat.cabal | 1 + src/Simplex/Chat/Controller.hs | 5 + src/Simplex/Chat/Core.hs | 117 +++++++++++++----- src/Simplex/Chat/Library/Commands.hs | 43 ++++++- src/Simplex/Chat/Mobile.hs | 1 + src/Simplex/Chat/Operators.hs | 19 ++- src/Simplex/Chat/Options.hs | 7 ++ src/Simplex/Chat/Store/Profiles.hs | 20 +-- .../SQLite/Migrations/chat_query_plans.txt | 14 ++- src/Simplex/Chat/View.hs | 11 +- tests/ChatClient.hs | 10 +- tests/ChatTests.hs | 2 + tests/ChatTests/ChatRelays.hs | 49 ++++++++ 14 files changed, 240 insertions(+), 61 deletions(-) create mode 100644 tests/ChatTests/ChatRelays.hs diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index 4cce44e588..917226873b 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -434,6 +434,7 @@ undocumentedCommands = "GetChatItemTTL", "GetRemoteFile", "GetUserProtoServers", + "GetUserChatRelays", "ListRemoteCtrls", "ListRemoteHosts", "ReconnectAllServers", @@ -451,6 +452,7 @@ undocumentedCommands = "SetServerOperators", "SetTempFolder", "SetUserProtoServers", + "SetUserChatRelays", "SlowSQLQueries", "StartChat", "StartRemoteHost", diff --git a/simplex-chat.cabal b/simplex-chat.cabal index eafb57b512..e3ce7909b7 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -533,6 +533,7 @@ test-suite simplex-chat-test ChatClient ChatTests ChatTests.ChatList + ChatTests.ChatRelays ChatTests.Direct ChatTests.DBUtils ChatTests.Files diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index ad824d20f6..bca2131d86 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -389,6 +389,11 @@ data ChatCommand | SetUserProtoServers AProtocolType [AProtoServerWithAuth] | APITestProtoServer UserId AProtoServerWithAuth | TestProtoServer AProtoServerWithAuth + | GetUserChatRelays + | SetUserChatRelays [CLINewRelay] + -- TODO [chat relays] commands to test chat relay + -- | APITestChatRelay UserId ConnLinkContact + -- | TestChatRelay ConnLinkContact | APIGetServerOperators | APISetServerOperators (NonEmpty ServerOperator) | SetServerOperators (NonEmpty ServerOperatorRoles) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index f9bf76e5b3..40e4e61d6f 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -15,7 +15,9 @@ where import Control.Logger.Simple import Control.Monad +import Control.Monad.Except import Control.Monad.Reader +import qualified Data.ByteString.Char8 as B import Data.List (find) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -27,18 +29,21 @@ import Simplex.Chat.Library.Commands import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..), CreateBotOpts (..)) import Simplex.Chat.Remote.Types (RemoteHostId) import Simplex.Chat.Store.Profiles +import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences (FeatureAllowed (..), FilesPreference (..), Preferences (..), emptyChatPrefs) -import Simplex.Chat.View (ChatResponseEvent, serializeChatError, serializeChatResponse) +import Simplex.Chat.View (ChatResponseEvent, serializeChatError, serializeChatResponse, simplexChatContact) +import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..)) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import Simplex.Messaging.Encoding.String import System.Exit (exitFailure) import System.IO (hFlush, stdout) import Text.Read (readMaybe) import UnliftIO.Async simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO () -simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@ChatOpts {coreOptions = CoreChatOpts {dbOptions, logAgent, yesToUpMigrations, migrationBackupPath}, createBot, maintenance} chat = +simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@ChatOpts {coreOptions = coreOptions@CoreChatOpts {dbOptions, logAgent, yesToUpMigrations, migrationBackupPath}, createBot, maintenance} chat = case logAgent of Just level -> do setLogLevel level @@ -51,19 +56,21 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@Cha putStrLn $ "Error opening database: " <> show e exitFailure run db@ChatDatabase {chatStore} = do - u_ <- getSelectActiveUser chatStore + users <- withTransaction chatStore getUsers + u_ <- selectActiveUser coreOptions chatStore users let backgroundMode = not maintenance cc <- newChatController db u_ cfg opts backgroundMode - u <- maybe (createActiveUser cc createBot) pure u_ + u <- maybe (createActiveUser cc coreOptions createBot) pure u_ unless testView $ putStrLn $ "Current user: " <> userStr u unless maintenance $ forM_ (preStartHook chatHooks) ($ cc) - runSimplexChat opts u cc chat + runSimplexChat cfg opts u cc chat -runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO () -runSimplexChat ChatOpts {maintenance} u cc@ChatController {config = ChatConfig {chatHooks}} chat +runSimplexChat :: ChatConfig -> ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO () +runSimplexChat ChatConfig {testView} ChatOpts {coreOptions = CoreChatOpts {chatRelay}, maintenance} u cc@ChatController {config = ChatConfig {chatHooks}} chat | maintenance = wait =<< async (chat u cc) | otherwise = do a1 <- runReaderT (startChatController True True) cc + when (chatRelay && not testView) $ askCreateRelayAddress cc u forM_ (postStartHook chatHooks) ($ cc) a2 <- async $ chat u cc waitEither_ a1 a2 @@ -74,24 +81,30 @@ sendChatCmdStr cc s = runReaderT (execChatCommand Nothing (encodeUtf8 $ T.pack s sendChatCmd :: ChatController -> ChatCommand -> IO (Either ChatError ChatResponse) sendChatCmd cc cmd = runReaderT (execChatCommand' cmd 0) cc -getSelectActiveUser :: DBStore -> IO (Maybe User) -getSelectActiveUser st = do - users <- withTransaction st getUsers - case find activeUser users of - Just u -> pure $ Just u - Nothing -> selectUser users +selectActiveUser :: CoreChatOpts -> DBStore -> [User] -> IO (Maybe User) +selectActiveUser CoreChatOpts {chatRelay} st users + | chatRelay = + case find (\User {userChatRelay} -> isTrue userChatRelay) users of + Just u + | activeUser u -> pure $ Just u + | otherwise -> Just <$> withTransaction st (`setActiveUser` u) + Nothing -> pure Nothing + | otherwise = + case find activeUser users of + Just u -> pure $ Just u + Nothing -> selectUser where - selectUser :: [User] -> IO (Maybe User) - selectUser = \case + selectUser :: IO (Maybe User) + selectUser = case users of [] -> pure Nothing [user] -> Just <$> withTransaction st (`setActiveUser` user) - users -> do + _users -> do putStrLn "Select user profile:" forM_ (zip [1 :: Int ..] users) $ \(n, user) -> putStrLn $ show n <> ": " <> userStr user loop where loop = do - nStr <- getWithPrompt $ "user number (1 .. " <> show (length users) <> ")" + nStr <- withPrompt ("user number (1 .. " <> show (length users) <> "): ") getLine case readMaybe nStr :: Maybe Int of Nothing -> putStrLn "not a number" >> loop Just n @@ -100,39 +113,79 @@ getSelectActiveUser st = do let user = users !! (n - 1) in Just <$> withTransaction st (`setActiveUser` user) -createActiveUser :: ChatController -> Maybe CreateBotOpts -> IO User -createActiveUser cc = \case +createActiveUser :: ChatController -> CoreChatOpts -> Maybe CreateBotOpts -> IO User +createActiveUser cc CoreChatOpts {chatRelay} = \case Just CreateBotOpts {botDisplayName, allowFiles} -> do let preferences = if allowFiles then Nothing else Just emptyChatPrefs {files = Just FilesPreference {allow = FANo}} createUser exitFailure $ (mkProfile botDisplayName) {peerType = Just CPTBot, preferences} - Nothing -> do - putStrLn - "No user profiles found, it will be created now.\n\ - \Please choose your display name.\n\ - \It will be sent to your contacts when you connect.\n\ - \It is only stored on your device and you can change it later." - loop + Nothing + | chatRelay -> do + putStrLn + "No chat relay user profile found, it will be created now.\n\ + \Please choose chat relay display name." + loop + | otherwise -> do + putStrLn + "No user profiles found, it will be created now.\n\ + \Please choose your display name.\n\ + \It will be sent to your contacts when you connect.\n\ + \It is only stored on your device and you can change it later." + loop where loop = do - displayName <- T.pack <$> getWithPrompt "display name" + displayName <- T.pack <$> withPrompt "display name: " getLine createUser loop $ mkProfile displayName mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing} createUser onError p = - execChatCommand' (CreateActiveUser NewUser {profile = Just p, pastTimestamp = False, userChatRelay = False}) 0 `runReaderT` cc >>= \case + execChatCommand' (CreateActiveUser NewUser {profile = Just p, pastTimestamp = False, userChatRelay = chatRelay}) 0 `runReaderT` cc >>= \case Right (CRActiveUser user) -> pure user r -> printResponseEvent (Nothing, Nothing) (config cc) r >> onError +askCreateRelayAddress :: ChatController -> User -> IO () +askCreateRelayAddress cc@ChatController {chatStore} user = + withTransaction chatStore (\db -> runExceptT $ getUserAddress db user) >>= \case + Right _ -> pure () + Left SEUserContactLinkNotFound -> promptCreate + Left e -> printChatError (config cc) $ ChatErrorStore e + where + promptCreate :: IO () + promptCreate = do + ok <- onOffPrompt "Create relay address" True + when ok $ + execChatCommand' CreateMyAddress 0 `runReaderT` cc >>= \case + Right (CRUserContactLinkCreated _ address) -> do + putStrLn "Chat relay address is created:" + putStrLn $ addressStr address + r -> printResponseEvent (Nothing, Nothing) (config cc) r + addressStr :: CreatedLinkContact -> String + addressStr (CCLink cReq shortLink) = B.unpack $ maybe cReqStr strEncode shortLink + where + cReqStr = strEncode $ simplexChatContact cReq + printResponseEvent :: ChatResponseEvent r => (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Either ChatError r -> IO () printResponseEvent hu cfg = \case Right r -> do ts <- getCurrentTime tz <- getCurrentTimeZone putStrLn $ serializeChatResponse hu cfg ts tz (fst hu) r - Left e -> do - putStrLn $ serializeChatError True cfg e + Left e -> printChatError cfg e -getWithPrompt :: String -> IO String -getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine +printChatError :: ChatConfig -> ChatError -> IO () +printChatError cfg e = putStrLn $ serializeChatError True cfg e + +withPrompt :: String -> IO a -> IO a +withPrompt s a = putStr s >> hFlush stdout >> a + +onOffPrompt :: String -> Bool -> IO Bool +onOffPrompt prompt def = + withPrompt (prompt <> if def then " (Yn): " else " (yN): ") $ + getLine >>= \case + "" -> pure def + "y" -> pure True + "Y" -> pure True + "n" -> pure False + "N" -> pure False + _ -> putStrLn "Invalid input, please enter 'y' or 'n'" >> onOffPrompt prompt def userStr :: User -> String userStr User {localDisplayName, profile = LocalProfile {fullName}} = diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index d6688a939c..ddaaa9e294 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1442,7 +1442,7 @@ processChatCommand vr nm = \case pure $ CRConnNtfMessages ntfMsgs GetUserProtoServers (AProtocolType p) -> withUser $ \user -> withServerProtocol p $ do srvs <- withFastStore (`getUserServers` user) - liftIO $ CRUserServers user <$> groupByOperator (protocolServers p srvs) + liftIO $ CRUserServers user <$> groupByOperator (onlyProtocolServers p srvs) SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user) case L.nonEmpty userServers_ of @@ -1461,6 +1461,21 @@ processChatCommand vr nm = \case lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a nm (aUserId user) server) TestProtoServer srv -> withUser $ \User {userId} -> processChatCommand vr nm $ APITestProtoServer userId srv + GetUserChatRelays -> withUser $ \user -> do + srvs <- withFastStore (`getUserServers` user) + liftIO $ CRUserServers user <$> groupByOperator (onlyRelays srvs) + SetUserChatRelays relays -> withUser $ \user@User {userId} -> do + userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user) + case L.nonEmpty userServers_ of + Nothing -> throwCmdError "no relays" + Just userServers -> case relays of + [] -> throwCmdError "no relays" + _ -> do + let relays' = map aUserRelay relays + processChatCommand vr nm $ APISetUserServers userId $ L.map (updatedRelays relays') userServers + where + aUserRelay :: CLINewRelay -> AUserChatRelay + aUserRelay CLINewRelay {address, name} = AUCR SDBNew $ newChatRelay name [""] address APIGetServerOperators -> CRServerOperatorConditions <$> withFastStore getServerOperators APISetServerOperators operators -> do as <- asks randomAgentServers @@ -2017,6 +2032,7 @@ processChatCommand vr nm = \case Left e -> throwError $ ChatErrorStore e Right _ -> throwError $ ChatErrorStore SEDuplicateContactLink subMode <- chatReadVar subscriptionMode + -- TODO [chat relays] add relay key, identity to link data let userData = contactShortLinkData (userProfileDirect user Nothing Nothing True) Nothing -- TODO [certs rcv] (connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userData) Nothing IKPQOn subMode @@ -4041,9 +4057,8 @@ data ConnectViaContactResult = CVRConnectedContact Contact | CVRSentInvitation Connection (Maybe Profile) --- TODO [chat relays] used for CLI specific APIs (same for `updatedServers` below) - add similar APIs for chat relays? -protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) -protocolServers p (operators, smpServers, xftpServers, _chatRelays) = case p of +onlyProtocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) +onlyProtocolServers p (operators, smpServers, xftpServers, _chatRelays) = case p of SPSMP -> (operators, smpServers, [], []) SPXFTP -> (operators, [], xftpServers, []) @@ -4061,6 +4076,19 @@ updatedServers p' srvs UserOperatorServers {operator, smpServers, xftpServers, c disableSrv srv@UserServer {preset} = AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True} +onlyRelays :: ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP], [UserChatRelay]) +onlyRelays (operators, _smpServers, _xftpServers, chatRelays) = (operators, [], [], chatRelays) + +-- disable preset and replace custom chat relays (groupByOperator always adds custom) +updatedRelays :: [AUserChatRelay] -> UserOperatorServers -> UpdatedUserOperatorServers +updatedRelays relays UserOperatorServers {operator, smpServers, xftpServers, chatRelays} = + UpdatedUserOperatorServers operator (map (AUS SDBStored) smpServers) (map (AUS SDBStored) xftpServers) (updateRelays chatRelays) + where + updateRelays :: [UserChatRelay] -> [AUserChatRelay] + updateRelays pRelays = map disableRelay pRelays <> maybe relays (const []) operator + disableRelay relay@UserChatRelay {preset} = + AUCR SDBStored $ if preset then relay {enabled = False} else relay {deleted = True} + type ComposedMessageReq = (ComposedMessage, Maybe CIForwardedFrom, (Text, Maybe MarkdownList), Map MemberName CIMention) composedMessage :: Maybe CryptoFile -> MsgContent -> ComposedMessage @@ -4436,6 +4464,8 @@ chatCommandP = "/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP), "/smp" $> GetUserProtoServers (AProtocolType SPSMP), "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), + "/relays " *> (SetUserChatRelays <$> chatRelaysP), + "/relays" $> GetUserChatRelays, "/_operators" $> APIGetServerOperators, "/_operators " *> (APISetServerOperators <$> jsonP), "/operators " *> (SetServerOperators . L.fromList <$> operatorRolesP `A.sepBy1` A.char ','), @@ -4848,6 +4878,11 @@ chatCommandP = optional ("yes" *> A.space) *> (TMEEnableSetTTL <$> timedTTLP) <|> ("yes" $> TMEEnableKeepTTL) <|> ("no" $> TMEDisableKeepTTL) + chatRelaysP = chatRelayP `A.sepBy1` A.char ' ' + chatRelayP = do + name <- "name=" *> text1P + address <- _strP + pure CLINewRelay {name, address} operatorRolesP = do operatorId' <- A.decimal enabled' <- A.char ':' *> onOffP diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index b22cfebcdd..0d659923ca 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -253,6 +253,7 @@ mobileChatOpts dbOptions = logFile = Nothing, tbqSize = 4096, deviceName = Nothing, + chatRelay = False, highlyAvailable = False, yesToUpMigrations = False, migrationBackupPath = Just "" diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 4a8ac65d5e..2ba051c08b 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -271,6 +271,13 @@ data UserChatRelay' s = UserChatRelay } deriving (Show) +-- for setting chat relays via CLI API +data CLINewRelay = CLINewRelay + { address :: ConnLinkContact, + name :: Text + } + deriving (Show) + data PresetOperator = PresetOperator { operator :: Maybe NewServerOperator, smp :: [NewUserServer 'PSMP], @@ -503,16 +510,16 @@ validateUserServers curr others = (currUserErrs <> concatMap otherUserErrs other userServers :: (UserServersClass u, UserProtocol p) => SProtocolType p -> [u] -> [AUserServer p] userServers p = map aUserServer' . concatMap (servers' p) chatRelayErrs :: UserServersClass u => [u] -> [UserServersError] - chatRelayErrs uss = concatMap duplicateErrs_ speers + chatRelayErrs uss = concatMap duplicateErrs_ cRelays where - speers = filter (\(AUCR _ UserChatRelay {deleted}) -> not deleted) $ userChatRelays uss + cRelays = filter (\(AUCR _ UserChatRelay {deleted}) -> not deleted) $ userChatRelays uss duplicateErrs_ (AUCR _ UserChatRelay {name, address}) = [USEDuplicateChatRelayName name | name `elem` duplicateNames] <> [USEDuplicateChatRelayAddress name address | address `elem` duplicateAddresses] duplicateNames = snd $ foldl' addDuplicate (S.empty, S.empty) allNames - allNames = map (\(AUCR _ speer) -> name speer) speers + allNames = map (\(AUCR _ UserChatRelay {name}) -> name) cRelays duplicateAddresses = snd $ foldl' addAddress ([], []) allAddresses - allAddresses = map (\(AUCR _ speer) -> address speer) speers + allAddresses = map (\(AUCR _ UserChatRelay {address}) -> address) cRelays addAddress :: ([ConnLinkContact], [ConnLinkContact]) -> ConnLinkContact -> ([ConnLinkContact], [ConnLinkContact]) addAddress (xs, dups) x | any (sameConnLinkContact x) xs = (xs, x : dups) @@ -524,8 +531,8 @@ validateUserServers curr others = (currUserErrs <> concatMap otherUserErrs other | noChatRelays opEnabled = [USWNoChatRelays user] | otherwise = [] where - noChatRelays cond = not $ any speerEnabled $ userChatRelays $ filter cond uss - speerEnabled (AUCR _ UserChatRelay {deleted, enabled}) = enabled && not deleted + noChatRelays cond = not $ any relayEnabled $ userChatRelays $ filter cond uss + relayEnabled (AUCR _ UserChatRelay {deleted, enabled}) = enabled && not deleted userChatRelays :: UserServersClass u => [u] -> [AUserChatRelay] userChatRelays = map aUserChatRelay' . concatMap chatRelays' opEnabled :: UserServersClass u => u -> Bool diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index afc01e0493..90c8df5bd8 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -66,6 +66,7 @@ data CoreChatOpts = CoreChatOpts logFile :: Maybe FilePath, tbqSize :: Natural, deviceName :: Maybe Text, + chatRelay :: Bool, highlyAvailable :: Bool, yesToUpMigrations :: Bool, migrationBackupPath :: Maybe FilePath @@ -233,6 +234,11 @@ coreChatOptsP appDir defaultDbName = do <> metavar "DEVICE" <> help "Device name to use in connections with remote hosts and controller" ) + chatRelay <- + switch + ( long "relay" + <> help "Run as a chat relay client" + ) highlyAvailable <- switch ( long "ha" @@ -269,6 +275,7 @@ coreChatOptsP appDir defaultDbName = do logFile, tbqSize, deviceName, + chatRelay, highlyAvailable, yesToUpMigrations, migrationBackupPath diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 097e38ab36..c9083c02eb 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -140,8 +140,10 @@ createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, shortDe order <- getNextActiveOrder db DB.execute db - "INSERT INTO users (agent_user_id, local_display_name, active_user, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, created_at, updated_at) VALUES (?,?,?,?,0,?,?,?,?,?,?)" - (auId, displayName, BI activeUser, order, BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, currentTs, currentTs) + "INSERT INTO users (agent_user_id, local_display_name, active_user, is_user_chat_relay, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, created_at, updated_at) VALUES (?,?,?,?,?,0,?,?,?,?,?,?)" + ( (auId, displayName, BI activeUser, BI userChatRelay, order) + :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, currentTs, currentTs) + ) userId <- insertedRowId db DB.execute db @@ -628,7 +630,7 @@ getChatRelays db User {userId} = UserChatRelay {chatRelayId, address, name, domains = T.splitOn "," domains, preset, tested = unBI <$> tested, enabled, deleted = False} insertChatRelay :: DB.Connection -> User -> UTCTime -> NewUserChatRelay -> IO UserChatRelay -insertChatRelay db User {userId} ts speer@UserChatRelay {address, name, domains, preset, tested, enabled} = do +insertChatRelay db User {userId} ts relay@UserChatRelay {address, name, domains, preset, tested, enabled} = do crId <- fromOnly . head <$> DB.query @@ -640,7 +642,7 @@ insertChatRelay db User {userId} ts speer@UserChatRelay {address, name, domains, RETURNING chat_relay_id |] (address, name, T.intercalate "," domains, BI preset, BI <$> tested, BI enabled, userId, ts, ts) - pure speer {chatRelayId = DBEntityId crId} + pure relay {chatRelayId = DBEntityId crId} updateChatRelay :: DB.Connection -> UTCTime -> UserChatRelay -> IO () updateChatRelay db ts UserChatRelay {chatRelayId, address, name, domains, preset, tested, enabled} = @@ -900,13 +902,13 @@ setUserServers' db user@User {userId} ts UpdatedUserOperatorServers {operator, s | deleted -> Nothing <$ DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, BI False) | otherwise -> Just s <$ updateProtocolServer db p ts s upsertOrDeleteCRelay :: AUserChatRelay -> IO (Maybe UserChatRelay) - upsertOrDeleteCRelay (AUCR _ speer@UserChatRelay {chatRelayId, deleted}) = case chatRelayId of + upsertOrDeleteCRelay (AUCR _ relay@UserChatRelay {chatRelayId, deleted}) = case chatRelayId of DBNewEntity | deleted -> pure Nothing - | otherwise -> Just <$> insertChatRelay db user ts speer - DBEntityId speerId - | deleted -> Nothing <$ DB.execute db "DELETE FROM chat_relays WHERE user_id = ? AND chat_relay_id = ? AND preset = ?" (userId, speerId, BI False) - | otherwise -> Just speer <$ updateChatRelay db ts speer + | otherwise -> Just <$> insertChatRelay db user ts relay + DBEntityId relayId + | deleted -> Nothing <$ DB.execute db "DELETE FROM chat_relays WHERE user_id = ? AND chat_relay_id = ? AND preset = ?" (userId, relayId, BI False) + | otherwise -> Just relay <$ updateChatRelay db ts relay createCall :: DB.Connection -> User -> Call -> UTCTime -> IO () createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index 5f7d1a44e5..df158b4a5c 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -962,6 +962,14 @@ Query: Plan: +Query: + INSERT INTO chat_relays + (address, name, domains, preset, tested, enabled, user_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?) + RETURNING chat_relay_id + +Plan: + Query: INSERT INTO group_members ( group_id, member_id, member_role, member_category, member_status, invited_by, invited_by_group_member_id, @@ -5667,6 +5675,10 @@ SEARCH chat_items USING COVERING INDEX idx_chat_items_fwd_from_chat_item_id (fwd SEARCH files USING COVERING INDEX idx_files_chat_item_id (chat_item_id=?) SEARCH groups USING COVERING INDEX idx_groups_chat_item_id (chat_item_id=?) +Query: DELETE FROM chat_relays WHERE user_id = ? AND chat_relay_id = ? AND preset = ? +Plan: +SEARCH chat_relays USING INTEGER PRIMARY KEY (rowid=?) + Query: DELETE FROM commands WHERE user_id = ? AND command_id = ? Plan: SEARCH commands USING INTEGER PRIMARY KEY (rowid=?) @@ -6058,7 +6070,7 @@ Plan: Query: INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, short_link_contact, short_link_data_set, short_link_large_data_set, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?) Plan: -Query: INSERT INTO users (agent_user_id, local_display_name, active_user, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, created_at, updated_at) VALUES (?,?,?,?,0,?,?,?,?,?,?) +Query: INSERT INTO users (agent_user_id, local_display_name, active_user, is_user_chat_relay, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, created_at, updated_at) VALUES (?,?,?,?,?,0,?,?,?,?,?,?) Plan: Query: INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 9b58082b5d..37cd308d4b 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -24,7 +24,6 @@ import Data.Function (on) import Data.Int (Int64) import Data.List (groupBy, intercalate, intersperse, sortOn) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) @@ -1506,14 +1505,14 @@ viewUserServers UserOperatorServers {operator, smpServers, xftpServers, chatRela viewChatRelays [] = [] viewChatRelays cRelays | maybe True (\ServerOperator {enabled} -> enabled) operator = - ["Chat relays"] <> map (plain . (" " <>) . viewChatRelay) cRelays + [" Chat relays"] <> map (plain . (" " <>) . viewChatRelay) cRelays | otherwise = [] where - viewChatRelay UserChatRelay {name, address, preset, tested, enabled} = name <> chatrelayAddress <> chatrelayInfo + viewChatRelay UserChatRelay {name, address, preset, tested, enabled} = name <> relayAddress <> relayInfo where - chatrelayAddress = "(" <> safeDecodeUtf8 (strEncode address) <> ")" - chatrelayInfo = if null chatrelayInfo_ then "" else parens $ T.intercalate ", " chatrelayInfo_ - chatrelayInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled] + relayAddress = ": " <> safeDecodeUtf8 (strEncode address) + relayInfo = if null relayInfo_ then "" else parens $ T.intercalate ", " relayInfo_ + relayInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled] testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested serversUserHelp :: [StyledString] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 5e5113d7a6..0dde5f02f9 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -150,11 +150,15 @@ testCoreOpts = logFile = Nothing, tbqSize = 16, deviceName = Nothing, + chatRelay = False, highlyAvailable = False, yesToUpMigrations = False, migrationBackupPath = Nothing } +relayTestOpts :: ChatOpts +relayTestOpts = testOpts {coreOptions = testCoreOpts {chatRelay = True}} + #if !defined(dbPostgres) getTestOpts :: Bool -> ScrubbedBytes -> ChatOpts getTestOpts maintenance dbKey = testOpts {maintenance, coreOptions = testCoreOpts {dbOptions = (dbOptions testCoreOpts) {dbKey}}} @@ -283,10 +287,10 @@ nextVersion :: Version v -> Version v nextVersion (Version v) = Version (v + 1) createTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC -createTestChat ps cfg opts@ChatOpts {coreOptions} dbPrefix profile = do +createTestChat ps cfg opts@ChatOpts {coreOptions = coreOptions@CoreChatOpts {chatRelay}} dbPrefix profile = do Right db@ChatDatabase {chatStore, agentStore} <- createDatabase ps coreOptions dbPrefix insertUser agentStore - Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecord db' (AgentUserId 1) profile False True + Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecord db' (AgentUserId 1) profile chatRelay True startTestChat_ ps db cfg opts user startTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> IO TestCC @@ -316,7 +320,7 @@ startTestChat_ TestParams {printOutput} db cfg opts@ChatOpts {maintenance} user ct <- newChatTerminal t opts cc <- newChatController db (Just user) cfg opts False void $ execChatCommand' (SetTempFolder "tests/tmp/tmp") 0 `runReaderT` cc - chatAsync <- async $ runSimplexChat opts user cc $ \_u cc' -> runChatTerminal ct cc' opts + chatAsync <- async $ runSimplexChat cfg opts user cc $ \_u cc' -> runChatTerminal ct cc' opts unless maintenance $ atomically $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry termQ <- newTQueueIO termAsync <- async $ readTerminalOutput t termQ diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 20fccf6c64..ab532edaf2 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -1,6 +1,7 @@ module ChatTests where import ChatTests.ChatList +import ChatTests.ChatRelays import ChatTests.DBUtils import ChatTests.Direct import ChatTests.Files @@ -15,6 +16,7 @@ chatTests = do describe "direct tests" chatDirectTests describe "forward tests" chatForwardTests describe "group tests" chatGroupTests + describe "chat relay tests" chatRelayTests describe "local chats tests" chatLocalChatsTests describe "file tests" chatFileTests describe "profile tests" chatProfileTests diff --git a/tests/ChatTests/ChatRelays.hs b/tests/ChatTests/ChatRelays.hs new file mode 100644 index 0000000000..3db731e261 --- /dev/null +++ b/tests/ChatTests/ChatRelays.hs @@ -0,0 +1,49 @@ +module ChatTests.ChatRelays where + +import ChatClient +import ChatTests.DBUtils +import ChatTests.Utils +import Test.Hspec hiding (it) + +chatRelayTests :: SpecWith TestParams +chatRelayTests = do + describe "configure chat relays" $ do + it "get and set chat relays" testGetSetChatRelays + +testGetSetChatRelays :: HasCallStack => TestParams -> IO () +testGetSetChatRelays ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> do + withNewTestChatOpts ps relayTestOpts "cath" cathProfile $ \cath -> do + bob ##> "/ad" + (bobSLink, _cLink) <- getContactLinks bob True + + cath ##> "/ad" + (cathSLink, _cLink) <- getContactLinks cath True + + alice ##> ("/relays name=bob_relay " <> bobSLink) + alice <## "ok" + + alice ##> "/relays" + alice <## "Your servers" + alice <## " Chat relays" + alice <## (" bob_relay: " <> bobSLink) + + alice ##> ("/relays name=cath_relay " <> cathSLink) + alice <## "ok" + + alice ##> "/relays" + alice <## "Your servers" + alice <## " Chat relays" + alice <## (" cath_relay: " <> cathSLink) + + alice ##> ("/relays name=bob_relay " <> bobSLink <> " name=cath_relay " <> cathSLink) + alice <## "ok" + + alice ##> "/relays" + alice <## "Your servers" + alice <## " Chat relays" + alice + <### [ ConsoleString $ " bob_relay: " <> bobSLink, + ConsoleString $ " cath_relay: " <> cathSLink + ]