core: update servers API to include XFTP servers, ios: generalize UI to manage servers (#2140)

* core: update servers API to include XFTP servers, ios: generalize UI to manage servers

* add test

* update migrations to pass tests

* fix readme

* update simplexmq

src/Simplex/Chat/Controller.hs

@@ -4,9 +4,11 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -45,7 +47,7 @@ import Simplex.Chat.Protocol
 import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink)
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent (AgentClient)
-import Simplex.Messaging.Agent.Client (AgentLocks, SMPTestFailure)
+import Simplex.Messaging.Agent.Client (AgentLocks, ProtocolTestFailure)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Protocol
@@ -54,7 +56,7 @@ import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
-import Simplex.Messaging.Protocol (AProtocolType, CorrId, MsgFlags, NtfServer, ProtocolType (..), QueueId, XFTPServerWithAuth)
+import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType, CorrId, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI, QueueId, SProtocolType, UserProtocol, XFTPServerWithAuth)
 import Simplex.Messaging.TMap (TMap)
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost)
@@ -258,16 +260,12 @@ data ChatCommand
   | APIGroupLinkMemberRole GroupId GroupMemberRole
   | APIDeleteGroupLink GroupId
   | APIGetGroupLink GroupId
-  | APIGetUserSMPServers UserId
-  | GetUserSMPServers
-  | APISetUserSMPServers UserId SMPServersConfig
-  | SetUserSMPServers SMPServersConfig
-  | APIGetUserServers UserId
-  | GetUserServers
-  | APISetUserServers UserId ServersConfig
-  | SetUserServers ServersConfig
-  | APITestSMPServer UserId SMPServerWithAuth
-  | TestSMPServer SMPServerWithAuth
+  | APIGetUserProtoServers UserId AProtocolType
+  | GetUserProtoServers AProtocolType
+  | APISetUserProtoServers UserId AProtoServersConfig
+  | SetUserProtoServers AProtoServersConfig
+  | APITestProtoServer UserId AProtoServerWithAuth
+  | TestProtoServer AProtoServerWithAuth
   | APISetChatItemTTL UserId (Maybe Int64)
   | SetChatItemTTL (Maybe Int64)
   | APIGetChatItemTTL UserId
@@ -386,8 +384,8 @@ data ChatResponse
   | CRChatItems {user :: User, chatItems :: [AChatItem]}
   | CRChatItemId User (Maybe ChatItemId)
   | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
-  | CRUserSMPServers {user :: User, smpServers :: NonEmpty (ServerCfg 'PSMP), presetSMPServers :: NonEmpty SMPServerWithAuth}
-  | CRSmpTestResult {user :: User, smpTestFailure :: Maybe SMPTestFailure}
+  | CRUserProtoServers {user :: User, servers :: AUserProtoServers}
+  | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
   | CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
   | CRNetworkConfig {networkConfig :: NetworkConfig}
   | CRContactInfo {user :: User, contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile}
@@ -566,11 +564,31 @@ instance ToJSON AgentQueueId where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
-data SMPServersConfig = SMPServersConfig {smpServers :: [ServerCfg 'PSMP]}
+data ProtoServersConfig p = ProtoServersConfig {servers :: [ServerCfg p]}
   deriving (Show, Generic, FromJSON)
 
-data ServersConfig = ServersConfig {servers :: [AServerCfg]}
-  deriving (Show, Generic, FromJSON)
+data AProtoServersConfig = forall p. ProtocolTypeI p => APSC (SProtocolType p) (ProtoServersConfig p)
+
+deriving instance Show AProtoServersConfig
+
+data UserProtoServers p = UserProtoServers
+  { serverProtocol :: SProtocolType p,
+    protoServers :: NonEmpty (ServerCfg p),
+    presetServers :: NonEmpty (ProtoServerWithAuth p)
+  }
+  deriving (Show, Generic)
+
+instance ProtocolTypeI p => ToJSON (UserProtoServers p) where
+  toJSON = J.genericToJSON J.defaultOptions
+  toEncoding = J.genericToEncoding J.defaultOptions
+
+data AUserProtoServers = forall p. (ProtocolTypeI p, UserProtocol p) => AUPS (UserProtoServers p)
+
+instance ToJSON AUserProtoServers where
+  toJSON (AUPS s) = J.genericToJSON J.defaultOptions s
+  toEncoding (AUPS s) = J.genericToEncoding J.defaultOptions s
+
+deriving instance Show AUserProtoServers
 
 data ArchiveConfig = ArchiveConfig {archivePath :: FilePath, disableCompression :: Maybe Bool, parentTempDirectory :: Maybe FilePath}
   deriving (Show, Generic, FromJSON)
@@ -679,7 +697,8 @@ data ParsedServerAddress = ParsedServerAddress
 instance ToJSON ParsedServerAddress where toEncoding = J.genericToEncoding J.defaultOptions
 
 data ServerAddress = ServerAddress
-  { hostnames :: NonEmpty String,
+  { protocol :: AProtocolType,
+    hostnames :: NonEmpty String,
     port :: String,
     keyHash :: String,
     basicAuth :: String
@@ -794,6 +813,7 @@ data ChatErrorType
   | CEAgentVersion
   | CEAgentNoSubResult {agentConnId :: AgentConnId}
   | CECommandError {message :: String}
+  | CEServerProtocol {serverProtocol :: AProtocolType}
   | CEAgentCommandError {message :: String}
   | CEInvalidFileDescription {message :: String}
   | CEInternalError {message :: String}

src/Simplex/Chat/Migrations/M20230118_recreate_smp_servers.hs

@@ -35,5 +35,5 @@ SELECT
 DROP TABLE smp_servers;
 ALTER TABLE new_smp_servers RENAME TO smp_servers;
 
-CREATE INDEX idx_smp_servers_user_id ON smp_servers(user_id);
+CREATE INDEX idx_smp_servers_user_id ON "smp_servers"(user_id);
 |]

src/Simplex/Chat/Migrations/M20230402_protocol_servers.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20230402_protocol_servers where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230402_protocol_servers :: Query
+m20230402_protocol_servers =
+  [sql|
+ALTER TABLE smp_servers RENAME TO protocol_servers;
+ALTER TABLE protocol_servers ADD COLUMN protocol TEXT NOT NULL DEFAULT 'smp';
+|]
+
+down_m20230402_protocol_servers :: Query
+down_m20230402_protocol_servers =
+  [sql|
+ALTER TABLE protocol_servers DROP COLUMN protocol;
+ALTER TABLE protocol_servers RENAME TO smp_servers;
+|]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -547,7 +547,7 @@ CREATE INDEX idx_snd_file_chunks_file_id_connection_id ON snd_file_chunks(
 CREATE INDEX idx_snd_files_group_member_id ON snd_files(group_member_id);
 CREATE INDEX idx_snd_files_connection_id ON snd_files(connection_id);
 CREATE INDEX idx_snd_files_file_id ON snd_files(file_id);
-CREATE TABLE IF NOT EXISTS "smp_servers"(
+CREATE TABLE IF NOT EXISTS "protocol_servers"(
   smp_server_id INTEGER PRIMARY KEY,
   host TEXT NOT NULL,
   port TEXT NOT NULL,
@@ -559,9 +559,10 @@ CREATE TABLE IF NOT EXISTS "smp_servers"(
   user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now')),
+  protocol TEXT NOT NULL DEFAULT 'smp',
   UNIQUE(user_id, host, port)
 );
-CREATE INDEX idx_smp_servers_user_id ON smp_servers(user_id);
+CREATE INDEX idx_smp_servers_user_id ON "protocol_servers"(user_id);
 CREATE INDEX idx_chat_items_item_deleted_by_group_member_id ON chat_items(
   item_deleted_by_group_member_id
 );

src/Simplex/Chat/Mobile.hs

@@ -44,7 +44,7 @@ import Simplex.Messaging.Client (defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
-import Simplex.Messaging.Protocol (BasicAuth (..), CorrId (..), ProtoServerWithAuth (..), ProtocolServer (..), SMPServerWithAuth)
+import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), BasicAuth (..), CorrId (..), ProtoServerWithAuth (..), ProtocolServer (..))
 import Simplex.Messaging.Util (catchAll, liftEitherWith, safeDecodeUtf8)
 import System.Timeout (timeout)
 
@@ -194,11 +194,11 @@ chatParseMarkdown = LB.unpack . J.encode . ParsedMarkdown . parseMaybeMarkdownLi
 chatParseServer :: String -> JSONString
 chatParseServer = LB.unpack . J.encode . toServerAddress . strDecode . B.pack
   where
-    toServerAddress :: Either String SMPServerWithAuth -> ParsedServerAddress
+    toServerAddress :: Either String AProtoServerWithAuth -> ParsedServerAddress
     toServerAddress = \case
-      Right (ProtoServerWithAuth ProtocolServer {host, port, keyHash = C.KeyHash kh} auth) ->
+      Right (AProtoServerWithAuth protocol (ProtoServerWithAuth ProtocolServer {host, port, keyHash = C.KeyHash kh} auth)) ->
         let basicAuth = maybe "" (\(BasicAuth a) -> enc a) auth
-         in ParsedServerAddress (Just ServerAddress {hostnames = L.map enc host, port, keyHash = enc kh, basicAuth}) ""
+         in ParsedServerAddress (Just ServerAddress {protocol = AProtocolType protocol, hostnames = L.map enc host, port, keyHash = enc kh, basicAuth}) ""
       Left e -> ParsedServerAddress Nothing e
     enc :: StrEncoding a => a -> String
     enc = B.unpack . strEncode

src/Simplex/Chat/Options.hs

@@ -11,7 +11,7 @@ module Simplex.Chat.Options
     chatOptsP,
     coreChatOptsP,
     getChatOpts,
-    smpServersP,
+    protocolServersP,
     fullNetworkConfig,
   )
 where
@@ -25,7 +25,7 @@ import Simplex.Chat.Controller (ChatLogLevel (..), updateStr, versionNumber, ver
 import Simplex.Messaging.Client (NetworkConfig (..), defaultNetworkConfig)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Protocol (SMPServerWithAuth, XFTPServerWithAuth)
+import Simplex.Messaging.Protocol (ProtocolTypeI, ProtoServerWithAuth, SMPServerWithAuth, XFTPServerWithAuth)
 import Simplex.Messaging.Transport.Client (SocksProxy, defaultSocksProxy)
 import System.FilePath (combine)
 
@@ -82,7 +82,7 @@ coreChatOptsP appDir defaultDbFileName = do
       )
   smpServers <-
     option
-      parseSMPServers
+      parseProtocolServers
       ( long "server"
           <> short 's'
           <> metavar "SERVER"
@@ -91,7 +91,7 @@ coreChatOptsP appDir defaultDbFileName = do
       )
   xftpServers <-
     option
-      parseXFTPServers
+      parseProtocolServers
       ( long "xftp-server"
           <> metavar "SERVER"
           <> help "Semicolon-separated list of XFTP server(s) to use (each server can have more than one hostname)"
@@ -243,11 +243,8 @@ fullNetworkConfig socksProxy tcpTimeout logTLSErrors =
   let tcpConnectTimeout = (tcpTimeout * 3) `div` 2
    in defaultNetworkConfig {socksProxy, tcpTimeout, tcpConnectTimeout, logTLSErrors}
 
-parseSMPServers :: ReadM [SMPServerWithAuth]
-parseSMPServers = eitherReader $ parseAll smpServersP . B.pack
-
-parseXFTPServers :: ReadM [XFTPServerWithAuth]
-parseXFTPServers = eitherReader $ parseAll xftpServersP . B.pack
+parseProtocolServers :: ProtocolTypeI p => ReadM [ProtoServerWithAuth p]
+parseProtocolServers = eitherReader $ parseAll protocolServersP . B.pack
 
 parseSocksProxy :: ReadM (Maybe SocksProxy)
 parseSocksProxy = eitherReader $ parseAll strP . B.pack
@@ -258,11 +255,8 @@ parseServerPort = eitherReader $ parseAll serverPortP . B.pack
 serverPortP :: A.Parser (Maybe String)
 serverPortP = Just . B.unpack <$> A.takeWhile A.isDigit
 
-smpServersP :: A.Parser [SMPServerWithAuth]
-smpServersP = strP `A.sepBy1` A.char ';'
-
-xftpServersP :: A.Parser [XFTPServerWithAuth]
-xftpServersP = strP `A.sepBy1` A.char ';'
+protocolServersP :: ProtocolTypeI p => A.Parser [ProtoServerWithAuth p]
+protocolServersP = strP `A.sepBy1` A.char ';'
 
 parseLogLevel :: ReadM ChatLogLevel
 parseLogLevel = eitherReader $ \case

src/Simplex/Chat/Store.hs

@@ -246,8 +246,6 @@ module Simplex.Chat.Store
     updateGroupChatItemsRead,
     getGroupUnreadTimedItems,
     setGroupChatItemDeleteAt,
-    getSMPServers,
-    overwriteSMPServers,
     getProtocolServers,
     overwriteProtocolServers,
     createCall,
@@ -297,7 +295,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
 import Data.Ord (Down (..))
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (addUTCTime)
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Data.Time.LocalTime (TimeZone, getCurrentTimeZone)
@@ -365,6 +363,7 @@ import Simplex.Chat.Migrations.M20230317_hidden_profiles
 import Simplex.Chat.Migrations.M20230318_file_description
 import Simplex.Chat.Migrations.M20230321_agent_file_deleted
 import Simplex.Chat.Migrations.M20230328_files_protocol
+import Simplex.Chat.Migrations.M20230402_protocol_servers
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
 import Simplex.Chat.Util (week)
@@ -372,8 +371,9 @@ import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, Invitation
 import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation, MigrationError, SQLiteStore (..), createSQLiteStore, firstRow, firstRow', maybeFirstRow, withTransaction)
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
-import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), pattern SMPServer)
+import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..))
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
 import UnliftIO.STM
@@ -435,7 +435,8 @@ schemaMigrations =
     ("20230317_hidden_profiles", m20230317_hidden_profiles, Just down_m20230317_hidden_profiles),
     ("20230318_file_description", m20230318_file_description, Just down_m20230318_file_description),
     ("20230321_agent_file_deleted", m20230321_agent_file_deleted, Just down_m20230321_agent_file_deleted),
-    ("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol)
+    ("20230328_files_protocol", m20230328_files_protocol, Just down_m20230328_files_protocol),
+    ("20230402_protocol_servers", m20230402_protocol_servers, Just down_m20230402_protocol_servers)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -4849,49 +4850,42 @@ toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just
   either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_)
 toGroupChatItemList _ _ _ _ = []
 
-getSMPServers :: DB.Connection -> User -> IO [ServerCfg 'PSMP]
-getSMPServers db User {userId} =
+getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
+getProtocolServers db User {userId} =
   map toServerCfg
     <$> DB.query
       db
       [sql|
         SELECT host, port, key_hash, basic_auth, preset, tested, enabled
-        FROM smp_servers
-        WHERE user_id = ?;
+        FROM protocol_servers
+        WHERE user_id = ? AND protocol = ?;
       |]
-      (Only userId)
+      (userId, decodeLatin1 $ strEncode protocol)
   where
-    toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg 'PSMP
+    protocol = protocolTypeI @p
+    toServerCfg :: (NonEmpty TransportHost, String, C.KeyHash, Maybe Text, Bool, Maybe Bool, Bool) -> ServerCfg p
     toServerCfg (host, port, keyHash, auth_, preset, tested, enabled) =
-      let server = ProtoServerWithAuth (SMPServer host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
+      let server = ProtoServerWithAuth (ProtocolServer protocol host port keyHash) (BasicAuth . encodeUtf8 <$> auth_)
        in ServerCfg {server, preset, tested, enabled}
 
-overwriteSMPServers :: DB.Connection -> User -> [ServerCfg 'PSMP] -> ExceptT StoreError IO ()
-overwriteSMPServers db User {userId} servers =
+overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
+overwriteProtocolServers db User {userId} servers =
   checkConstraint SEUniqueID . ExceptT $ do
     currentTs <- getCurrentTime
-    DB.execute db "DELETE FROM smp_servers WHERE user_id = ?" (Only userId)
+    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
         [sql|
-          INSERT INTO smp_servers
-            (host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
-          VALUES (?,?,?,?,?,?,?,?,?,?)
+          INSERT INTO protocol_servers
+            (protocol, host, port, key_hash, basic_auth, preset, tested, enabled, user_id, created_at, updated_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?)
         |]
-        (host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_, preset, tested, enabled, userId, currentTs, currentTs)
+        ((protocol, host, port, keyHash, safeDecodeUtf8 . unBasicAuth <$> auth_) :. (preset, tested, enabled, userId, currentTs, currentTs))
     pure $ Right ()
-
-getProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> IO [ServerCfg p]
-getProtocolServers db user = case protocolTypeI @p of
-  SPSMP -> getSMPServers db user
-  _ -> pure [] -- TODO read from the new table of all servers (alternatively, we could migrate data)
-
-overwriteProtocolServers :: forall p. ProtocolTypeI p => DB.Connection -> User -> [ServerCfg p] -> ExceptT StoreError IO ()
-overwriteProtocolServers db user servers = case protocolTypeI @p of
-  SPSMP -> overwriteSMPServers db user servers
-  _ -> pure () -- TODO write the new table of all servers
+  where
+    protocol = decodeLatin1 $ strEncode $ protocolTypeI @p
 
 createCall :: DB.Connection -> User -> Call -> UTCTime -> IO ()
 createCall db user@User {userId} Call {contactId, callId, chatItemId, callState} callTs = do

src/Simplex/Chat/Types.hs

@@ -52,7 +52,7 @@ import Simplex.FileTransfer.Description (FileDigest)
 import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
-import Simplex.Messaging.Protocol (AProtoServerWithAuth, ProtoServerWithAuth, ProtocolTypeI)
+import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
 import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
 
 class IsContact a where
@@ -2100,21 +2100,3 @@ instance ProtocolTypeI p => ToJSON (ServerCfg p) where
 
 instance ProtocolTypeI p => FromJSON (ServerCfg p) where
   parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
-
-data AServerCfg = AServerCfg
-  { server :: AProtoServerWithAuth,
-    preset :: Bool,
-    tested :: Maybe Bool,
-    enabled :: Bool
-  }
-
-deriving instance Show AServerCfg
-
-deriving instance Generic AServerCfg
-
-instance ToJSON AServerCfg where
-  toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
-  toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
-
-instance FromJSON AServerCfg where
-  parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}

src/Simplex/Chat/View.hs

@@ -18,10 +18,12 @@ import Data.Char (toUpper)
 import Data.Function (on)
 import Data.Int (Int64)
 import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
 import Data.Time.Clock (DiffTime, UTCTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Data.Time.LocalTime (ZonedTime (..), localDay, localTimeOfDay, timeOfDayToTime, utcToZonedTime)
@@ -38,14 +40,15 @@ import Simplex.Chat.Protocol
 import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
 import Simplex.Chat.Styled
 import Simplex.Chat.Types
-import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..))
+import qualified Simplex.FileTransfer.Protocol as XFTP
+import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
 import Simplex.Messaging.Agent.Protocol
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON)
-import Simplex.Messaging.Protocol (AProtocolType, ProtocolServer (..), ProtocolTypeI)
+import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtocolTypeI, SProtocolType (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Util (bshow, tshow)
@@ -68,8 +71,8 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
   CRChats chats -> viewChats ts chats
   CRApiChat u chat -> ttyUser u $ if testView then testViewChat chat else [plain . bshow $ J.encode chat]
   CRApiParsedMarkdown ft -> [plain . bshow $ J.encode ft]
-  CRUserSMPServers u smpServers _ -> ttyUser u $ viewSMPServers (L.toList smpServers) testView
-  CRSmpTestResult u testFailure -> ttyUser u $ viewSMPTestResult testFailure
+  CRUserProtoServers u userServers -> ttyUser u $ viewUserServers userServers testView
+  CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
   CRChatItemTTL u ttl -> ttyUser u $ viewChatItemTTL ttl
   CRNetworkConfig cfg -> viewNetworkConfig cfg
   CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
@@ -748,36 +751,46 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho
   ]
 
 -- TODO make more generic messages or split
-viewSMPServers :: ProtocolTypeI p => [ServerCfg p] -> Bool -> [StyledString]
-viewSMPServers servers testView =
+viewUserServers :: AUserProtoServers -> Bool -> [StyledString]
+viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers}) testView =
   if testView
     then [customServers]
     else
       [ customServers,
         "",
-        "use " <> highlight' "/smp test <srv>" <> " to test SMP server connection",
-        "use " <> highlight' "/smp set <srv1[,srv2,...]>" <> " to switch to custom SMP servers",
-        "use " <> highlight' "/smp default" <> " to remove custom SMP servers and use default",
-        "(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"
+        "use " <> highlight (srvCmd <> " test <srv>") <> " to test " <> pName <> " server connection",
+        "use " <> highlight (srvCmd <> " set <srv1[,srv2,...]>") <> " to switch to custom " <> pName <> " servers",
+        "use " <> highlight (srvCmd <> " default") <> " to remove custom " <> pName <> " servers and use default"
       ]
+        <> 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 servers
+      if null protoServers
         then "no custom SMP servers saved"
-        else viewServers servers
+        else viewServers protoServers
 
-viewSMPTestResult :: Maybe SMPTestFailure -> [StyledString]
-viewSMPTestResult = \case
-  Just SMPTestFailure {testStep, testError} ->
+protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString
+protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode
+
+viewServerTestResult :: AProtoServerWithAuth -> Maybe ProtocolTestFailure -> [StyledString]
+viewServerTestResult (AProtoServerWithAuth p _) = \case
+  Just ProtocolTestFailure {testStep, testError} ->
     result
-      <> ["Server requires authorization to create queues, check password" | testStep == TSCreateQueue && testError == SMP SMP.AUTH]
-      <> ["Possibly, certificate fingerprint in server address is incorrect" | testStep == TSConnect && brokerErr]
+      <> [pName <> " server requires authorization to create queues, check password" | testStep == TSCreateQueue && testError == SMP SMP.AUTH]
+      <> [pName <> " server requires authorization to upload files, check password" | testStep == TSCreateFile && testError == XFTP XFTP.AUTH]
+      <> ["Possibly, certificate fingerprint in " <> pName <> " server address is incorrect" | testStep == TSConnect && brokerErr]
     where
-      result = ["SMP server test failed at " <> plain (drop 2 $ show testStep) <> ", error: " <> plain (strEncode testError)]
+      result = [pName <> " server test failed at " <> plain (drop 2 $ show testStep) <> ", error: " <> plain (strEncode testError)]
       brokerErr = case testError of
         BROKER _ NETWORK -> True
         _ -> False
-  _ -> ["SMP server test passed"]
+  _ -> [pName <> " server test passed"]
+  where
+    pName = protocolName p
 
 viewChatItemTTL :: Maybe Int64 -> [StyledString]
 viewChatItemTTL = \case
@@ -825,8 +838,8 @@ viewConnectionStats ConnectionStats {rcvServers, sndServers} =
   ["receiving messages via: " <> viewServerHosts rcvServers | not $ null rcvServers]
     <> ["sending messages via: " <> viewServerHosts sndServers | not $ null sndServers]
 
-viewServers :: ProtocolTypeI p => [ServerCfg p] -> StyledString
-viewServers = plain . intercalate ", " . map (B.unpack . strEncode . (\ServerCfg {server} -> server))
+viewServers :: ProtocolTypeI p => NonEmpty (ServerCfg p) -> StyledString
+viewServers = plain . intercalate ", " . map (B.unpack . strEncode . (\ServerCfg {server} -> server)) . L.toList
 
 viewServerHosts :: [SMPServer] -> StyledString
 viewServerHosts = plain . intercalate ", " . map showSMPServer
@@ -1304,6 +1317,7 @@ viewChatError logLevel = \case
     CEDirectMessagesProhibited dir ct -> viewDirectMessagesProhibited dir ct
     CEAgentVersion -> ["unsupported agent version"]
     CEAgentNoSubResult connId -> ["no subscription result for connection: " <> sShow connId]
+    CEServerProtocol p -> [plain $ "Servers for protocol " <> strEncode p <> " cannot be configured by the users"]
     CECommandError e -> ["bad chat command: " <> plain e]
     CEAgentCommandError e -> ["agent command error: " <> plain e]
     CEInvalidFileDescription e -> ["invalid file description: " <> plain e]