core: preset operators and servers (#5142)

* core: preset servers and operators (WIP)

* usageConditionsToAdd

* simplify

* WIP

* database entity IDs

* preset operators and servers (compiles)

* update (most tests pass)

* remove imports

* fix

* update

* make preset servers lists potentially empty in some operators, as long as the combined list is not empty

* CLI API in progress, validateUserServers

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

* exclude disabled operators when receiving files

* fix TH in ghc 8.10.7

* add type for ghc 8.10.7

* pattern match for ghc 8.10.7

* ghc 8.10.7 fix attempt

* remove additional pattern, update servers

* do not strip title from conditions

* remove space

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

src/Simplex/Chat/Controller.hs

@@ -35,7 +35,6 @@ import qualified Data.ByteArray as BA
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (ord)
-import Data.Constraint (Dict (..))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
@@ -71,7 +70,7 @@ import Simplex.Chat.Util (liftIOEither)
 import Simplex.FileTransfer.Description (FileDescriptionURI)
 import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
 import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
-import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg)
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, SQLiteStore, UpMigration, withTransaction, withTransactionPriority)
@@ -85,7 +84,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
-import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), ProtocolTypeI, QueueId, SMPMsgMeta (..), SProtocolType, SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
+import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), CorrId, MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer)
 import Simplex.Messaging.TMap (TMap)
 import Simplex.Messaging.Transport (TLS, simplexMQVersion)
 import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
@@ -133,7 +132,7 @@ data ChatConfig = ChatConfig
   { agentConfig :: AgentConfig,
     chatVRange :: VersionRangeChat,
     confirmMigrations :: MigrationConfirmation,
-    defaultServers :: DefaultAgentServers,
+    presetServers :: PresetServers,
     tbqSize :: Natural,
     fileChunkSize :: Integer,
     xftpDescrPartSize :: Int,
@@ -155,6 +154,12 @@ data ChatConfig = ChatConfig
     chatHooks :: ChatHooks
   }
 
+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
   { -- preCmdHook can be used to process or modify the commands before they are processed.
@@ -173,12 +178,9 @@ defaultChatHooks =
       eventHook = \_ -> pure
     }
 
-data DefaultAgentServers = DefaultAgentServers
-  { smp :: NonEmpty (ServerCfg 'PSMP),
-    useSMP :: Int,
+data PresetServers = PresetServers
+  { operators :: NonEmpty PresetOperator,
     ntf :: [NtfServer],
-    xftp :: NonEmpty (ServerCfg 'PXFTP),
-    useXFTP :: Int,
     netCfg :: NetworkConfig
   }
 
@@ -204,6 +206,7 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite
 
 data ChatController = ChatController
   { currentUser :: TVar (Maybe User),
+    randomServers :: RandomServers,
     currentRemoteHost :: TVar (Maybe RemoteHostId),
     firstTime :: Bool,
     smpAgent :: AgentClient,
@@ -347,20 +350,18 @@ data ChatCommand
   | APIGetGroupLink GroupId
   | APICreateMemberContact GroupId GroupMemberId
   | APISendMemberContactInvitation {contactId :: ContactId, msgContent_ :: Maybe MsgContent}
-  | APIGetUserProtoServers UserId AProtocolType
   | GetUserProtoServers AProtocolType
-  | APISetUserProtoServers UserId AProtoServersConfig
-  | SetUserProtoServers AProtoServersConfig
+  | SetUserProtoServers AProtocolType [AProtoServerWithAuth]
   | APITestProtoServer UserId AProtoServerWithAuth
   | TestProtoServer AProtoServerWithAuth
   | APIGetServerOperators
-  | APISetServerOperators (NonEmpty OperatorEnabled)
+  | APISetServerOperators (NonEmpty ServerOperator)
   | APIGetUserServers UserId
-  | APISetUserServers UserId (NonEmpty UserServers)
-  | APIValidateServers (NonEmpty UserServers) -- response is CRUserServersValidation
+  | APISetUserServers UserId (NonEmpty UpdatedUserOperatorServers)
+  | APIValidateServers (NonEmpty UpdatedUserOperatorServers) -- response is CRUserServersValidation
   | APIGetUsageConditions
   | APISetConditionsNotified Int64
-  | APIAcceptConditions Int64 (NonEmpty ServerOperator)
+  | APIAcceptConditions Int64 (NonEmpty Int64)
   | APISetChatItemTTL UserId (Maybe Int64)
   | SetChatItemTTL (Maybe Int64)
   | APIGetChatItemTTL UserId
@@ -586,10 +587,9 @@ data ChatResponse
   | CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
   | CRChatItemId User (Maybe ChatItemId)
   | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
-  | CRUserProtoServers {user :: User, servers :: AUserProtoServers, operators :: [ServerOperator]}
   | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
   | CRServerOperators {operators :: [ServerOperator], conditionsAction :: Maybe UsageConditionsAction}
-  | CRUserServers {user :: User, userServers :: [UserServers]}
+  | CRUserServers {user :: User, userServers :: [UserOperatorServers]}
   | CRUserServersValidation {serverErrors :: [UserServersError]}
   | CRUsageConditions {usageConditions :: UsageConditions, conditionsText :: Text, acceptedConditions :: Maybe UsageConditions}
   | CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
@@ -956,23 +956,23 @@ instance ToJSON AgentQueueId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
-data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
-  deriving (Show)
+-- data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
+--   deriving (Show)
 
-data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
+-- data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
 
-deriving instance Show AProtoServersConfig
+-- deriving instance Show AProtoServersConfig
 
-data UserProtoServers p = UserProtoServers
-  { serverProtocol :: SProtocolType p,
-    protoServers :: NonEmpty (ServerCfg p),
-    presetServers :: NonEmpty (ServerCfg p)
-  }
-  deriving (Show)
+-- data UserProtoServers p = UserProtoServers
+--   { serverProtocol :: SProtocolType p,
+--     protoServers :: NonEmpty (ServerCfg p),
+--     presetServers :: NonEmpty (ServerCfg p)
+--   }
+--   deriving (Show)
 
-data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
+-- data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
 
-deriving instance Show AUserProtoServers
+-- deriving instance Show AUserProtoServers
 
 data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
   deriving (Show)
@@ -1575,28 +1575,28 @@ $(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
 
 $(JQ.deriveJSON defaultJSON ''SlowSQLQuery)
 
-instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
-  parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
+-- instance ProtocolTypeI p => FromJSON (ProtoServersConfig p) where
+--   parseJSON = $(JQ.mkParseJSON defaultJSON ''ProtoServersConfig)
 
-instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
-  parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
+-- instance ProtocolTypeI p => FromJSON (UserProtoServers p) where
+--   parseJSON = $(JQ.mkParseJSON defaultJSON ''UserProtoServers)
 
-instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
-  toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
-  toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
+-- instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
+--   toJSON = $(JQ.mkToJSON defaultJSON ''UserProtoServers)
+--   toEncoding = $(JQ.mkToEncoding defaultJSON ''UserProtoServers)
 
-instance FromJSON AUserProtoServers where
-  parseJSON v = J.withObject "AUserProtoServers" parse v
-    where
-      parse o = do
-        AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
-        case userProtocol p of
-          Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
-          Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
+-- instance FromJSON AUserProtoServers where
+--   parseJSON v = J.withObject "AUserProtoServers" parse v
+--     where
+--       parse o = do
+--         AProtocolType (p :: SProtocolType p) <- o .: "serverProtocol"
+--         case userProtocol p of
+--           Just Dict -> AUPS <$> J.parseJSON @(UserProtoServers p) v
+--           Nothing -> fail $ "AUserProtoServers: unsupported protocol " <> show p
 
-instance ToJSON AUserProtoServers where
-  toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
-  toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
+-- instance ToJSON AUserProtoServers where
+--   toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s
+--   toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
 

src/Simplex/Chat/Migrations/M20241027_server_operators.hs

@@ -11,7 +11,6 @@ m20241027_server_operators =
 CREATE TABLE server_operators (
   server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
   server_operator_tag TEXT,
-  app_vendor INTEGER NOT NULL,
   trade_name TEXT NOT NULL,
   legal_name TEXT,
   server_domains TEXT,
@@ -22,8 +21,6 @@ CREATE TABLE server_operators (
   updated_at TEXT NOT NULL DEFAULT (datetime('now'))
 );
 
-ALTER TABLE protocol_servers ADD COLUMN server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL;
-
 CREATE TABLE usage_conditions (
   usage_conditions_id INTEGER PRIMARY KEY AUTOINCREMENT,
   conditions_commit TEXT NOT NULL UNIQUE,
@@ -41,18 +38,8 @@ CREATE TABLE operator_usage_conditions (
   created_at TEXT NOT NULL DEFAULT (datetime('now'))
 );
 
-CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(server_operator_id);
 CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(server_operator_id);
-CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(server_operator_id, conditions_commit);
-
-INSERT INTO server_operators
-  (server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
-  VALUES (1, 'simplex', 1, 'SimpleX Chat', 'SimpleX Chat Ltd', 'simplex.im', 1);
-INSERT INTO server_operators
-  (server_operator_id, server_operator_tag, app_vendor, trade_name, legal_name, server_domains, enabled)
-  VALUES (2, 'xyz', 0, 'XYZ', 'XYZ Ltd', 'xyz.com', 0);
-
--- UPDATE protocol_servers SET server_operator_id = 1 WHERE host LIKE "%.simplex.im" OR host LIKE "%.simplex.im,%";
+CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(conditions_commit, server_operator_id);
 |]
 
 down_m20241027_server_operators :: Query
@@ -60,9 +47,6 @@ down_m20241027_server_operators =
   [sql|
 DROP INDEX idx_operator_usage_conditions_conditions_commit;
 DROP INDEX idx_operator_usage_conditions_server_operator_id;
-DROP INDEX idx_protocol_servers_server_operator_id;
-
-ALTER TABLE protocol_servers DROP COLUMN server_operator_id;
 
 DROP TABLE operator_usage_conditions;
 DROP TABLE usage_conditions;

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -450,7 +450,6 @@ CREATE TABLE IF NOT EXISTS "protocol_servers"(
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
   protocol TEXT NOT NULL DEFAULT 'smp',
-  server_operator_id INTEGER REFERENCES server_operators ON DELETE SET NULL,
   UNIQUE(user_id, host, port)
 );
 CREATE TABLE xftp_file_descriptions(
@@ -593,7 +592,6 @@ CREATE TABLE app_settings(app_settings TEXT NOT NULL);
 CREATE TABLE server_operators(
   server_operator_id INTEGER PRIMARY KEY AUTOINCREMENT,
   server_operator_tag TEXT,
-  app_vendor INTEGER NOT NULL,
   trade_name TEXT NOT NULL,
   legal_name TEXT,
   server_domains TEXT,
@@ -919,13 +917,10 @@ CREATE INDEX idx_received_probes_group_member_id on received_probes(
   group_member_id
 );
 CREATE INDEX idx_contact_requests_contact_id ON contact_requests(contact_id);
-CREATE INDEX idx_protocol_servers_server_operator_id ON protocol_servers(
-  server_operator_id
-);
 CREATE INDEX idx_operator_usage_conditions_server_operator_id ON operator_usage_conditions(
   server_operator_id
 );
 CREATE UNIQUE INDEX idx_operator_usage_conditions_conditions_commit ON operator_usage_conditions(
-  server_operator_id,
-  conditions_commit
+  conditions_commit,
+  server_operator_id
 );

src/Simplex/Chat/Operators.hs

@@ -1,24 +1,42 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.Chat.Operators where
 
+import Control.Applicative ((<|>))
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
 import Data.FileEmbed
+import Data.Foldable (foldMap')
+import Data.IORef
 import Data.Int (Int64)
+import Data.List (find, foldl')
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, isNothing)
+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
+import Data.Scientific (floatingOrInteger)
+import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Time (addUTCTime)
 import Data.Time.Clock (UTCTime, nominalDay)
 import Database.SQLite.Simple.FromField (FromField (..))
@@ -26,23 +44,51 @@ import Database.SQLite.Simple.ToField (ToField (..))
 import Language.Haskell.TH.Syntax (lift)
 import Simplex.Chat.Operators.Conditions
 import Simplex.Chat.Types.Util (textParseJSON)
-import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles (..))
+import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, sumTypeJSON)
-import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), SProtocolType (..))
-import Simplex.Messaging.Util (safeDecodeUtf8)
+import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, SProtocolType (..), UserProtocol)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8)
 
 usageConditionsCommit :: Text
-usageConditionsCommit = "165143a1112308c035ac00ed669b96b60599aa1c"
+usageConditionsCommit = "a5061f3147165a05979d6ace33960aced2d6ac03"
+
+previousConditionsCommit :: Text
+previousConditionsCommit = "11a44dc1fd461a93079f897048b46998db55da5c"
 
 usageConditionsText :: Text
 usageConditionsText =
   $( let s = $(embedFile =<< makeRelativeToProject "PRIVACY.md")
-      in [|stripFrontMatter (safeDecodeUtf8 $(lift s))|]
+      in [|stripFrontMatter $(lift (safeDecodeUtf8 s))|]
    )
 
-data OperatorTag = OTSimplex | OTXyz
-  deriving (Show)
+data DBStored = DBStored | DBNew
+
+data SDBStored (s :: DBStored) where
+  SDBStored :: SDBStored 'DBStored
+  SDBNew :: SDBStored 'DBNew
+
+deriving instance Show (SDBStored s)
+
+class DBStoredI s where sdbStored :: SDBStored s
+
+instance DBStoredI 'DBStored where sdbStored = SDBStored
+
+instance DBStoredI 'DBNew where sdbStored = SDBNew
+
+data DBEntityId' (s :: DBStored) where
+  DBEntityId :: Int64 -> DBEntityId' 'DBStored
+  DBNewEntity :: DBEntityId' 'DBNew
+
+deriving instance Show (DBEntityId' s)
+
+type DBEntityId = DBEntityId' 'DBStored
+
+type DBNewEntity = DBEntityId' 'DBNew
+
+data OperatorTag = OTSimplex | OTFlux
+  deriving (Eq, Ord, Show)
 
 instance FromField OperatorTag where fromField = fromTextField_ textDecode
 
@@ -58,11 +104,17 @@ instance ToJSON OperatorTag where
 instance TextEncoding OperatorTag where
   textDecode = \case
     "simplex" -> Just OTSimplex
-    "xyz" -> Just OTXyz
+    "flux" -> Just OTFlux
     _ -> Nothing
   textEncode = \case
     OTSimplex -> "simplex"
-    OTXyz -> "xyz"
+    OTFlux -> "flux"
+
+-- this and other types only define instances of serialization for known DB IDs only,
+-- entities without IDs cannot be serialized to JSON
+instance FromField DBEntityId where fromField f = DBEntityId <$> fromField f
+
+instance ToField DBEntityId where toField (DBEntityId i) = toField i
 
 data UsageConditions = UsageConditions
   { conditionsId :: Int64,
@@ -80,18 +132,16 @@ data UsageConditionsAction
 usageConditionsAction :: [ServerOperator] -> UsageConditions -> UTCTime -> Maybe UsageConditionsAction
 usageConditionsAction operators UsageConditions {createdAt, notifiedAt} now = do
   let enabledOperators = filter (\ServerOperator {enabled} -> enabled) operators
-  if null enabledOperators
-    then Nothing
-    else
-      if all conditionsAccepted enabledOperators
-        then
-          let acceptedForOperators = filter conditionsAccepted operators
-           in Just $ UCAAccepted acceptedForOperators
-        else
-          let acceptForOperators = filter (not . conditionsAccepted) enabledOperators
-              deadline = conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
-              showNotice = isNothing notifiedAt
-           in Just $ UCAReview acceptForOperators deadline showNotice
+  if
+    | null enabledOperators -> Nothing
+    | all conditionsAccepted enabledOperators ->
+        let acceptedForOperators = filter conditionsAccepted operators
+         in Just $ UCAAccepted acceptedForOperators
+    | otherwise ->
+        let acceptForOperators = filter (not . conditionsAccepted) enabledOperators
+            deadline = conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
+            showNotice = isNothing notifiedAt
+         in Just $ UCAReview acceptForOperators deadline showNotice
 
 conditionsRequiredOrDeadline :: UTCTime -> UTCTime -> Maybe UTCTime
 conditionsRequiredOrDeadline createdAt notifiedAtOrNow =
@@ -107,8 +157,16 @@ data ConditionsAcceptance
   | CARequired {deadline :: Maybe UTCTime}
   deriving (Show)
 
-data ServerOperator = ServerOperator
-  { operatorId :: OperatorId,
+type ServerOperator = ServerOperator' 'DBStored
+
+type NewServerOperator = ServerOperator' 'DBNew
+
+data AServerOperator = forall s. ASO (SDBStored s) (ServerOperator' s)
+
+deriving instance Show AServerOperator
+
+data ServerOperator' s = ServerOperator
+  { operatorId :: DBEntityId' s,
     operatorTag :: Maybe OperatorTag,
     tradeName :: Text,
     legalName :: Maybe Text,
@@ -124,81 +182,257 @@ conditionsAccepted ServerOperator {conditionsAcceptance} = case conditionsAccept
   CAAccepted {} -> True
   _ -> False
 
-data OperatorEnabled = OperatorEnabled
-  { operatorId :: OperatorId,
-    enabled :: Bool,
-    roles :: ServerRoles
-  }
-  deriving (Show)
-
-data UserServers = UserServers
+data UserOperatorServers = UserOperatorServers
   { operator :: Maybe ServerOperator,
-    smpServers :: [ServerCfg 'PSMP],
-    xftpServers :: [ServerCfg 'PXFTP]
+    smpServers :: [UserServer 'PSMP],
+    xftpServers :: [UserServer 'PXFTP]
   }
   deriving (Show)
 
-groupByOperator :: [ServerOperator] -> [ServerCfg 'PSMP] -> [ServerCfg 'PXFTP] -> [UserServers]
-groupByOperator srvOperators smpSrvs xftpSrvs =
-  map createOperatorServers (M.toList combinedMap)
+data UpdatedUserOperatorServers = UpdatedUserOperatorServers
+  { operator :: Maybe ServerOperator,
+    smpServers :: [AUserServer 'PSMP],
+    xftpServers :: [AUserServer 'PXFTP]
+  }
+  deriving (Show)
+
+updatedServers :: UserProtocol p => UpdatedUserOperatorServers -> SProtocolType p -> [AUserServer p]
+updatedServers UpdatedUserOperatorServers {smpServers, xftpServers} = \case
+  SPSMP -> smpServers
+  SPXFTP -> xftpServers
+
+type UserServer p = UserServer' 'DBStored p
+
+type NewUserServer p = UserServer' 'DBNew p
+
+data AUserServer p = forall s. AUS (SDBStored s) (UserServer' s p)
+
+deriving instance Show (AUserServer p)
+
+data UserServer' s p = UserServer
+  { serverId :: DBEntityId' s,
+    server :: ProtoServerWithAuth p,
+    preset :: Bool,
+    tested :: Maybe Bool,
+    enabled :: Bool,
+    deleted :: Bool
+  }
+  deriving (Show)
+
+data PresetOperator = PresetOperator
+  { operator :: Maybe NewServerOperator,
+    smp :: [NewUserServer 'PSMP],
+    useSMP :: Int,
+    xftp :: [NewUserServer 'PXFTP],
+    useXFTP :: Int
+  }
+
+operatorServers :: UserProtocol p => SProtocolType p -> PresetOperator -> [NewUserServer p]
+operatorServers p PresetOperator {smp, xftp} = case p of
+  SPSMP -> smp
+  SPXFTP -> xftp
+
+operatorServersToUse :: UserProtocol p => SProtocolType p -> PresetOperator -> Int
+operatorServersToUse p PresetOperator {useSMP, useXFTP} = case p of
+  SPSMP -> useSMP
+  SPXFTP -> useXFTP
+
+presetServer :: Bool -> ProtoServerWithAuth p -> NewUserServer p
+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)
+usageConditionsToAdd :: Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
+usageConditionsToAdd = usageConditionsToAdd' previousConditionsCommit usageConditionsCommit
+
+-- This function is used in unit tests
+usageConditionsToAdd' :: Text -> Text -> Bool -> UTCTime -> [UsageConditions] -> (Maybe UsageConditions, UsageConditions, [UsageConditions])
+usageConditionsToAdd' prevCommit sourceCommit newUser createdAt = \case
+  []
+    | newUser -> (Just sourceCond, sourceCond, [sourceCond])
+    | otherwise -> (Just prevCond, sourceCond, [prevCond, sourceCond])
+    where
+      prevCond = conditions 1 prevCommit
+      sourceCond = conditions 2 sourceCommit
+  conds
+    | hasSourceCond -> (Nothing, last conds, [])
+    | otherwise -> (Nothing, sourceCond, [sourceCond])
+    where
+      hasSourceCond = any ((sourceCommit ==) . conditionsCommit) conds
+      sourceCond = conditions cId sourceCommit
+      cId = maximum (map conditionsId conds) + 1
   where
-    srvOperatorId ServerCfg {operator} = operator
-    opId ServerOperator {operatorId} = operatorId
-    operatorMap :: Map (Maybe Int64) (Maybe ServerOperator)
-    operatorMap = M.fromList [(Just (opId op), Just op) | op <- srvOperators] `M.union` M.singleton Nothing Nothing
-    initialMap :: Map (Maybe Int64) ([ServerCfg 'PSMP], [ServerCfg 'PXFTP])
-    initialMap = M.fromList [(key, ([], [])) | key <- M.keys operatorMap]
-    smpsMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (server : smps, xftps)) (srvOperatorId server) acc) initialMap smpSrvs
-    combinedMap = foldr (\server acc -> M.adjust (\(smps, xftps) -> (smps, server : xftps)) (srvOperatorId server) acc) smpsMap xftpSrvs
-    createOperatorServers (key, (groupedSmps, groupedXftps)) =
-      UserServers
-        { operator = fromMaybe Nothing (M.lookup key operatorMap),
-          smpServers = groupedSmps,
-          xftpServers = groupedXftps
-        }
+    conditions cId commit = UsageConditions {conditionsId = cId, conditionsCommit = commit, notifiedAt = Nothing, createdAt}
+
+-- This function should be used inside DB transaction to update operators.
+-- It allows to add/remove/update preset operators in the database preserving enabled and roles settings,
+-- and preserves custom operators without tags for forward compatibility.
+updatedServerOperators :: NonEmpty PresetOperator -> [ServerOperator] -> [AServerOperator]
+updatedServerOperators presetOps storedOps =
+  foldr addPreset [] presetOps
+    <> map (ASO SDBStored) (filter (isNothing . operatorTag) storedOps)
+  where
+    -- TODO remove domains of preset operators from custom
+    addPreset PresetOperator {operator} = case operator of
+      Nothing -> id
+      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}
+            Nothing -> ASO SDBNew presetOp
+
+-- This function should be used inside DB transaction to update servers.
+updatedUserServers :: forall p. UserProtocol p => SProtocolType p -> NonEmpty PresetOperator -> NonEmpty (NewUserServer p) -> [UserServer p] -> NonEmpty (AUserServer p)
+updatedUserServers _ _ randomSrvs [] = L.map (AUS SDBNew) randomSrvs
+updatedUserServers p presetOps randomSrvs srvs = 
+  fromMaybe (L.map (AUS SDBNew) randomSrvs) (L.nonEmpty updatedSrvs)
+  where
+    updatedSrvs = map userServer presetSrvs <> map (AUS SDBStored) (filter customServer srvs)
+    storedSrvs :: Map (ProtoServerWithAuth p) (UserServer p)
+    storedSrvs = foldl' (\ss srv@UserServer {server} -> M.insert server srv ss) M.empty srvs
+    customServer :: UserServer p -> Bool
+    customServer srv = not (preset srv) && all (`S.notMember` presetHosts) (srvHost srv)
+    presetSrvs :: [NewUserServer p]
+    presetSrvs = concatMap (operatorServers p) presetOps
+    presetHosts :: Set TransportHost
+    presetHosts = foldMap' (S.fromList . L.toList . srvHost) presetSrvs
+    userServer :: NewUserServer p -> AUserServer p
+    userServer srv@UserServer {server} = maybe (AUS SDBNew srv) (AUS SDBStored) (M.lookup server storedSrvs)
+
+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 =
+  fromMaybe fallbackSrvs . L.nonEmpty . mapMaybe enabledOpAgentServer
+  where
+    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}) ->
+          (opEnabled, ServerCfg {server, enabled, operator = Just opId, roles})
+        Nothing ->
+          (True, ServerCfg {server, enabled, operator = Nothing, roles = allRoles})
+
+matchingHost :: Text -> TransportHost -> Bool
+matchingHost d = \case
+  THDomainName h -> d `T.isSuffixOf` T.pack h
+  _ -> False
+
+operatorDomains :: [ServerOperator] -> [(Text, ServerOperator)]
+operatorDomains = foldr (\op ds -> foldr (\d -> ((d, op) :)) ds (serverDomains op)) []
+
+groupByOperator :: ([ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> IO [UserOperatorServers]
+groupByOperator (ops, smpSrvs, xftpSrvs) = do
+  ss <- mapM (\op -> (serverDomains op,) <$> newIORef (UserOperatorServers (Just op) [] [])) ops
+  custom <- newIORef $ UserOperatorServers Nothing [] []
+  mapM_ (addServer ss custom addSMP) (reverse smpSrvs)
+  mapM_ (addServer ss custom addXFTP) (reverse xftpSrvs)
+  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 = 
+      let v = maybe custom snd $ find (\(ds, _) -> any (\d -> any (matchingHost d) (srvHost srv)) ds) ss
+       in atomicModifyIORef'_ v $ add srv
+    addSMP srv s@UserOperatorServers {smpServers} = (s :: UserOperatorServers) {smpServers = srv : smpServers}
+    addXFTP srv s@UserOperatorServers {xftpServers} = (s :: UserOperatorServers) {xftpServers = srv : xftpServers}
 
 data UserServersError
-  = USEStorageMissing
-  | USEProxyMissing
-  | USEDuplicateSMP {server :: AProtoServerWithAuth}
-  | USEDuplicateXFTP {server :: AProtoServerWithAuth}
+  = USEStorageMissing {protocol :: AProtocolType}
+  | USEProxyMissing {protocol :: AProtocolType}
+  | USEDuplicateServer {protocol :: AProtocolType, duplicateServer :: AProtoServerWithAuth, duplicateHost :: TransportHost}
   deriving (Show)
 
-validateUserServers :: NonEmpty UserServers -> [UserServersError]
-validateUserServers userServers =
-  let storageMissing_ = if any (canUseForRole storage) userServers then [] else [USEStorageMissing]
-      proxyMissing_ = if any (canUseForRole proxy) userServers then [] else [USEProxyMissing]
-
-      allSMPServers = map (\ServerCfg {server} -> server) $ concatMap (\UserServers {smpServers} -> smpServers) userServers
-      duplicateSMPServers = findDuplicatesByHost allSMPServers
-      duplicateSMPErrors = map (USEDuplicateSMP . AProtoServerWithAuth SPSMP) duplicateSMPServers
-
-      allXFTPServers = map (\ServerCfg {server} -> server) $ concatMap (\UserServers {xftpServers} -> xftpServers) userServers
-      duplicateXFTPServers = findDuplicatesByHost allXFTPServers
-      duplicateXFTPErrors = map (USEDuplicateXFTP . AProtoServerWithAuth SPXFTP) duplicateXFTPServers
-   in storageMissing_ <> proxyMissing_ <> duplicateSMPErrors <> duplicateXFTPErrors
+validateUserServers :: NonEmpty UpdatedUserOperatorServers -> [UserServersError]
+validateUserServers uss =
+  missingRolesErr SPSMP storage USEStorageMissing
+    <> missingRolesErr SPSMP proxy USEProxyMissing
+    <> missingRolesErr SPXFTP storage USEStorageMissing
+    <> duplicatServerErrs SPSMP
+    <> duplicatServerErrs SPXFTP
   where
-    canUseForRole :: (ServerRoles -> Bool) -> UserServers -> Bool
-    canUseForRole roleSel UserServers {operator, smpServers, xftpServers} = case operator of
-      Just ServerOperator {roles} -> roleSel roles
-      Nothing -> not (null smpServers) && not (null xftpServers)
-    findDuplicatesByHost :: [ProtoServerWithAuth p] -> [ProtoServerWithAuth p]
-    findDuplicatesByHost servers =
-      let allHosts = concatMap (L.toList . host . protoServer) servers
-          hostCounts = M.fromListWith (+) [(host, 1 :: Int) | host <- allHosts]
-          duplicateHosts = M.keys $ M.filter (> 1) hostCounts
-       in filter (\srv -> any (`elem` duplicateHosts) (L.toList $ host . protoServer $ srv)) servers
+    missingRolesErr :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> (ServerRoles -> Bool) -> (AProtocolType -> UserServersError) -> [UserServersError]
+    missingRolesErr p roleSel err = [err (AProtocolType p) | not hasRole]
+      where
+        hasRole =
+          any (\(AUS _ UserServer {deleted, enabled}) -> enabled && not deleted) $
+            concatMap (`updatedServers` p) $ filter roleEnabled (L.toList uss)
+        roleEnabled UpdatedUserOperatorServers {operator} =
+          maybe True (\ServerOperator {enabled, roles} -> enabled && roleSel roles) operator
+    duplicatServerErrs :: (ProtocolTypeI p, UserProtocol p) => SProtocolType p -> [UserServersError]
+    duplicatServerErrs p = mapMaybe duplicateErr_ srvs
+      where
+        srvs =
+          filter (\(AUS _ UserServer {deleted}) -> not deleted) $
+            concatMap (`updatedServers` p) (L.toList uss)
+        duplicateErr_ (AUS _ srv@UserServer {server}) =
+          USEDuplicateServer (AProtocolType p) (AProtoServerWithAuth p server)
+            <$> find (`S.member` duplicateHosts) (srvHost srv)
+        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 (DBEntityId' s) where
+  toEncoding = \case
+    DBEntityId i -> toEncoding i
+    DBNewEntity -> JE.null_
+  toJSON = \case
+    DBEntityId i -> toJSON i
+    DBNewEntity -> J.Null
+
+instance DBStoredI s => FromJSON (DBEntityId' s) where
+  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)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CA") ''ConditionsAcceptance)
 
-$(JQ.deriveJSON defaultJSON ''ServerOperator)
+instance ToJSON (ServerOperator' s) where
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerOperator')
+  toJSON = $(JQ.mkToJSON defaultJSON ''ServerOperator')
 
-$(JQ.deriveJSON defaultJSON ''OperatorEnabled)
+instance DBStoredI s => FromJSON (ServerOperator' s) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerOperator')
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "UCA") ''UsageConditionsAction)
 
-$(JQ.deriveJSON defaultJSON ''UserServers)
+instance ProtocolTypeI p => ToJSON (UserServer' s p) where
+  toEncoding = $(JQ.mkToEncoding defaultJSON ''UserServer')
+  toJSON = $(JQ.mkToJSON defaultJSON ''UserServer')
+
+instance (DBStoredI s, ProtocolTypeI p) => FromJSON (UserServer' s p) where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''UserServer')
+
+instance ProtocolTypeI p => FromJSON (AUserServer p) where
+  parseJSON v = (AUS SDBStored <$> parseJSON v) <|> (AUS SDBNew <$> parseJSON v)
+
+$(JQ.deriveJSON defaultJSON ''UserOperatorServers)
+
+instance FromJSON UpdatedUserOperatorServers where
+  parseJSON = $(JQ.mkParseJSON defaultJSON ''UpdatedUserOperatorServers)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "USE") ''UserServersError)

src/Simplex/Chat/Operators/Conditions.hs

@@ -9,7 +9,7 @@ import qualified Data.Text as T
 stripFrontMatter :: Text -> Text
 stripFrontMatter =
   T.unlines
-    . dropWhile ("# " `T.isPrefixOf`) -- strip title
+    -- . dropWhile ("# " `T.isPrefixOf`) -- strip title
     . dropWhile (T.all isSpace)
     . dropWhile fm
     . (\ls -> let ls' = dropWhile (not . fm) ls in if null ls' then ls else ls')

src/Simplex/Chat/Stats.hs

@@ -7,7 +7,6 @@ module Simplex.Chat.Stats where
 
 import qualified Data.Aeson.TH as J
 import Data.List (partition)
-import Data.List.NonEmpty (NonEmpty)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust)
@@ -131,7 +130,7 @@ data NtfServerSummary = NtfServerSummary
 -- - users are passed to exclude hidden users from totalServersSummary;
 -- - if currentUser is hidden, it should be accounted in totalServersSummary;
 -- - known is set only in user level summaries based on passed userSMPSrvs and userXFTPSrvs
-toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> NonEmpty SMPServer -> NonEmpty XFTPServer -> [NtfServer] -> PresentedServersSummary
+toPresentedServersSummary :: AgentServersSummary -> [User] -> User -> [SMPServer] -> [XFTPServer] -> [NtfServer] -> PresentedServersSummary
 toPresentedServersSummary agentSummary users currentUser userSMPSrvs userXFTPSrvs userNtfSrvs = do
   let (userSMPSrvsSumms, allSMPSrvsSumms) = accSMPSrvsSummaries
       (userSMPCurr, userSMPPrev, userSMPProx) = smpSummsIntoCategories userSMPSrvsSumms

src/Simplex/Chat/Store/Profiles.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -47,9 +50,13 @@ module Simplex.Chat.Store.Profiles
     getContactWithoutConnViaAddress,
     updateUserAddressAutoAccept,
     getProtocolServers,
+    getUpdateUserServers,
     -- overwriteOperatorsAndServers,
     overwriteProtocolServers,
+    insertProtocolServer,
+    getUpdateServerOperators,
     getServerOperators,
+    getUserServers,
     setServerOperators,
     getCurrentUsageConditions,
     getLatestAcceptedConditions,
@@ -77,10 +84,11 @@ import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
-import Data.Text (Text, splitOn)
+import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
-import Database.SQLite.Simple (NamedParam (..), Only (..), (:.) (..))
+import Database.SQLite.Simple (NamedParam (..), Only (..), Query, (:.) (..))
 import Database.SQLite.Simple.QQ (sql)
 import Simplex.Chat.Call
 import Simplex.Chat.Messages
@@ -92,7 +100,7 @@ import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Chat.Types.Shared
 import Simplex.Chat.Types.UITheme
-import Simplex.Messaging.Agent.Env.SQLite (OperatorId, ServerCfg (..), ServerRoles (..))
+import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
 import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
 import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
@@ -100,7 +108,7 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON)
-import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
+import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode, UserProtocol)
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
 
@@ -524,177 +532,282 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do
       Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
       _ -> (False, False, Nothing)
 
-getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
-getProtocolServers db User {userId} =
-  map toServerCfg
+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' = L.toList $ updatedUserServers p presetOps randomSrvs srvs
+  mapM (upsertServer ts) srvs'
+  where
+    upsertServer :: UTCTime -> AUserServer p -> IO (UserServer p)
+    upsertServer ts (AUS _ s@UserServer {serverId}) = case serverId of
+      DBNewEntity -> insertProtocolServer db p user ts s
+      DBEntityId _ -> updateProtocolServer db p ts s $> s
+
+getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> IO [UserServer p]
+getProtocolServers db p User {userId} =
+  map toUserServer
     <$> DB.query
       db
       [sql|
-        SELECT s.host, s.port, s.key_hash, s.basic_auth, s.server_operator_id, s.preset, s.tested, s.enabled, o.role_storage, o.role_proxy
-        FROM protocol_servers s
-        LEFT JOIN server_operators o USING (server_operator_id)
-        WHERE s.user_id = ? AND s.protocol = ?
+        SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled
+        FROM protocol_servers
+        WHERE user_id = ? AND protocol = ?
       |]
-      (userId, decodeLatin1 $ strEncode protocol)
+      (userId, decodeLatin1 $ strEncode p)
   where
-    protocol = protocolTypeI @p
-    toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Maybe OperatorId, Bool, Maybe Bool, Bool, Maybe Bool, Maybe Bool) -> ServerCfg p
-    toServerCfg (host, port, keyHash, auth_, operator, preset, tested, enabled, storage_, proxy_) =
-      let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
-          roles = ServerRoles {storage = fromMaybe True storage_, proxy = fromMaybe True proxy_}
-       in ServerCfg {server, operator, preset, tested, enabled, roles}
+    toUserServer :: (DBEntityId, NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> UserServer p
+    toUserServer (serverId, host, port, keyHash, auth_, preset, tested, enabled) =
+      let server = ProtoServerWithAuth (ProtocolServer p host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
+       in UserServer {serverId, server, preset, tested, enabled, deleted = False}
 
 -- TODO remove
 -- overwriteOperatorsAndServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> Maybe [ServerOperator] -> [ServerCfg p] -> ExceptT StoreError IO [ServerCfg p]
 -- overwriteOperatorsAndServers db user@User {userId} operators_ servers = do
-overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
-overwriteProtocolServers db User {userId} servers =
+overwriteProtocolServers :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> [UserServer p] -> ExceptT StoreError IO ()
+overwriteProtocolServers db p User {userId} servers =
   -- liftIO $ mapM_ (updateServerOperators_ db) operators_
   checkConstraint SEUniqueID . ExceptT $ do
     currentTs <- getCurrentTime
-    DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, protocol)
-    forM_ servers $ \ServerCfg {server, preset, tested, enabled} -> do
-      let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
+    DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND protocol = ? " (userId, decodeLatin1 $ strEncode p)
+    forM_ servers $ \UserServer {serverId, server, preset, tested, enabled} -> do
       DB.execute
         db
         [sql|
           INSERT INTO protocol_servers
-            (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
-          VALUES (?,?,?,?,?,?,?,?,?,?,?)
+            (server_id, protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
         |]
-        ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
-    -- Right <$> getProtocolServers db user
+        (Only serverId :. serverColumns p server :. (preset, tested, enabled, userId, currentTs, currentTs))
     pure $ Right ()
-  where
-    protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
+
+insertProtocolServer :: forall p. ProtocolTypeI p => DB.Connection -> SProtocolType p -> User -> UTCTime -> NewUserServer p -> IO (UserServer p)
+insertProtocolServer db p User {userId} ts srv@UserServer {server, preset, tested, enabled} = do
+  DB.execute
+    db
+    [sql|
+      INSERT INTO protocol_servers
+        (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
+      VALUES (?,?,?,?,?,?,?,?,?,?,?)
+    |]
+    (serverColumns p server :. (preset, tested, enabled, userId, ts, ts))
+  sId <- insertedRowId db
+  pure (srv :: NewUserServer p) {serverId = DBEntityId sId}
+
+updateProtocolServer :: ProtocolTypeI p => DB.Connection -> SProtocolType p -> UTCTime -> UserServer p -> IO ()
+updateProtocolServer db p ts UserServer {serverId, server, preset, tested, enabled} =
+  DB.execute
+    db
+    [sql|
+      UPDATE protocol_servers
+      SET protocol = ?, host = ?, port = ?, key_hash = ?, basic_auth = ?,
+          preset = ?, tested = ?, enabled = ?, updated_at = ?
+      WHERE smp_server_id = ?
+    |]
+    (serverColumns p server :. (preset, tested, enabled, ts, serverId))
+
+serverColumns :: ProtocolTypeI p => SProtocolType p -> ProtoServerWithAuth p -> (Text, NonEmpty TransportHost, String, C.KeyHash, Maybe Text)
+serverColumns p (ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_) =
+  let protocol = decodeLatin1 $ strEncode p
+      auth = safeDecodeUtf8 . unBasicAuth <$> auth_
+   in (protocol, host, port, keyHash, auth)
 
 getServerOperators :: DB.Connection -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
 getServerOperators db = do
-  now <- liftIO getCurrentTime
-  currentConditions <- getCurrentUsageConditions db
-  latestAcceptedConditions <- getLatestAcceptedConditions db
-  operators <-
-    liftIO $
-      map (toOperator now currentConditions latestAcceptedConditions)
-        <$> DB.query_
-          db
-          [sql|
-            SELECT
-              so.server_operator_id, so.server_operator_tag, so.trade_name, so.legal_name,
-              so.server_domains, so.enabled, so.role_storage, so.role_proxy,
-              AcceptedConditions.conditions_commit, AcceptedConditions.accepted_at
-            FROM server_operators so
-            LEFT JOIN (
-              SELECT server_operator_id, conditions_commit, accepted_at, MAX(operator_usage_conditions_id)
-              FROM operator_usage_conditions
-              GROUP BY server_operator_id
-            ) AcceptedConditions ON AcceptedConditions.server_operator_id = so.server_operator_id
-          |]
-  pure (operators, usageConditionsAction operators currentConditions now)
-  where
-    toOperator ::
-      UTCTime ->
-      UsageConditions ->
-      Maybe UsageConditions ->
-      ( (OperatorId, Maybe OperatorTag, Text, Maybe Text, Text, Bool, Bool, Bool)
-          :. (Maybe Text, Maybe UTCTime)
-      ) ->
-      ServerOperator
-    toOperator
-      now
-      UsageConditions {conditionsCommit = currentCommit, createdAt, notifiedAt}
-      latestAcceptedConditions_
-      ( (operatorId, operatorTag, tradeName, legalName, domains, enabled, storage, proxy)
-          :. (operatorCommit_, acceptedAt_)
-        ) =
-        let roles = ServerRoles {storage, proxy}
-            serverDomains = splitOn "," domains
-            conditionsAcceptance = case (latestAcceptedConditions_, operatorCommit_) of
-              -- no conditions were ever accepted for any operator(s)
-              -- (shouldn't happen as there should always be record for SimpleX Chat)
-              (Nothing, _) -> CARequired Nothing
-              -- no conditions were ever accepted for this operator
-              (_, Nothing) -> CARequired Nothing
-              (Just UsageConditions {conditionsCommit = latestAcceptedCommit}, Just operatorCommit)
-                | latestAcceptedCommit == currentCommit ->
-                    if operatorCommit == latestAcceptedCommit
-                      then -- current conditions were accepted for operator
-                        CAAccepted acceptedAt_
-                      else -- current conditions were NOT accepted for operator, but were accepted for other operator(s)
-                        CARequired Nothing
-                | otherwise ->
-                    if operatorCommit == latestAcceptedCommit
-                      then -- new conditions available, latest accepted conditions were accepted for operator
-                        CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
-                      else -- new conditions available, latest accepted conditions were NOT accepted for operator (were accepted for other operator(s))
-                        CARequired Nothing
-         in ServerOperator {operatorId, operatorTag, tradeName, legalName, serverDomains, conditionsAcceptance, enabled, roles}
+  currentConds <- 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)
 
-setServerOperators :: DB.Connection -> NonEmpty OperatorEnabled -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
-setServerOperators db operatorsEnabled = do
-  liftIO $ forM_ operatorsEnabled $ \OperatorEnabled {operatorId, enabled, roles = ServerRoles {storage, proxy}} ->
-    DB.execute
-      db
-      "UPDATE server_operators SET enabled = ?, role_storage = ?, role_proxy = ? WHERE server_operator_id = ?"
-      (enabled, storage, proxy, operatorId)
-  getServerOperators db
+getUserServers :: DB.Connection -> User -> ExceptT StoreError IO ([ServerOperator], [UserServer 'PSMP],  [UserServer 'PXFTP])
+getUserServers db user =
+  (,,)
+    <$> (fst <$> getServerOperators db)
+    <*> liftIO (getProtocolServers db SPSMP user)
+    <*> liftIO (getProtocolServers db SPXFTP user)
+
+setServerOperators :: DB.Connection -> NonEmpty ServerOperator -> IO ()
+setServerOperators db ops = do
+  currentTs <- getCurrentTime
+  mapM_ (updateServerOperator db currentTs) ops
+
+updateServerOperator :: DB.Connection -> UTCTime -> ServerOperator -> IO ()
+updateServerOperator db currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} =
+  DB.execute
+    db
+    [sql|
+      UPDATE server_operators
+      SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ?
+      WHERE server_operator_id = ?
+    |]
+    (enabled, storage, proxy, operatorId, currentTs)
+
+getUpdateServerOperators :: DB.Connection -> NonEmpty PresetOperator -> Bool -> IO [ServerOperator]
+getUpdateServerOperators db presetOps newUser = do
+  conds <- map toUsageConditions <$> DB.query_ db usageCondsQuery
+  now <- getCurrentTime
+  let (acceptForSimplex_, currentConds, condsToAdd) = usageConditionsToAdd newUser now conds
+  mapM_ insertConditions condsToAdd
+  latestAcceptedConds_ <- getLatestAcceptedConditions db
+  ops <- updatedServerOperators presetOps <$> getServerOperators_ db
+  forM ops $ \(ASO _ op) ->
+    case operatorId op of
+      DBNewEntity -> do
+        op' <- insertOperator op
+        case (operatorTag op', acceptForSimplex_) of
+          (Just OTSimplex, Just cond) -> autoAcceptConditions op' cond
+          _ -> pure op'
+      DBEntityId _ -> do
+        updateOperator op
+        getOperatorConditions_ db op currentConds latestAcceptedConds_ now >>= \case
+          CARequired Nothing | operatorTag op == Just OTSimplex -> autoAcceptConditions op currentConds
+          CARequired (Just ts) | ts < now -> autoAcceptConditions op currentConds
+          ca -> pure op {conditionsAcceptance = ca}
+  where
+    insertConditions UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt} =
+      DB.execute
+        db
+        [sql|
+          INSERT INTO usage_conditions
+            (usage_conditions_id, conditions_commit, notified_at, created_at)
+          VALUES (?,?,?,?)
+        |]
+        (conditionsId, conditionsCommit, notifiedAt, createdAt)
+    updateOperator :: ServerOperator -> IO ()
+    updateOperator ServerOperator {operatorId, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} =
+      DB.execute
+        db
+        [sql|
+          UPDATE server_operators
+          SET trade_name = ?, legal_name = ?, server_domains = ?, enabled = ?, role_storage = ?, role_proxy = ?
+          WHERE server_operator_id = ?
+        |]
+        (tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy, operatorId)
+    insertOperator :: NewServerOperator -> IO ServerOperator
+    insertOperator op@ServerOperator {operatorTag, tradeName, legalName, serverDomains, enabled, roles = ServerRoles {storage, proxy}} = do
+      DB.execute
+        db
+        [sql|
+          INSERT INTO server_operators
+            (server_operator_tag, trade_name, legal_name, server_domains, enabled, role_storage, role_proxy)
+          VALUES (?,?,?,?,?,?,?)
+        |]
+        (operatorTag, tradeName, legalName, T.intercalate "," serverDomains, enabled, storage, proxy)
+      opId <- insertedRowId db
+      pure op {operatorId = DBEntityId opId}
+    autoAcceptConditions op UsageConditions {conditionsCommit} =
+      acceptConditions_ db op conditionsCommit Nothing
+        $> op {conditionsAcceptance = CAAccepted Nothing}
+
+serverOperatorQuery :: Query
+serverOperatorQuery =
+  [sql|
+    SELECT server_operator_id, server_operator_tag, trade_name, legal_name,
+      server_domains, enabled, role_storage, 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) =
+  ServerOperator
+    { operatorId,
+      operatorTag,
+      tradeName,
+      legalName,
+      serverDomains = T.splitOn "," domains,
+      conditionsAcceptance = CARequired Nothing,
+      enabled,
+      roles = 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
+  case latestAcceptedConds_ of
+    Nothing -> pure $ CARequired Nothing -- no conditions accepted by any operator
+    Just UsageConditions {conditionsCommit = latestAcceptedCommit} -> do
+      operatorAcceptedConds_ <-
+        maybeFirstRow id $
+          DB.query
+            db
+            [sql|
+              SELECT conditions_commit, accepted_at
+              FROM operator_usage_conditions
+              WHERE server_operator_id = ?
+              ORDER BY operator_usage_conditions_id DESC
+              LIMIT 1
+            |]
+            (Only operatorId)
+      pure $ case operatorAcceptedConds_ of
+        Just (operatorCommit, acceptedAt_)
+          | operatorCommit /= latestAcceptedCommit -> CARequired Nothing -- TODO should we consider this operator disabled?
+          | currentCommit /= latestAcceptedCommit -> CARequired $ conditionsRequiredOrDeadline createdAt (fromMaybe now notifiedAt)
+          | otherwise -> CAAccepted acceptedAt_
+        _ -> CARequired Nothing -- no conditions were accepted for this operator
 
 getCurrentUsageConditions :: DB.Connection -> ExceptT StoreError IO UsageConditions
 getCurrentUsageConditions db =
   ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
-    DB.query_
-      db
-      [sql|
-        SELECT usage_conditions_id, conditions_commit, notified_at, created_at
-        FROM usage_conditions
-        ORDER BY usage_conditions_id DESC LIMIT 1
-      |]
+    DB.query_ db (usageCondsQuery <> " DESC LIMIT 1")
+
+usageCondsQuery :: Query
+usageCondsQuery =
+  [sql|
+    SELECT usage_conditions_id, conditions_commit, notified_at, created_at
+    FROM usage_conditions
+    ORDER BY usage_conditions_id
+  |]
 
 toUsageConditions :: (Int64, Text, Maybe UTCTime, UTCTime) -> UsageConditions
 toUsageConditions (conditionsId, conditionsCommit, notifiedAt, createdAt) =
   UsageConditions {conditionsId, conditionsCommit, notifiedAt, createdAt}
 
-getLatestAcceptedConditions :: DB.Connection -> ExceptT StoreError IO (Maybe UsageConditions)
-getLatestAcceptedConditions db = do
-  (latestAcceptedCommit_ :: Maybe Text) <-
-    liftIO $
-      maybeFirstRow fromOnly $
-        DB.query_
-          db
-          [sql|
+getLatestAcceptedConditions :: DB.Connection -> IO (Maybe UsageConditions)
+getLatestAcceptedConditions db =
+  maybeFirstRow toUsageConditions $
+    DB.query_
+      db
+      [sql|
+        SELECT usage_conditions_id, conditions_commit, notified_at, created_at
+        FROM usage_conditions
+        WHERE conditions_commit = (
           SELECT conditions_commit
           FROM operator_usage_conditions
           ORDER BY accepted_at DESC
           LIMIT 1
-        |]
-  forM latestAcceptedCommit_ $ \latestAcceptedCommit ->
-    ExceptT . firstRow toUsageConditions SEUsageConditionsNotFound $
-      DB.query
-        db
-        [sql|
-          SELECT usage_conditions_id, conditions_commit, notified_at, created_at
-          FROM usage_conditions
-          WHERE conditions_commit = ?
-        |]
-        (Only latestAcceptedCommit)
+        )
+      |]
 
 setConditionsNotified :: DB.Connection -> Int64 -> UTCTime -> IO ()
-setConditionsNotified db conditionsId notifiedAt =
-  DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, conditionsId)
+setConditionsNotified db condId notifiedAt =
+  DB.execute db "UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ?" (notifiedAt, condId)
 
-acceptConditions :: DB.Connection -> Int64 -> NonEmpty ServerOperator -> UTCTime -> ExceptT StoreError IO ([ServerOperator], Maybe UsageConditionsAction)
-acceptConditions db conditionsId operators acceptedAt = do
-  UsageConditions {conditionsCommit} <- getUsageConditionsById_ db conditionsId
-  liftIO $ forM_ operators $ \ServerOperator {operatorId, operatorTag} ->
-    DB.execute
-      db
-      [sql|
-        INSERT INTO operator_usage_conditions
-          (server_operator_id, server_operator_tag, conditions_commit, accepted_at)
-        VALUES (?,?,?,?)
-      |]
-      (operatorId, operatorTag, conditionsCommit, acceptedAt)
-  getServerOperators db
+acceptConditions :: DB.Connection -> Int64 -> NonEmpty Int64 -> UTCTime -> ExceptT StoreError IO ()
+acceptConditions db condId opIds acceptedAt = do
+  UsageConditions {conditionsCommit} <- getUsageConditionsById_ db condId
+  operators <- mapM getServerOperator_ opIds
+  let ts = Just acceptedAt
+  liftIO $ forM_ operators $ \op -> acceptConditions_ db op conditionsCommit ts
+  where
+    getServerOperator_ opId =
+      ExceptT $ firstRow toServerOperator (SEOperatorNotFound opId) $
+        DB.query db (serverOperatorQuery <> " WHERE operator_id = ?") (Only opId)
+
+acceptConditions_ :: DB.Connection -> ServerOperator -> Text -> Maybe UTCTime -> IO ()
+acceptConditions_ db ServerOperator {operatorId, operatorTag} conditionsCommit acceptedAt =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO operator_usage_conditions
+        (server_operator_id, server_operator_tag, conditions_commit, accepted_at)
+      VALUES (?,?,?,?)
+    |]
+    (operatorId, operatorTag, conditionsCommit, acceptedAt)
 
 getUsageConditionsById_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UsageConditions
 getUsageConditionsById_ db conditionsId =
@@ -708,83 +821,22 @@ getUsageConditionsById_ db conditionsId =
       |]
       (Only conditionsId)
 
-setUserServers :: DB.Connection -> User -> NonEmpty UserServers -> ExceptT StoreError IO ()
-setUserServers db User {userId} userServers = do
-  currentTs <- liftIO getCurrentTime
-  forM_ userServers $ do
-    \UserServers {operator, smpServers, xftpServers} -> do
-      forM_ operator $ \op -> liftIO $ updateOperator currentTs op
-      overwriteServers currentTs operator smpServers
-      overwriteServers currentTs operator xftpServers
+setUserServers :: DB.Connection -> User -> NonEmpty UpdatedUserOperatorServers -> ExceptT StoreError IO ()
+setUserServers db user@User {userId} userServers = checkConstraint SEUniqueID $ liftIO $ do
+  ts <- getCurrentTime
+  forM_ userServers $ \UpdatedUserOperatorServers {operator, smpServers, xftpServers} -> do
+    mapM_ (updateServerOperator db ts) operator
+    mapM_ (upsertOrDelete SPSMP ts) smpServers
+    mapM_ (upsertOrDelete SPXFTP ts) xftpServers
   where
-    updateOperator :: UTCTime -> ServerOperator -> IO ()
-    updateOperator currentTs ServerOperator {operatorId, enabled, roles = ServerRoles {storage, proxy}} =
-      DB.execute
-        db
-        [sql|
-          UPDATE server_operators
-          SET enabled = ?, role_storage = ?, role_proxy = ?, updated_at = ?
-          WHERE server_operator_id = ?
-        |]
-        (enabled, storage, proxy, operatorId, currentTs)
-    overwriteServers :: forall p. ProtocolTypeI p => UTCTime -> Maybe ServerOperator -> [ServerCfg p] -> ExceptT StoreError IO ()
-    overwriteServers currentTs serverOperator servers =
-      checkConstraint SEUniqueID . ExceptT $ do
-        case serverOperator of
-          Nothing ->
-            DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id IS NULL AND protocol = ?" (userId, protocol)
-          Just ServerOperator {operatorId} ->
-            DB.execute db "DELETE FROM protocol_servers WHERE user_id = ? AND server_operator_id = ? AND protocol = ?" (userId, operatorId, protocol)
-        forM_ servers $ \ServerCfg {server, operator, preset, tested, enabled} -> do
-          let ProtoServerWithAuth ProtocolServer {host, port, keyHash} auth_ = server
-          DB.execute
-            db
-            [sql|
-              INSERT INTO protocol_servers
-                (protocol, host, port, key_hash, basic_auth, operator, preset, tested, enabled, user_id, created_at, updated_at)
-              VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
-            |]
-            ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, operator) :. (preset, tested, enabled, userId, currentTs, currentTs))
-        pure $ Right ()
-      where
-        protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
-
--- updateServerOperators_ :: DB.Connection -> [ServerOperator] -> IO [ServerOperator]
--- updateServerOperators_ db operators = do
---   DB.execute_ db "DELETE FROM server_operators WHERE preset = 0"
---   let (existing, new) = partition (isJust . operatorId) operators
---   existing' <- mapM (\op -> upsertExisting op $> op) existing
---   new' <- mapM insertNew new
---   pure $ existing' <> new'
---   where
---     upsertExisting ServerOperator {operatorId, name, preset, enabled, roles = ServerRoles {storage, proxy}}
---       | preset =
---           DB.execute
---             db
---             [sql|
---               UPDATE server_operators
---               SET enabled = ?, role_storage = ?, role_proxy = ?
---               WHERE server_operator_id = ?
---             |]
---             (enabled, storage, proxy, operatorId)
---       | otherwise =
---           DB.execute
---             db
---             [sql|
---               INSERT INTO server_operators (server_operator_id, name, preset, enabled, role_storage, role_proxy)
---               VALUES (?,?,?,?,?,?)
---             |]
---             (operatorId, name, preset, enabled, storage, proxy)
---     insertNew op@ServerOperator {name, preset, enabled, roles = ServerRoles {storage, proxy}} = do
---       DB.execute
---         db
---         [sql|
---           INSERT INTO server_operators (name, preset, enabled, role_storage, role_proxy)
---           VALUES (?,?,?,?,?)
---         |]
---         (name, preset, enabled, storage, proxy)
---       opId <- insertedRowId db
---       pure op {operatorId = Just opId}
+    upsertOrDelete :: ProtocolTypeI p => SProtocolType p -> UTCTime -> AUserServer p -> IO ()
+    upsertOrDelete p ts (AUS _ s@UserServer {serverId, deleted}) = case serverId of
+      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
 
 createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
 createCall db user@User {userId} Call {contactId, callId, callUUID, chatItemId, callState} callTs = do

src/Simplex/Chat/Store/Shared.hs

@@ -127,6 +127,7 @@ data StoreError
   | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
   | SERemoteCtrlDuplicateCA
   | SEProhibitedDeleteUser {userId :: UserId, contactId :: ContactId}
+  | SEOperatorNotFound {serverOperatorId :: Int64}
   | SEUsageConditionsNotFound
   deriving (Show, Exception)
 

src/Simplex/Chat/Terminal.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Chat.Terminal where
@@ -13,15 +14,15 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Database.SQLite.Simple (SQLError (..))
 import qualified Database.SQLite.Simple as DB
-import Simplex.Chat (defaultChatConfig, operatorSimpleXChat)
+import Simplex.Chat (_defaultNtfServers, defaultChatConfig, operatorSimpleXChat)
 import Simplex.Chat.Controller
 import Simplex.Chat.Core
 import Simplex.Chat.Help (chatWelcome)
+import Simplex.Chat.Operators
 import Simplex.Chat.Options
 import Simplex.Chat.Terminal.Input
 import Simplex.Chat.Terminal.Output
 import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
-import Simplex.Messaging.Agent.Env.SQLite (allRoles, presetServerCfg)
 import Simplex.Messaging.Client (NetworkConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig)
 import Simplex.Messaging.Util (raceAny_)
 import System.IO (hFlush, hSetEcho, stdin, stdout)
@@ -29,20 +30,24 @@ import System.IO (hFlush, hSetEcho, stdin, stdout)
 terminalChatConfig :: ChatConfig
 terminalChatConfig =
   defaultChatConfig
-    { defaultServers =
-        DefaultAgentServers
-          { smp =
-              L.fromList $
-                map
-                  (presetServerCfg True allRoles operatorSimpleXChat)
-                  [ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
-                    "smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
-                    "smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
-                  ],
-            useSMP = 3,
-            ntf = ["ntf://FB-Uop7RTaZZEG0ZLD2CIaTjsPh-Fw0zFAnb7QyA8Ks=@ntf2.simplex.im,ntg7jdjy2i3qbib3sykiho3enekwiaqg3icctliqhtqcg6jmoh6cxiad.onion"],
-            xftp = L.map (presetServerCfg True allRoles operatorSimpleXChat) defaultXFTPServers,
-            useXFTP = L.length defaultXFTPServers,
+    { presetServers =
+        PresetServers
+          { operators =
+              [ PresetOperator
+                  { operator = Just operatorSimpleXChat,
+                    smp =
+                      map
+                        (presetServer True)
+                        [ "smp://u2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU=@smp4.simplex.im,o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion",
+                          "smp://hpq7_4gGJiilmz5Rf-CswuU5kZGkm_zOIooSw6yALRg=@smp5.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion",
+                          "smp://PQUV2eL0t7OStZOoAsPEV2QYWt4-xilbakvGUGOItUo=@smp6.simplex.im,bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"
+                        ],
+                    useSMP = 3,
+                    xftp = map (presetServer True) $ L.toList defaultXFTPServers,
+                    useXFTP = 3
+                  }
+              ],
+            ntf = _defaultNtfServers,
             netCfg =
               defaultNetworkConfig
                 { smpProxyMode = SPMUnknown,

src/Simplex/Chat/Terminal/Main.hs

@@ -10,7 +10,7 @@ import Data.Maybe (fromMaybe)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.LocalTime (getCurrentTimeZone)
 import Network.Socket
-import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), DefaultAgentServers (DefaultAgentServers, netCfg), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
+import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
 import Simplex.Chat.Core
 import Simplex.Chat.Options
 import Simplex.Chat.Terminal
@@ -56,7 +56,7 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer
           putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
 
 welcome :: ChatConfig -> ChatOpts -> IO ()
-welcome ChatConfig {defaultServers = DefaultAgentServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
+welcome ChatConfig {presetServers = PresetServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
   mapM_
     putStrLn
     [ versionString versionNumber,

src/Simplex/Chat/View.hs

@@ -19,12 +19,13 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (isSpace, toUpper)
 import Data.Function (on)
 import Data.Int (Int64)
-import Data.List (foldl', groupBy, intercalate, intersperse, partition, sortOn)
+import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
+import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1)
@@ -54,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 (..), ServerCfg (..))
+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 (..))
@@ -96,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
@@ -1214,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)"]
+viewUserServers :: UserOperatorServers -> [StyledString]
+viewUserServers (UserOperatorServers _ [] []) = []
+viewUserServers UserOperatorServers {operator, smpServers, xftpServers} =
+  [plain $ maybe "Your servers" shortViewOperator operator]
+    <> viewServers SPSMP smpServers
+    <> viewServers SPXFTP xftpServers
   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
+    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
@@ -1255,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"]
@@ -1331,11 +1382,11 @@ 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 Int64) 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) <> ")"
+-- 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
@@ -1934,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