From 0ec88fd560572ede849a06493047ab9c1254c6ef Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Tue, 12 Nov 2024 20:41:20 +0000 Subject: [PATCH] make servers of disabled operators "unknown", consider only enabled servers when switching profile links --- src/Simplex/Chat.hs | 92 +++++++++++++++---------- src/Simplex/Chat/Controller.hs | 1 + src/Simplex/Chat/Operators.hs | 77 +++++++++------------ src/Simplex/Chat/Store/Profiles.hs | 8 ++- src/Simplex/Chat/View.hs | 106 ++++++++++++++++++++++------- tests/ChatClient.hs | 2 +- tests/ChatTests/Direct.hs | 71 ++++++++++++++----- tests/ChatTests/Profiles.hs | 11 ++- 8 files changed, 239 insertions(+), 129 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index cc9aa4431c..6a6ac4fb0a 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -55,6 +55,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime) import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds) +import Data.Type.Equality import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Data.Word (Word32) @@ -392,32 +393,34 @@ newChatController netCfg' = updateNetworkConfig netCfg simpleNetCfg operators' = case (smpServers, xftpServers) of ([], []) -> operators - (smpSrvs, []) -> L.map removeSMP operators <> [custom smpSrvs []] - ([], xftpSrvs) -> L.map removeXFTP operators <> [custom [] xftpSrvs] + (smpSrvs, []) -> L.map disableSMP operators <> [custom smpSrvs []] + ([], xftpSrvs) -> L.map disableXFTP operators <> [custom [] xftpSrvs] (smpSrvs, xftpSrvs) -> [custom smpSrvs xftpSrvs] - removeSMP op = (op :: PresetOperator) {smp = []} - removeXFTP op = (op :: PresetOperator) {xftp = []} + disableSMP op@PresetOperator {smp} = (op :: PresetOperator) {smp = map disableSrv smp} + disableXFTP op@PresetOperator {xftp} = (op :: PresetOperator) {xftp = map disableSrv xftp} + disableSrv :: forall p. NewUserServer p -> NewUserServer p + disableSrv srv = (srv :: NewUserServer p) {enabled = False} custom smpSrvs xftpSrvs = PresetOperator { operator = Nothing, - smp = map (presetServer True) smpSrvs, + smp = map newUserServer smpSrvs, useSMP = 0, - xftp = map (presetServer True) xftpSrvs, + xftp = map newUserServer xftpSrvs, useXFTP = 0 } agentServers :: DB.Connection -> ChatConfig -> RandomServers -> IO InitialAgentServers agentServers db ChatConfig {presetServers = PresetServers {operators = presetOps, ntf, netCfg}} randomServers = do users <- getUsers db opDomains <- operatorDomains <$> getUpdateServerOperators db presetOps (null users) - smp' <- getUserServers SPSMP users opDomains - xftp' <- getUserServers SPXFTP users opDomains + smp' <- getServers SPSMP users opDomains + xftp' <- getServers SPXFTP users opDomains pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg} where - getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> IO (Map UserId (NonEmpty (ServerCfg p))) - getUserServers p users opDomains = do + getServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [User] -> [(Text, ServerOperator)] -> IO (Map UserId (NonEmpty (ServerCfg p))) + getServers p users opDomains = do let randomSrvs = rndServers p randomServers fmap M.fromList $ forM users $ \u -> - (aUserId u,) . agentServerCfgs opDomains <$> getUpdateUserServers db p presetOps randomSrvs u + (aUserId u,) . agentServerCfgs opDomains randomSrvs <$> getUpdateUserServers db p presetOps randomSrvs u updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPort, tcpTimeout_, logTLSErrors} = @@ -641,16 +644,17 @@ processChatCommand' vr = \case when (n == displayName) . throwChatError $ if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""} opDomains <- operatorDomains . fst <$> withFastStore getServerOperators - let smp = agentServerCfgs opDomains smpServers - xftp = agentServerCfgs opDomains xftpServers + rs <- asks randomServers + let smp = agentServerCfgs opDomains (rndServers SPSMP rs) smpServers + xftp = agentServerCfgs 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 createPresetContactCards user `catchChatError` \_ -> pure () withFastStore $ \db -> do createNoteFolder db user - liftIO $ mapM_ (insertProtocolServer db SPSMP user ts) smpServers - liftIO $ mapM_ (insertProtocolServer db SPXFTP user ts) xftpServers + liftIO $ mapM_ (insertProtocolServer db SPSMP user ts) $ useServers SPSMP rs smpServers + liftIO $ mapM_ (insertProtocolServer db SPXFTP user ts) $ useServers SPXFTP rs xftpServers atomically . writeTVar u $ Just user pure $ CRActiveUser user where @@ -659,11 +663,10 @@ processChatCommand' vr = \case withFastStore $ \db -> do createContact db user simplexStatusContactProfile createContact db user simplexTeamContactProfile - chooseServers :: forall p. (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> CM (NonEmpty (NewUserServer p)) + chooseServers :: forall p. ProtocolTypeI p => SProtocolType p -> CM [UserServer p] chooseServers p = do - rs <- asks randomServers srvs <- chatReadVar currentUser >>= mapM (\user -> withFastStore' $ \db -> getProtocolServers db p user) - pure $ useServers p rs $ fromMaybe [] srvs + pure $ fromMaybe [] srvs coupleDaysAgo t = (`addUTCTime` t) . fromInteger . negate . (+ (2 * day)) <$> randomRIO (0, day) day = 86400 ListUsers -> CRUsersList <$> withFastStore' getUsersInfo @@ -1561,25 +1564,36 @@ processChatCommand' vr = \case msgs <- lift $ withAgent' $ \a -> getConnectionMessages a acIds let ntfMsgs = L.map (\msg -> receivedMsgInfo <$> msg) msgs pure $ CRConnNtfMessages ntfMsgs - GetUserProtoServers (AProtocolType p) -> withUser $ \user@User {userId} -> withServerProtocol p $ do + GetUserProtoServers (AProtocolType p) -> withUser $ \user -> withServerProtocol p $ do (operators, smpServers, xftpServers) <- withFastStore (`getUserServers` user) userServers <- liftIO $ groupByOperator $ case p of SPSMP -> (operators, smpServers, []) SPXFTP -> (operators, [], xftpServers) pure $ CRUserServers user userServers - SetUserProtoServers (AProtocolType p) servers -> withUser $ \user@User {userId} -> withServerProtocol p $ do - userServers <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user) - -- disable operators servers and repace (or add) custom servers, or restore random defaults if empty list - case L.nonEmpty userServers of - Just srvs -> processChatCommand $ APISetUserServers userId $ L.map updated srvs - where - updated UserOperatorServers {operator, smpServers, xftpServers} = - UpdatedUserOperatorServers - { operator, - smpServers = map (AUS SDBStored) smpServers, - xftpServers = map (AUS SDBStored) xftpServers - } + SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do + srvs' <- mapM aUserServer srvs + userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user) + case L.nonEmpty userServers_ of Nothing -> throwChatError $ CECommandError "no servers" + Just userServers -> case srvs of + [] -> throwChatError $ CECommandError "no servers" + _ -> processChatCommand $ APISetUserServers userId $ L.map updatedSrvs userServers + where + -- disable preset and replace custom servers (groupByOperator always adds custom) + updatedSrvs UserOperatorServers {operator, smpServers, xftpServers} = case p of + SPSMP -> u (updateSrvs smpServers, map (AUS SDBStored) xftpServers) + SPXFTP -> u (map (AUS SDBStored) smpServers, updateSrvs xftpServers) + where + u = uncurry $ UpdatedUserOperatorServers operator + updateSrvs :: [UserServer p] -> [AUserServer p] + updateSrvs pSrvs = map disableSrv pSrvs <> maybe srvs' (const []) operator + disableSrv srv@UserServer {preset} = + AUS SDBStored $ if preset then srv {enabled = False} else srv {deleted = True} + where + aUserServer :: AProtoServerWithAuth -> CM (AUserServer p) + aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of + Just Refl -> pure $ AUS SDBNew $ newUserServer srv + Nothing -> throwChatError $ CECommandError $ "incorrect server protocol: " <> B.unpack (strEncode srv) APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user -> lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server) TestProtoServer srv -> withUser $ \User {userId} -> @@ -1600,8 +1614,8 @@ processChatCommand' vr = \case rs <- asks randomServers lift $ withAgent' $ \a -> do let auId = aUserId user - setProtocolServers a auId $ agentServerCfgs opDomains $ useServers SPSMP rs smpServers - setProtocolServers a auId $ agentServerCfgs opDomains $ useServers SPXFTP rs xftpServers + setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPSMP rs) smpServers + setProtocolServers a auId $ agentServerCfgs opDomains (rndServers SPXFTP rs) xftpServers ok_ APIValidateServers userServers -> pure $ CRUserServersValidation $ validateUserServers userServers APIGetUsageConditions -> do @@ -1876,7 +1890,13 @@ processChatCommand' vr = \case canKeepLink (CRInvitationUri crData _) newUser = do let ConnReqUriData {crSmpQueues = q :| _} = crData SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q - newUserServers <- map (\UserServer {server} -> protoServer server) <$> withFastStore' (\db -> getProtocolServers db SPSMP newUser) + rs <- asks randomServers + newUserServers <- withFastStore $ \db -> do + opDomains <- operatorDomains . fst <$> getServerOperators db + L.map (\ServerCfg {server} -> protoServer server) + . agentServerCfgs opDomains (rndServers SPSMP rs) + . filter (\UserServer {enabled} -> enabled) + <$> liftIO (getProtocolServers db SPSMP newUser) pure $ smpServer `elem` newUserServers updateConnRecord user@User {userId} conn@PendingContactConnection {customUserProfileId} newUser = do withAgent $ \a -> changeConnectionUser a (aUserId user) (aConnId' conn) (aUserId newUser) @@ -2615,7 +2635,7 @@ processChatCommand' vr = \case let presentedServersSummary = toPresentedServersSummary agentServersSummary users user smpServers xftpServers _defaultNtfServers pure $ CRAgentServersSummary user presentedServersSummary where - getServers :: (ProtocolTypeI p, UserProtocol p) => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p] + getServers :: ProtocolTypeI p => DB.Connection -> User -> SProtocolType p -> IO [ProtocolServer p] getServers db user p = map (\UserServer {server} -> protoServer server) <$> getProtocolServers db p user ResetAgentServersStats -> withAgent resetAgentServersStats >> ok_ GetAgentWorkers -> lift $ CRAgentWorkersSummary <$> withAgent' getAgentWorkersSummary @@ -8205,9 +8225,7 @@ chatCommandP = "/xftp test " *> (TestProtoServer . AProtoServerWithAuth SPXFTP <$> strP), "/ntf test " *> (TestProtoServer . AProtoServerWithAuth SPNTF <$> strP), "/smp " *> (SetUserProtoServers (AProtocolType SPSMP) . map (AProtoServerWithAuth SPSMP) <$> protocolServersP), - "/smp default" $> SetUserProtoServers (AProtocolType SPSMP) [], "/xftp " *> (SetUserProtoServers (AProtocolType SPXFTP) . map (AProtoServerWithAuth SPXFTP) <$> protocolServersP), - "/xftp default" $> SetUserProtoServers (AProtocolType SPXFTP) [], "/smp" $> GetUserProtoServers (AProtocolType SPSMP), "/xftp" $> GetUserProtoServers (AProtocolType SPXFTP), "/_operators" $> APIGetServerOperators, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 92462c173a..e4fcb59758 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -158,6 +158,7 @@ data RandomServers = RandomServers { smpServers :: NonEmpty (NewUserServer 'PSMP), xftpServers :: NonEmpty (NewUserServer 'PXFTP) } + deriving (Show) -- The hooks can be used to extend or customize chat core in mobile or CLI clients. data ChatHooks = ChatHooks diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index bad6c250b4..81541074c8 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -8,7 +8,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -40,7 +39,6 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime, nominalDay) -import Data.Type.Equality import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import Language.Haskell.TH.Syntax (lift) @@ -51,7 +49,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON) import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol) import Simplex.Messaging.Transport.Client (TransportHost (..)) -import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8, (<$?>)) +import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8) usageConditionsCommit :: Text usageConditionsCommit = "165143a1112308c035ac00ed669b96b60599aa1c" @@ -79,11 +77,6 @@ instance DBStoredI 'DBStored where sdbStored = SDBStored instance DBStoredI 'DBNew where sdbStored = SDBNew -instance TestEquality SDBStored where - testEquality SDBStored SDBStored = Just Refl - testEquality SDBNew SDBNew = Just Refl - testEquality _ _ = Nothing - data DBEntityId' (s :: DBStored) where DBEntityId :: Int64 -> DBEntityId' 'DBStored DBNewEntity :: DBEntityId' 'DBNew @@ -94,14 +87,6 @@ type DBEntityId = DBEntityId' 'DBStored type DBNewEntity = DBEntityId' 'DBNew -data ADBEntityId = forall s. DBStoredI s => AEI (SDBStored s) (DBEntityId' s) - -pattern ADBEntityId :: Int64 -> ADBEntityId -pattern ADBEntityId i = AEI SDBStored (DBEntityId i) - -pattern ADBNewEntity :: ADBEntityId -pattern ADBNewEntity = AEI SDBNew DBNewEntity - data OperatorTag = OTSimplex | OTXyz deriving (Eq, Ord, Show) @@ -253,8 +238,14 @@ operatorServersToUse p PresetOperator {useSMP, useXFTP} = case p of SPXFTP -> useXFTP presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p -presetServer enabled server = - UserServer {serverId = DBNewEntity, server, preset = True, tested = Nothing, enabled, deleted = False} +presetServer = newUserServer_ True + +newUserServer :: ProtoServerWithAuth p -> NewUserServer p +newUserServer = newUserServer_ False True + +newUserServer_ :: Bool -> Bool -> ProtoServerWithAuth p -> NewUserServer p +newUserServer_ preset enabled server = + UserServer {serverId = DBNewEntity, server, preset, tested = Nothing, enabled, deleted = False} -- This function should be used inside DB transaction to update conditions in the database -- it evaluates to (conditions to mark as accepted to SimpleX operator, current conditions, and conditions to add) @@ -319,16 +310,21 @@ updatedUserServers p presetOps randomSrvs srvs = srvHost :: UserServer' s p -> NonEmpty TransportHost srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv -agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (UserServer' s p) -> NonEmpty (ServerCfg p) -agentServerCfgs opDomains = L.map agentServer +agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (NewUserServer p) -> [UserServer' s p] -> NonEmpty (ServerCfg p) +agentServerCfgs opDomains randomSrvs = + fromMaybe fallbackSrvs . L.nonEmpty . mapMaybe enabledOpAgentServer where - agentServer :: UserServer' s p -> ServerCfg p + fallbackSrvs = L.map (snd . agentServer) randomSrvs + enabledOpAgentServer srv = + let (opEnabled, srvCfg) = agentServer srv + in if opEnabled then Just srvCfg else Nothing + agentServer :: UserServer' s p -> (Bool, ServerCfg p) agentServer srv@UserServer {server, enabled} = case find (\(d, _) -> any (matchingHost d) (srvHost srv)) opDomains of Just (_, ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled, roles}) -> - ServerCfg {server, operator = Just opId, enabled = opEnabled && enabled, roles} + (opEnabled, ServerCfg {server, enabled, operator = Just opId, roles}) Nothing -> - ServerCfg {server, operator = Nothing, enabled, roles = allRoles} + (True, ServerCfg {server, enabled, operator = Nothing, roles = allRoles}) matchingHost :: Text -> TransportHost -> Bool matchingHost d = \case @@ -344,7 +340,9 @@ groupByOperator (ops, smpSrvs, xftpSrvs) = do custom <- newIORef $ UserOperatorServers Nothing [] [] mapM_ (addServer ss custom addSMP) (reverse smpSrvs) mapM_ (addServer ss custom addXFTP) (reverse xftpSrvs) - mapM (readIORef . snd) ss + opSrvs <- mapM (readIORef . snd) ss + customSrvs <- readIORef custom + pure $ opSrvs <> [customSrvs] where addServer :: [([Text], IORef UserOperatorServers)] -> IORef UserOperatorServers -> (UserServer p -> UserOperatorServers -> UserOperatorServers) -> UserServer p -> IO () addServer ss custom add srv = @@ -368,7 +366,7 @@ validateUserServers uss = <> duplicatServerErrs SPXFTP where missingRolesErr :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> (ServerRoles -> Bool) -> (AProtocolType -> UserServersError) -> [UserServersError] - missingRolesErr p roleSel err = [err (AProtocolType p) | hasRole] + missingRolesErr p roleSel err = [err (AProtocolType p) | not hasRole] where hasRole = any (\(AUS _ UserServer {deleted, enabled}) -> enabled && not deleted) $ @@ -384,15 +382,12 @@ validateUserServers uss = duplicateErr_ (AUS _ srv@UserServer {server}) = USEDuplicateServer (AProtocolType p) (AProtoServerWithAuth p server) <$> find (`S.member` duplicateHosts) (srvHost srv) - duplicateHosts = snd $ foldl' (\acc (AUS _ srv) -> foldl' addHost acc $ srvHost srv) (S.empty, S.empty) srvs + duplicateHosts = snd $ foldl' addHost (S.empty, S.empty) allHosts + allHosts = concatMap (\(AUS _ srv) -> L.toList $ srvHost srv) srvs addHost (hs, dups) h | h `S.member` hs = (hs, S.insert h dups) | otherwise = (S.insert h hs, dups) -instance ToJSON ADBEntityId where - toEncoding (AEI _ dbId) = toEncoding dbId - toJSON (AEI _ dbId) = toJSON dbId - instance ToJSON (DBEntityId' s) where toEncoding = \case DBEntityId i -> toEncoding i @@ -401,20 +396,16 @@ instance ToJSON (DBEntityId' s) where DBEntityId i -> toJSON i DBNewEntity -> J.Null -instance FromJSON ADBEntityId where - parseJSON (J.Null) = pure $ AEI SDBNew DBNewEntity - parseJSON (J.Number n) = case floatingOrInteger n of - Left (_ :: Double) -> fail "bad ADBEntityId" - Right i -> pure $ AEI SDBStored (DBEntityId $ fromInteger i) - parseJSON _ = fail "bad ADBEntityId" - instance DBStoredI s => FromJSON (DBEntityId' s) where - parseJSON v = (\(AEI _ dbId) -> checkDBStored dbId) <$?> parseJSON v - -checkDBStored :: forall t s s'. (DBStoredI s, DBStoredI s') => t s' -> Either String (t s) -checkDBStored x = case testEquality (sdbStored @s) (sdbStored @s') of - Just Refl -> Right x - Nothing -> Left "bad DBStored" + parseJSON v = case (v, sdbStored @s) of + (J.Null, SDBNew) -> pure DBNewEntity + (J.Number n, SDBStored) -> case floatingOrInteger n of + Left (_ :: Double) -> fail "bad DBEntityId" + Right i -> pure $ DBEntityId (fromInteger i) + _ -> fail "bad DBEntityId" + omittedField = case sdbStored @s of + SDBStored -> Nothing + SDBNew -> Just DBNewEntity $(JQ.deriveJSON defaultJSON ''UsageConditions) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 23cb391ecb..39bd4bb985 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -532,11 +532,11 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply) _ -> (False, False, Nothing) -getUpdateUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => DB.Connection -> SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO (NonEmpty (UserServer p)) +getUpdateUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => DB.Connection -> SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> User -> IO [UserServer p] getUpdateUserServers db p presetOps randomSrvs user = do ts <- getCurrentTime srvs <- getProtocolServers db p user - let srvs' = updatedUserServers p presetOps randomSrvs srvs + let srvs' = L.toList $ updatedUserServers p presetOps randomSrvs srvs mapM (upsertServer ts) srvs' where upsertServer :: UTCTime -> AUserServer p -> IO (UserServer p) @@ -831,7 +831,9 @@ setUserServers db user@User {userId} userServers = checkConstraint SEUniqueID $ where upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> UTCTime -> AUserServer p -> IO () upsertOrDelete p ts (AUS _ s@UserServer {serverId, deleted}) = case serverId of - DBNewEntity -> void $ insertProtocolServer db p user ts s + DBNewEntity + | deleted -> pure () + | otherwise -> void $ insertProtocolServer db p user ts s DBEntityId srvId | deleted -> DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND smp_server_id = ? AND preset = ?" (userId, srvId, False) | otherwise -> updateProtocolServer db p ts s diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index a14ba1317a..6296fd8b4a 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -25,6 +25,7 @@ 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) +import Data.String import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) @@ -42,6 +43,7 @@ import Simplex.Chat.Help import Simplex.Chat.Markdown import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Messages.CIContent +import Simplex.Chat.Operators import Simplex.Chat.Protocol import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange) import Simplex.Chat.Remote.Types @@ -53,7 +55,7 @@ import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..)) -import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..)) +import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..), ServerRoles (..)) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..)) import Simplex.Messaging.Client (SMPProxyFallback, SMPProxyMode (..), SocksMode (..)) @@ -95,10 +97,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRChats chats -> viewChats ts tz chats CRApiChat u chat -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat] CRApiParsedMarkdown ft -> [viewJSON ft] - -- CRUserProtoServers u userServers operators -> ttyUser u $ viewUserServers userServers operators testView CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure - CRServerOperators {} -> [] - CRUserServers {} -> [] + CRServerOperators ops ca -> viewServerOperators ops ca + CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp) CRUserServersValidation _ -> [] CRUsageConditions {} -> [] CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl @@ -1213,27 +1214,31 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho "profile is " <> if isJust viewPwdHash then "hidden" else "visible" ] --- viewUserServers :: AUserProtoServers -> [ServerOperator] -> Bool -> [StyledString] --- viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) operators testView = --- customServers --- <> if testView --- then [] --- else --- [ "", --- "use " <> highlight (srvCmd <> " test ") <> " to test " <> pName <> " server connection", --- "use " <> highlight (srvCmd <> " ") <> " to configure " <> pName <> " servers", --- "use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets" --- ] --- <> case p of --- SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"] --- SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"] --- where --- srvCmd = "/" <> strEncode p --- pName = protocolName p --- customServers = --- if null protoServers --- then ("no " <> pName <> " servers saved, using presets: ") : viewServers operators presetServers --- else viewServers operators protoServers +viewUserServers :: UserOperatorServers -> [StyledString] +viewUserServers (UserOperatorServers _ [] []) = [] +viewUserServers UserOperatorServers {operator, smpServers, xftpServers} = + [plain $ maybe "Your servers" shortViewOperator operator] + <> viewServers SPSMP smpServers + <> viewServers SPXFTP xftpServers + where + viewServers :: ProtocolTypeI p => SProtocolType p -> [UserServer p] -> [StyledString] + viewServers _ [] = [] + viewServers p srvs = [" " <> protocolName p <> " servers"] <> map (plain . (" " <> ) . viewServer) srvs + where + viewServer UserServer {server, preset, tested, enabled} = safeDecodeUtf8 (strEncode server) <> serverInfo + where + serverInfo = if null serverInfo_ then "" else parens $ T.intercalate ", " serverInfo_ + serverInfo_ = ["preset" | preset] <> testedInfo <> ["disabled" | not enabled] + testedInfo = maybe [] (\t -> ["test: " <> if t then "passed" else "failed"]) tested + +serversUserHelp :: [StyledString] +serversUserHelp = + [ "", + "use " <> highlight' "/smp test " <> " to test SMP server connection", + "use " <> highlight' "/smp " <> " to configure SMP servers", + "or the same commands starting from /xftp for XFTP servers", + "chat options " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") and " <> highlight' "--xftp-servers" <> " have precedence over preset servers for new user profiles" + ] protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode @@ -1254,6 +1259,53 @@ viewServerTestResult (AProtoServerWithAuth p _) = \case where pName = protocolName p +viewServerOperators :: [ServerOperator] -> Maybe UsageConditionsAction -> [StyledString] +viewServerOperators ops ca = map (plain . viewOperator) ops <> maybe [] viewConditionsAction ca + +viewOperator :: ServerOperator' s -> Text +viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsAcceptance} = + viewOpIdTag op + <> tradeName + <> maybe "" parens legalName + <> (", domains: " <> T.intercalate ", " serverDomains) + <> (", conditions: " <> viewOpConditions conditionsAcceptance) + <> (", " <> viewOpEnabled op) + +shortViewOperator :: ServerOperator -> Text +shortViewOperator op@ServerOperator {operatorId = DBEntityId opId, tradeName} = + tshow opId <> ". " <> tradeName <> parens (viewOpEnabled op) + +viewOpIdTag :: ServerOperator' s -> Text +viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of + DBEntityId i -> tshow i <> " - " <> tag + DBNewEntity -> tag + where + tag = maybe "" textEncode operatorTag <> ". " + +viewOpConditions :: ConditionsAcceptance -> Text +viewOpConditions = \case + CAAccepted ts -> viewCond "accepted" ts + CARequired ts -> viewCond "required" ts + where + viewCond w ts = w <> maybe "" (parens . tshow) ts + +viewOpEnabled :: ServerOperator' s -> Text +viewOpEnabled ServerOperator {enabled, roles = ServerRoles {storage, proxy}} + | enabled && storage && proxy = "enabled" + | enabled && storage = "enabled storage" + | enabled && proxy = "enabled proxy" + | otherwise = "disabled" + +viewConditionsAction :: UsageConditionsAction -> [StyledString] +viewConditionsAction = \case + UCAReview {operators, deadline, showNotice} | showNotice -> case deadline of + Just ts -> [plain $ "New conditions will be accepted at " <> tshow ts <> " for " <> ops] + Nothing -> [plain $ "New conditions have to be accepted for " <> ops] + where + ops = T.intercalate ", " $ map legalName_ operators + legalName_ ServerOperator {tradeName, legalName} = fromMaybe tradeName legalName + _ -> [] + viewChatItemTTL :: Maybe Int64 -> [StyledString] viewChatItemTTL = \case Nothing -> ["old messages are not being deleted"] @@ -1933,7 +1985,9 @@ viewVersionInfo logLevel CoreVersionInfo {version, simplexmqVersion, simplexmqCo then [versionString version, updateStr, "simplexmq: " <> simplexmqVersion <> parens simplexmqCommit] else [versionString version, updateStr] where - parens s = " (" <> s <> ")" + +parens :: (IsString a, Semigroup a) => a -> a +parens s = " (" <> s <> ")" viewRemoteHosts :: [RemoteHostInfo] -> [StyledString] viewRemoteHosts = \case diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index ab47951214..b3d8166f9f 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -154,7 +154,7 @@ testCfg = (presetServers defaultChatConfig) { operators = [ PresetOperator - { operator = Just operatorSimpleXChat, + { operator = Nothing, smp = map (presetServer True) ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001"], useSMP = 1, xftp = map (presetServer True) ["xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002"], diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 7d5dc67d24..36771760d3 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -1109,17 +1109,32 @@ testGetSetSMPServers :: HasCallStack => FilePath -> IO () testGetSetSMPServers = testChat2 aliceProfile bobProfile $ \alice _ -> do - alice #$> ("/_servers 1 smp", id, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001") + alice ##> "/_servers 1" + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)" + alice <## " XFTP servers" + alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)" alice #$> ("/smp smp://1234-w==@smp1.example.im", id, "ok") - alice #$> ("/smp", id, "smp://1234-w==@smp1.example.im") + alice ##> "/smp" + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)" + alice <## " smp://1234-w==@smp1.example.im" alice #$> ("/smp smp://1234-w==:password@smp1.example.im", id, "ok") - alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im") + -- alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im") + alice ##> "/smp" + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)" + alice <## " smp://1234-w==:password@smp1.example.im" alice #$> ("/smp smp://2345-w==@smp2.example.im smp://3456-w==@smp3.example.im:5224", id, "ok") alice ##> "/smp" - alice <## "smp://2345-w==@smp2.example.im" - alice <## "smp://3456-w==@smp3.example.im:5224" - alice #$> ("/smp default", id, "ok") - alice #$> ("/smp", id, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001") + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)" + alice <## " smp://2345-w==@smp2.example.im" + alice <## " smp://3456-w==@smp3.example.im:5224" testTestSMPServerConnection :: HasCallStack => FilePath -> IO () testTestSMPServerConnection = @@ -1140,17 +1155,31 @@ testGetSetXFTPServers :: HasCallStack => FilePath -> IO () testGetSetXFTPServers = testChat2 aliceProfile bobProfile $ \alice _ -> withXFTPServer $ do - alice #$> ("/_servers 1 xftp", id, "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002") + alice ##> "/_servers 1" + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)" + alice <## " XFTP servers" + alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset)" alice #$> ("/xftp xftp://1234-w==@xftp1.example.im", id, "ok") - alice #$> ("/xftp", id, "xftp://1234-w==@xftp1.example.im") + alice ##> "/xftp" + alice <## "Your servers" + alice <## " XFTP servers" + alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)" + alice <## " xftp://1234-w==@xftp1.example.im" alice #$> ("/xftp xftp://1234-w==:password@xftp1.example.im", id, "ok") - alice #$> ("/xftp", id, "xftp://1234-w==:password@xftp1.example.im") + alice ##> "/xftp" + alice <## "Your servers" + alice <## " XFTP servers" + alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)" + alice <## " xftp://1234-w==:password@xftp1.example.im" alice #$> ("/xftp xftp://2345-w==@xftp2.example.im xftp://3456-w==@xftp3.example.im:5224", id, "ok") alice ##> "/xftp" - alice <## "xftp://2345-w==@xftp2.example.im" - alice <## "xftp://3456-w==@xftp3.example.im:5224" - alice #$> ("/xftp default", id, "ok") - alice #$> ("/xftp", id, "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002") + alice <## "Your servers" + alice <## " XFTP servers" + alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)" + alice <## " xftp://2345-w==@xftp2.example.im" + alice <## " xftp://3456-w==@xftp3.example.im:5224" testTestXFTPServer :: HasCallStack => FilePath -> IO () testTestXFTPServer = @@ -1768,11 +1797,17 @@ testCreateUserSameServers = where checkCustomServers alice = do alice ##> "/smp" - alice <## "smp://2345-w==@smp2.example.im" - alice <## "smp://3456-w==@smp3.example.im:5224" + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)" + alice <## " smp://2345-w==@smp2.example.im" + alice <## " smp://3456-w==@smp3.example.im:5224" alice ##> "/xftp" - alice <## "xftp://2345-w==@xftp2.example.im" - alice <## "xftp://3456-w==@xftp3.example.im:5224" + alice <## "Your servers" + alice <## " XFTP servers" + alice <## " xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002 (preset, disabled)" + alice <## " xftp://2345-w==@xftp2.example.im" + alice <## " xftp://3456-w==@xftp3.example.im:5224" testDeleteUser :: HasCallStack => FilePath -> IO () testDeleteUser = diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index d5dff9fde6..1d390e1236 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -1734,7 +1734,16 @@ testChangePCCUserDiffSrv tmp = do -- Create new user with different servers alice ##> "/create user alisa" showActiveUser alice "alisa" - alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003", id, "ok") + alice ##> "/smp" + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset)" + alice #$> ("/smp smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003", id, "ok") + alice ##> "/smp" + alice <## "Your servers" + alice <## " SMP servers" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001 (preset, disabled)" + alice <## " smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@127.0.0.1:7003" alice ##> "/user alice" showActiveUser alice "alice (Alice)" -- Change connection to newly created user and use the newly created connection