From feb687d3b8bae376691f01807305d76504cfbe73 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 15 Nov 2024 12:08:15 +0000 Subject: [PATCH] core: different roles for different protocols (#5185) * 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> --- src/Simplex/Chat.hs | 28 ++++++----- src/Simplex/Chat/Controller.hs | 2 +- .../Migrations/M20241027_server_operators.hs | 6 ++- src/Simplex/Chat/Migrations/chat_schema.sql | 6 ++- src/Simplex/Chat/Operators.hs | 31 ++++++++---- src/Simplex/Chat/Store/Profiles.hs | 44 +++++++++-------- src/Simplex/Chat/View.hs | 48 ++++++++++++------- tests/OperatorTests.hs | 4 +- 8 files changed, 104 insertions(+), 65 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 05f99656bb..95bb405bae 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 27acf8990b..7fb811255f 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -588,7 +588,7 @@ data ChatResponse | CRChatItemId User (Maybe ChatItemId) | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList} | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure} - | CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction} + | CRServerOperatorConditions {conditions :: ServerOperatorConditions} | CRUserServers {user :: User, userServers :: [UserOperatorServers]} | CRUserServersValidation {user :: User, serverErrors :: [UserServersError]} | CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions} diff --git a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs index d84cc5aa73..c4b40c4706 100644 --- a/src/Simplex/Chat/Migrations/M20241027_server_operators.hs +++ b/src/Simplex/Chat/Migrations/M20241027_server_operators.hs @@ -15,8 +15,10 @@ CREATE TABLE server_operators ( legal_name TEXT, server_domains TEXT, enabled INTEGER NOT NULL DEFAULT 1, - role_storage INTEGER NOT NULL DEFAULT 1, - role_proxy INTEGER NOT NULL DEFAULT 1, + smp_role_storage INTEGER NOT NULL DEFAULT 1, + smp_role_proxy INTEGER NOT NULL DEFAULT 1, + xftp_role_storage INTEGER NOT NULL DEFAULT 1, + xftp_role_proxy INTEGER NOT NULL DEFAULT 1, created_at TEXT NOT NULL DEFAULT (datetime('now')), updated_at TEXT NOT NULL DEFAULT (datetime('now')) ); diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index c037a60770..0dc68034e7 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -596,8 +596,10 @@ CREATE TABLE server_operators( legal_name TEXT, server_domains TEXT, enabled INTEGER NOT NULL DEFAULT 1, - role_storage INTEGER NOT NULL DEFAULT 1, - role_proxy INTEGER NOT NULL DEFAULT 1, + smp_role_storage INTEGER NOT NULL DEFAULT 1, + smp_role_proxy INTEGER NOT NULL DEFAULT 1, + xftp_role_storage INTEGER NOT NULL DEFAULT 1, + xftp_role_proxy INTEGER NOT NULL DEFAULT 1, created_at TEXT NOT NULL DEFAULT(datetime('now')), updated_at TEXT NOT NULL DEFAULT(datetime('now')) ); diff --git a/src/Simplex/Chat/Operators.hs b/src/Simplex/Chat/Operators.hs index 6bf1a75da4..c3d9a8823b 100644 --- a/src/Simplex/Chat/Operators.hs +++ b/src/Simplex/Chat/Operators.hs @@ -134,6 +134,13 @@ data UsageConditionsAction | UCAAccepted {operators :: [ServerOperator]} deriving (Show) +data ServerOperatorConditions = ServerOperatorConditions + { serverOperators :: [ServerOperator], + currentConditions :: UsageConditions, + conditionsAction :: Maybe UsageConditionsAction + } + deriving (Show) + usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators @@ -178,10 +185,16 @@ data ServerOperator' s = ServerOperator serverDomains :: [Text], conditionsAcceptance :: ConditionsAcceptance, enabled :: Bool, - roles :: ServerRoles + smpRoles :: ServerRoles, + xftpRoles :: ServerRoles } deriving (Show) +operatorRoles :: UserProtocol p => SProtocolType p -> ServerOperator -> ServerRoles +operatorRoles p op = case p of + SPSMP -> smpRoles op + SPXFTP -> xftpRoles op + conditionsAccepted :: ServerOperator -> Bool conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAcceptance of CAAccepted {} -> True @@ -336,8 +349,8 @@ updatedServerOperators presetOps storedOps = Just presetOp -> (storedOp' :) where storedOp' = case find ((operatorTag presetOp ==) . operatorTag) storedOps of - Just ServerOperator {operatorId, conditionsAcceptance, enabled, roles} -> - ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, roles} + Just ServerOperator {operatorId, conditionsAcceptance, enabled, smpRoles, xftpRoles} -> + ASO SDBStored presetOp {operatorId, conditionsAcceptance, enabled, smpRoles, xftpRoles} Nothing -> ASO SDBNew presetOp -- This function should be used inside DB transaction to update servers. @@ -361,8 +374,8 @@ updatedUserServers p presetOps randomSrvs srvs = srvHost :: UserServer' s p -> NonEmpty TransportHost srvHost UserServer {server = ProtoServerWithAuth srv _} = host srv -agentServerCfgs :: [(Text, ServerOperator)] -> NonEmpty (NewUserServer p) -> [UserServer' s p] -> NonEmpty (ServerCfg p) -agentServerCfgs opDomains randomSrvs = +agentServerCfgs :: UserProtocol p => SProtocolType p -> [(Text, ServerOperator)] -> NonEmpty (NewUserServer p) -> [UserServer' s p] -> NonEmpty (ServerCfg p) +agentServerCfgs p opDomains randomSrvs = fromMaybe fallbackSrvs . L.nonEmpty . mapMaybe enabledOpAgentServer where fallbackSrvs = L.map (snd . agentServer) randomSrvs @@ -372,8 +385,8 @@ agentServerCfgs opDomains randomSrvs = 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}) -> - (opEnabled, ServerCfg {server, enabled, operator = Just opId, roles}) + Just (_, op@ServerOperator {operatorId = DBEntityId opId, enabled = opEnabled}) -> + (opEnabled, ServerCfg {server, enabled, operator = Just opId, roles = operatorRoles p op}) Nothing -> (True, ServerCfg {server, enabled, operator = Nothing, roles = allRoles}) @@ -423,7 +436,7 @@ validateUserServers curr others = currUserErrs <> concatMap otherUserErrs others p' = AProtocolType p noServers cond = not $ any srvEnabled $ snd $ partitionValid $ concatMap (`servers'` p) $ filter cond uss opEnabled = maybe True (\ServerOperator {enabled} -> enabled) . operator' - hasRole roleSel = maybe True (\ServerOperator {enabled, roles} -> enabled && roleSel roles) . operator' + hasRole roleSel = maybe True (\op@ServerOperator {enabled} -> enabled && roleSel (operatorRoles p op)) . operator' srvEnabled (AUS _ UserServer {deleted, enabled}) = enabled && not deleted serverErrs :: (UserServersClass u, ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [u] -> [UserServersError] serverErrs p uss = map (USEInvalidServer p') invalidSrvs <> mapMaybe duplicateErr_ srvs @@ -472,6 +485,8 @@ instance DBStoredI s => FromJSON (ServerOperator' s) where $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction) +$(JQ.deriveJSON defaultJSON ''ServerOperatorConditions) + instance ProtocolTypeI p => ToJSON (UserServer' s p) where toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer_) toJSON = $(JQ.mkToJSON defaultJSON ''UserServer_) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 87b5d2fd64..daf9a78fca 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -612,20 +612,21 @@ serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) auth = safeDecodeUtf8 . unBasicAuth <$> auth_ in (protocol, host, port, keyHash, auth) -getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction) +getServerOperators :: DB.Connection -> ExceptT StoreError IO ServerOperatorConditions getServerOperators db = do - currentConds <- getCurrentUsageConditions db + currentConditions <- getCurrentUsageConditions db liftIO $ do now <- getCurrentTime latestAcceptedConds_ <- getLatestAcceptedConditions db - let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConds latestAcceptedConds_ now - operators <- mapM getConds =<< getServerOperators_ db - pure (operators, usageConditionsAction operators currentConds now) + let getConds op = (\ca -> op {conditionsAcceptance = ca}) <$> getOperatorConditions_ db op currentConditions latestAcceptedConds_ now + ops <- mapM getConds =<< getServerOperators_ db + let conditionsAction = usageConditionsAction ops currentConditions now + pure ServerOperatorConditions {serverOperators = ops, currentConditions, conditionsAction} getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) getUserServers db user = (,,) - <$> (fst <$> getServerOperators db) + <$> (serverOperators <$> getServerOperators db) <*> liftIO (getProtocolServers db SPSMP user) <*> liftIO (getProtocolServers db SPXFTP user) @@ -635,15 +636,15 @@ setServerOperators db ops = do mapM_ (updateServerOperator db currentTs) ops updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO () -updateServerOperator db currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} = +updateServerOperator db currentTs ServerOperator {operatorId, enabled, smpRoles, xftpRoles} = DB.execute db [sql| UPDATE server_operators - SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ? + SET enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ?, updated_at = ? WHERE server_operator_id = ? |] - (enabled, storage, proxy, operatorId, currentTs) + (enabled, storage smpRoles, proxy smpRoles, storage xftpRoles, proxy xftpRoles, currentTs, operatorId) getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator] getUpdateServerOperators db presetOps newUser = do @@ -677,25 +678,25 @@ getUpdateServerOperators db presetOps newUser = do |] (conditionsId, conditionsCommit, notifiedAt, createdAt) updateOperator :: ServerOperator -> IO () - updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = + updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, smpRoles, xftpRoles} = DB.execute db [sql| UPDATE server_operators - SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, role_storage = ?, role_proxy = ? + SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, smp_role_storage = ?, smp_role_proxy = ?, xftp_role_storage = ?, xftp_role_proxy = ? WHERE server_operator_id = ? |] - (tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy, operatorId) + (tradeName, legalName, T.intercalate "," serverDomains, enabled, storage smpRoles, proxy smpRoles, storage xftpRoles, proxy xftpRoles, operatorId) insertOperator :: NewServerOperator -> IO ServerOperator - insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = do + insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, smpRoles, xftpRoles} = do DB.execute db [sql| INSERT INTO server_operators - (server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy) - VALUES (?,?,?,?,?,?,?) + (server_operator_tag, trade_name, legal_name, server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy) + VALUES (?,?,?,?,?,?,?,?,?) |] - (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy) + (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage smpRoles, proxy smpRoles, storage xftpRoles, proxy xftpRoles) opId <- insertedRowId db pure op {operatorId = DBEntityId opId} autoAcceptConditions op UsageConditions {conditionsCommit} = @@ -706,15 +707,15 @@ serverOperatorQuery :: Query serverOperatorQuery = [sql| SELECT server_operator_id, server_operator_tag, trade_name, legal_name, - server_domains, enabled, role_storage, role_proxy + server_domains, enabled, smp_role_storage, smp_role_proxy, xftp_role_storage, xftp_role_proxy FROM server_operators |] getServerOperators_ :: DB.Connection -> IO [ServerOperator] getServerOperators_ db = map toServerOperator <$> DB.query_ db serverOperatorQuery -toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool) -> ServerOperator -toServerOperator (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy) = +toServerOperator :: (DBEntityId, Maybe OperatorTag, Text, Maybe Text, Text, Bool) :. (Bool, Bool) :. (Bool, Bool) -> ServerOperator +toServerOperator ((operatorId, operatorTag, tradeName, legalName, domains, enabled) :. smpRoles' :. xftpRoles') = ServerOperator { operatorId, operatorTag, @@ -723,8 +724,11 @@ toServerOperator (operatorId, operatorTag, tradeName, legalName, domains, enable serverDomains = T.splitOn "," domains, conditionsAcceptance = CARequired Nothing, enabled, - roles = ServerRoles {storage, proxy} + smpRoles = serverRoles smpRoles', + xftpRoles = serverRoles xftpRoles' } + where + serverRoles (storage, proxy) = ServerRoles {storage, proxy} getOperatorConditions_ :: DB.Connection -> ServerOperator -> UsageConditions -> Maybe UsageConditions -> UTCTime -> IO ConditionsAcceptance getOperatorConditions_ db ServerOperator {operatorId} UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt} latestAcceptedConds_ now = do diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 317fd58a8e..e4c0fd5606 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -65,7 +65,7 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) -import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtocolTypeI, SProtocolType (..)) +import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtocolTypeI, SProtocolType (..), UserProtocol) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) @@ -98,7 +98,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat] CRApiParsedMarkdown ft -> [viewJSON ft] CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure - CRServerOperators ops ca -> viewServerOperators ops ca + CRServerOperatorConditions (ServerOperatorConditions ops _ ca) -> viewServerOperators ops ca CRUserServers u uss -> ttyUser u $ concatMap viewUserServers uss <> (if testView then [] else serversUserHelp) CRUserServersValidation {} -> [] CRUsageConditions {} -> [] @@ -1221,15 +1221,27 @@ viewUserServers UserOperatorServers {operator, smpServers, xftpServers} = <> viewServers SPSMP smpServers <> viewServers SPXFTP xftpServers where - viewServers :: ProtocolTypeI p => SProtocolType p -> [UserServer p] -> [StyledString] + viewServers :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServer p] -> [StyledString] viewServers _ [] = [] - viewServers p srvs = [" " <> protocolName p <> " servers"] <> map (plain . (" " <> ) . viewServer) srvs + viewServers p srvs + | maybe True (\ServerOperator {enabled} -> enabled) operator = + [" " <> protocolName p <> " servers" <> maybe "" ((" " <>) . viewRoles) operator] + <> map (plain . (" " <> ) . viewServer) srvs + | otherwise = [] 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 + viewRoles op@ServerOperator {enabled} + | not enabled = "disabled" + | storage rs && proxy rs = "enabled" + | storage rs = "enabled storage" + | proxy rs = "enabled proxy" + | otherwise = "disabled (servers known)" + where + rs = operatorRoles p op serversUserHelp :: [StyledString] serversUserHelp = @@ -1272,8 +1284,8 @@ viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsA <> (", " <> viewOpEnabled op) shortViewOperator :: ServerOperator -> Text -shortViewOperator op@ServerOperator {operatorId = DBEntityId opId, tradeName} = - tshow opId <> ". " <> tradeName <> parens (viewOpEnabled op) +shortViewOperator ServerOperator {operatorId = DBEntityId opId, tradeName, enabled} = + tshow opId <> ". " <> tradeName <> parens (if enabled then "enabled" else "disabled") viewOpIdTag :: ServerOperator' s -> Text viewOpIdTag ServerOperator {operatorId, operatorTag} = case operatorId of @@ -1290,11 +1302,19 @@ viewOpConditions = \case 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" +viewOpEnabled ServerOperator {enabled, smpRoles, xftpRoles} + | not enabled = "disabled" + | no smpRoles && no xftpRoles = "disabled (servers known)" + | both smpRoles && both xftpRoles = "enabled" + | otherwise = "SMP " <> viewRoles smpRoles <> ", XFTP" <> viewRoles xftpRoles + where + no rs = not $ storage rs || proxy rs + both rs = storage rs && proxy rs + viewRoles rs + | both rs = "enabled" + | storage rs = "enabled storage" + | proxy rs = "enabled proxy" + | otherwise = "disabled (servers known)" viewConditionsAction :: UsageConditionsAction -> [StyledString] viewConditionsAction = \case @@ -1382,12 +1402,6 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} = ["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo] <> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo] --- viewServers :: ProtocolTypeI p => [ServerOperator] -> NonEmpty (ServerCfg p) -> [StyledString] --- viewServers operators = map (plain . (\ServerCfg {server, operator} -> B.unpack (strEncode server) <> viewOperator operator)) . L.toList --- where --- ops :: Map (Maybe DBEntityId) Text = foldl' (\m ServerOperator {operatorId, tradeName} -> M.insert (Just operatorId) tradeName m) M.empty operators --- viewOperator = maybe "" $ \op -> " (operator " <> maybe (show op) T.unpack (M.lookup (Just op) ops) <> ")" - viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo where diff --git a/tests/OperatorTests.hs b/tests/OperatorTests.hs index 1b867a3e1d..4966bfbb97 100644 --- a/tests/OperatorTests.hs +++ b/tests/OperatorTests.hs @@ -29,7 +29,7 @@ validateServers = describe "validate user servers" $ do validateUserServers [invalidDisabled] [] `shouldBe` [USENoServers aSMP Nothing] validateUserServers [invalidDisabledOp] [] `shouldBe` [USENoServers aSMP Nothing, USENoServers aXFTP Nothing] it "should fail without servers with storage role" $ do - validateUserServers [invalidNoStorage] [] `shouldBe` [USEStorageMissing aSMP Nothing, USEStorageMissing aXFTP Nothing] + validateUserServers [invalidNoStorage] [] `shouldBe` [USEStorageMissing aSMP Nothing] it "should fail with duplicate host" $ do validateUserServers [invalidDuplicate] [] `shouldBe` [ USEDuplicateServer aSMP "smp://0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im,beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion" "smp8.simplex.im", @@ -71,7 +71,7 @@ invalidDisabledOp = invalidNoStorage :: UpdatedUserOperatorServers invalidNoStorage = (valid :: UpdatedUserOperatorServers) - { operator = Just operatorSimpleXChat {operatorId = DBEntityId 1, roles = allRoles {storage = False}} + { operator = Just operatorSimpleXChat {operatorId = DBEntityId 1, smpRoles = allRoles {storage = False}} } invalidDuplicate :: UpdatedUserOperatorServers