make servers of disabled operators "unknown", consider only enabled servers when switching profile links

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,

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

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)
 

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

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 <srv>") <> " to test " <> pName <> " server connection",
---           "use " <> highlight (srvCmd <> " <srv1[,srv2,...]>") <> " 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 <srv>" <> " to test SMP server connection",
+    "use " <> highlight' "/smp <srv1[,srv2,...]>" <> " 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

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"],

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 =

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