xftp: agent API to set and test servers (#704)

* xftp: agent API to set and test servers

* ProtocolTestStep

* update agent API for XFTP servers

* ci: update ubuntu versions

* disable test hanging on ubuntu

src/Simplex/FileTransfer/Agent.hs

@@ -86,7 +86,7 @@ closeXFTPAgent XFTPAgent {xftpWorkers} = do
 receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> m RcvFileId
 receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) = do
   g <- asks idsDrg
-  workPath <- getWorkPath
+  workPath <- getXFTPWorkPath
   ts <- liftIO getCurrentTime
   let isoTime = formatTime defaultTimeLocale "%Y%m%d_%H%M%S_%6q" ts
   prefixPath <- uniqueCombine workPath (isoTime <> "_rcv.xftp")
@@ -105,13 +105,8 @@ receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) = do
       addXFTPWorker c (Just server)
     downloadChunk _ = throwError $ INTERNAL "no replicas"
 
-getWorkPath :: AgentMonad m => m FilePath
-getWorkPath = do
-  workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent)
-  maybe getTemporaryDirectory pure workDir
-
 toFSFilePath :: AgentMonad m => FilePath -> m FilePath
-toFSFilePath f = (</> f) <$> getWorkPath
+toFSFilePath f = (</> f) <$> getXFTPWorkPath
 
 createEmptyFile :: AgentMonad m => FilePath -> m ()
 createEmptyFile fPath = do
@@ -262,7 +257,7 @@ sendFileExperimental c@AgentClient {xftpServers} userId filePath numRecipients =
     sendCLI :: SndFileId -> [XFTPServerWithAuth] -> m ()
     sendCLI sndFileId xftpSrvs = do
       let fileName = takeFileName filePath
-      workPath <- getWorkPath
+      workPath <- getXFTPWorkPath
       outputDir <- uniqueCombine workPath $ fileName <> ".descr"
       createDirectory outputDir
       let tempPath = workPath </> "snd"

src/Simplex/Messaging/Agent.hs

@@ -68,8 +68,8 @@ module Simplex.Messaging.Agent
     deleteConnections,
     getConnectionServers,
     getConnectionRatchetAdHash,
-    setSMPServers,
-    testSMPServerConnection,
+    setProtocolServers,
+    testProtocolServer,
     setNtfServers,
     setNetworkConfig,
     getNetworkConfig,
@@ -140,7 +140,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr')
+import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, UserProtocol, XFTPServerWithAuth, protoServer, sameSrvAddr')
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util
@@ -175,8 +175,8 @@ resumeAgentClient c = atomically $ writeTVar (active c) True
 
 type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m)
 
-createUser :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId
-createUser c = withAgentEnv c . createUser' c
+createUser :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> m UserId
+createUser c = withAgentEnv c .: createUser' c
 
 -- | Delete user record optionally deleting all user's connections on SMP servers
 deleteUser :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> m ()
@@ -288,12 +288,14 @@ getConnectionRatchetAdHash :: AgentErrorMonad m => AgentClient -> ConnId -> m By
 getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
 
 -- | Change servers to be used for creating new queues
-setSMPServers :: MonadUnliftIO m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
-setSMPServers c = withAgentEnv c .: setSMPServers' c
+setProtocolServers :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentErrorMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
+setProtocolServers c = withAgentEnv c .: setProtocolServers' c
 
--- | Test SMP server
-testSMPServerConnection :: AgentErrorMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
-testSMPServerConnection c = withAgentEnv c .: runSMPServerTest c
+-- | Test protocol server
+testProtocolServer :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentErrorMonad m) => AgentClient -> UserId -> ProtoServerWithAuth p -> m (Maybe ProtocolTestFailure)
+testProtocolServer c userId srv = withAgentEnv c $ case protocolTypeI @p of
+  SPSMP -> runSMPServerTest c userId srv
+  SPXFTP -> runXFTPServerTest c userId srv
 
 setNtfServers :: MonadUnliftIO m => AgentClient -> [NtfServer] -> m ()
 setNtfServers c = withAgentEnv c . setNtfServers' c
@@ -417,10 +419,11 @@ processCommand c (connId, APC e cmd) =
     userId :: UserId
     userId = 1
 
-createUser' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId
-createUser' c srvs = do
+createUser' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> m UserId
+createUser' c smp xftp = do
   userId <- withStore' c createUserRecord
-  atomically $ TM.insert userId srvs $ smpServers c
+  atomically $ TM.insert userId smp $ smpServers c
+  atomically $ TM.insert userId xftp $ xftpServers c
   pure userId
 
 deleteUser' :: AgentMonad m => AgentClient -> UserId -> Bool -> m ()
@@ -1336,8 +1339,12 @@ connectionStats = \case
   NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []}
 
 -- | Change servers to be used for creating new queues, in Reader monad
-setSMPServers' :: AgentMonad' m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m ()
-setSMPServers' c userId srvs = atomically $ TM.insert userId srvs $ smpServers c
+setProtocolServers' :: forall p m. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> NonEmpty (ProtoServerWithAuth p) -> m ()
+setProtocolServers' c userId srvs = servers >>= atomically . TM.insert userId srvs
+  where
+    servers = case protocolTypeI @p of
+      SPSMP -> pure $ smpServers c
+      SPXFTP -> pure $ xftpServers c
 
 registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
 registerNtfToken' c suppliedDeviceToken suppliedNtfMode =

src/Simplex/Messaging/Agent/Client.hs

@@ -19,14 +19,16 @@
 
 module Simplex.Messaging.Agent.Client
   ( AgentClient (..),
-    SMPTestFailure (..),
-    SMPTestStep (..),
+    ProtocolTestFailure (..),
+    ProtocolTestStep (..),
     newAgentClient,
     withConnLock,
     closeAgentClient,
     closeProtocolServerClients,
     closeXFTPServerClient,
     runSMPServerTest,
+    runXFTPServerTest,
+    getXFTPWorkPath,
     newRcvQueue,
     subscribeQueues,
     getQueueMessage,
@@ -94,6 +96,7 @@ import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
+import Crypto.Random (getRandomBytes)
 import Data.Aeson (ToJSON)
 import qualified Data.Aeson as J
 import Data.Bifunctor (bimap, first, second)
@@ -111,17 +114,18 @@ import Data.Maybe (isJust, listToMaybe)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text.Encoding
-import Data.Time (UTCTime)
+import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import Data.Word (Word16)
 import qualified Database.SQLite.Simple as DB
 import GHC.Generics (Generic)
 import Network.Socket (HostName)
-import Simplex.FileTransfer.Client (XFTPClient, XFTPClientConfig (..))
+import Simplex.FileTransfer.Client (XFTPClient, XFTPClientConfig (..), XFTPClientError)
 import qualified Simplex.FileTransfer.Client as X
-import Simplex.FileTransfer.Description (ChunkReplicaId (..))
-import Simplex.FileTransfer.Protocol (FileResponse, XFTPErrorType)
-import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec)
+import Simplex.FileTransfer.Description (ChunkReplicaId (..), kb)
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, XFTPErrorType (DIGEST))
+import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import Simplex.FileTransfer.Types (RcvFileChunkReplica (..))
+import Simplex.FileTransfer.Util (uniqueCombine)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Lock
 import Simplex.Messaging.Agent.Protocol
@@ -171,6 +175,7 @@ import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Timeout (timeout)
 import UnliftIO (mapConcurrently)
+import UnliftIO.Directory (getTemporaryDirectory)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -681,24 +686,34 @@ protocolClientError protocolError_ host = \case
   e@PCECryptoError {} -> INTERNAL $ show e
   PCEIOError {} -> BROKER host NETWORK
 
-data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect
+data ProtocolTestStep
+  = TSConnect
+  | TSDisconnect
+  | TSCreateQueue
+  | TSSecureQueue
+  | TSDeleteQueue
+  | TSCreateFile
+  | TSUploadFile
+  | TSDownloadFile
+  | TSCompareFile
+  | TSDeleteFile
   deriving (Eq, Show, Generic)
 
-instance ToJSON SMPTestStep where
+instance ToJSON ProtocolTestStep where
   toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "TS"
   toJSON = J.genericToJSON . enumJSON $ dropPrefix "TS"
 
-data SMPTestFailure = SMPTestFailure
-  { testStep :: SMPTestStep,
+data ProtocolTestFailure = ProtocolTestFailure
+  { testStep :: ProtocolTestStep,
     testError :: AgentErrorType
   }
   deriving (Eq, Show, Generic)
 
-instance ToJSON SMPTestFailure where
+instance ToJSON ProtocolTestFailure where
   toEncoding = J.genericToEncoding J.defaultOptions
   toJSON = J.genericToJSON J.defaultOptions
 
-runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure)
+runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure)
 runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
   cfg <- getClientConfig c smpCfg
   C.SignAlg a <- asks $ cmdSignAlg . config
@@ -714,13 +729,60 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
           liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey
           liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
         ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
-        incClientStat c userId smp "TEST" "OK"
-        pure $ either Just (const Nothing) r <|> maybe (Just (SMPTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
+        incClientStat c userId smp "SMP_TEST" "OK"
+        pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
       Left e -> pure (Just $ testErr TSConnect e)
   where
     addr = B.unpack $ strEncode srv
-    testErr :: SMPTestStep -> SMPClientError -> SMPTestFailure
-    testErr step = SMPTestFailure step . protocolClientError SMP addr
+    testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
+    testErr step = ProtocolTestFailure step . protocolClientError SMP addr
+
+runXFTPServerTest :: forall m. AgentMonad m => AgentClient -> UserId -> XFTPServerWithAuth -> m (Maybe ProtocolTestFailure)
+runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
+  cfg <- asks $ xftpCfg . config
+  xftpNetworkConfig <- readTVarIO $ useNetworkConfig c
+  workDir <- getXFTPWorkPath
+  filePath <- getTempFilePath workDir
+  rcvPath <- getTempFilePath workDir
+  liftIO $ do
+    let tSess = (userId, srv, Nothing)
+    X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
+      Right xftp -> do
+        (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+        (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+        createTestChunk filePath
+        digest <- liftIO $ C.sha256Hash <$> B.readFile filePath
+        let file = FileInfo {sndKey, size = chSize, digest}
+            chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
+        r <- runExceptT $ do
+          (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
+          liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
+          liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
+          rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
+          unless (digest == rcvDigest) $ throwError $ ProtocolTestFailure TSCompareFile $ XFTP DIGEST
+          liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
+        ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp
+        incClientStat c userId xftp "XFTP_TEST" "OK"
+        pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
+      Left e -> pure (Just $ testErr TSConnect e)
+  where
+    addr = B.unpack $ strEncode srv
+    testErr :: ProtocolTestStep -> XFTPClientError -> ProtocolTestFailure
+    testErr step = ProtocolTestFailure step . protocolClientError XFTP addr
+    chSize :: Integral a => a
+    chSize = kb 256
+    getTempFilePath :: FilePath -> m FilePath
+    getTempFilePath workPath = do
+      ts <- liftIO getCurrentTime
+      let isoTime = formatTime defaultTimeLocale "%Y-%m-%dT%H%M%S.%6q" ts
+      uniqueCombine workPath isoTime
+    createTestChunk :: FilePath -> IO ()
+    createTestChunk fp = B.writeFile fp =<< getRandomBytes chSize
+
+getXFTPWorkPath :: AgentMonad m => m FilePath
+getXFTPWorkPath = do
+  workDir <- readTVarIO =<< asks (xftpWorkDir . xftpAgent)
+  maybe getTemporaryDirectory pure workDir
 
 mkTransportSession :: AgentMonad' m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg)
 mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c

src/Simplex/Messaging/Protocol.hs

@@ -68,6 +68,7 @@ module Simplex.Messaging.Protocol
     SProtocolType (..),
     AProtocolType (..),
     ProtocolTypeI (..),
+    UserProtocol,
     ProtocolServer (..),
     ProtoServer,
     SMPServer,
@@ -111,6 +112,7 @@ module Simplex.Messaging.Protocol
     SMPMsgMeta (..),
     NMsgMeta (..),
     MsgFlags (..),
+    userProtocol,
     rcvMessageMeta,
     noMsgFlags,
 
@@ -152,6 +154,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isPrint, isSpace)
+import Data.Constraint (Dict (..))
 import Data.Functor (($>))
 import Data.Kind
 import Data.List.NonEmpty (NonEmpty (..))
@@ -161,7 +164,7 @@ import Data.String
 import Data.Time.Clock.System (SystemTime (..))
 import Data.Type.Equality
 import GHC.Generics (Generic)
-import GHC.TypeLits (type (+))
+import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
 import Generic.Random (genericArbitraryU)
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
@@ -704,6 +707,10 @@ instance StrEncoding AProtocolType where
   strEncode (AProtocolType p) = strEncode p
   strP = aProtocolType <$> strP
 
+instance ProtocolTypeI p => ToJSON (SProtocolType p) where
+  toEncoding = strToJEncoding
+  toJSON = strToJSON
+
 instance ToJSON AProtocolType where
   toEncoding = strToJEncoding
   toJSON = strToJSON
@@ -722,6 +729,18 @@ instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF
 
 instance ProtocolTypeI 'PXFTP where protocolTypeI = SPXFTP
 
+type family UserProtocol (p :: ProtocolType) :: Constraint where
+  UserProtocol PSMP = ()
+  UserProtocol PXFTP = ()
+  UserProtocol a =
+    (Int ~ Bool, TypeError (Text "Servers for protocol " :<>: ShowType a :<>: Text " cannot be configured by the users"))
+
+userProtocol :: SProtocolType p -> Maybe (Dict (UserProtocol p))
+userProtocol = \case
+  SPSMP -> Just Dict
+  SPXFTP -> Just Dict
+  _ -> Nothing
+
 -- | server location and transport key digest (hash).
 data ProtocolServer p = ProtocolServer
   { scheme :: SProtocolType p,

tests/AgentTests/FunctionalAPITests.hs

@@ -47,7 +47,7 @@ import Data.Type.Equality
 import SMPAgentClient
 import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..))
+import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore)
 import Simplex.Messaging.Agent.Protocol as Agent
 import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..))
@@ -63,6 +63,7 @@ import Simplex.Messaging.Util (tryError)
 import Simplex.Messaging.Version
 import Test.Hspec
 import UnliftIO
+import XFTPClient (testXFTPServer)
 
 type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e)
 
@@ -217,11 +218,11 @@ functionalAPITests t = do
     it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
     let srv1 = testSMPServer2 {keyHash = "1234"}
     it "should fail with incorrect fingerprint" $ do
-      testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (SMPTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+      testSMPServerConnectionTest t Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
     describe "server with password" $ do
       let auth = Just "abcd"
           srv = ProtoServerWithAuth testSMPServer2
-          authErr = Just (SMPTestFailure TSCreateQueue $ SMP AUTH)
+          authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP AUTH)
       it "should pass with correct password" $ testSMPServerConnectionTest t auth (srv auth) `shouldReturn` Nothing
       it "should fail without password" $ testSMPServerConnectionTest t auth (srv Nothing) `shouldReturn` authErr
       it "should fail with incorrect password" $ testSMPServerConnectionTest t auth (srv $ Just "wrong") `shouldReturn` authErr
@@ -798,7 +799,7 @@ testUsers = do
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
-    auId <- createUser a [noAuthSrv testSMPServer]
+    auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetingsMsgId 4 a bId' b aId'
     deleteUser a auId True
@@ -815,7 +816,7 @@ testDeleteUserQuietly = do
   runRight_ $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
-    auId <- createUser a [noAuthSrv testSMPServer]
+    auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetingsMsgId 4 a bId' b aId'
     deleteUser a auId False
@@ -829,7 +830,7 @@ testUsersNoServer t = do
   (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
     (aId, bId) <- makeConnection a b
     exchangeGreetingsMsgId 4 a bId b aId
-    auId <- createUser a [noAuthSrv testSMPServer]
+    auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId', bId') <- makeConnectionForUsers a auId b 1
     exchangeGreetingsMsgId 4 a bId' b aId'
     pure (aId, bId, auId, aId', bId')
@@ -957,11 +958,11 @@ testCreateQueueAuth clnt1 clnt2 = do
           smpCfg = (defaultClientConfig :: ProtocolClientConfig) {smpServerVRange = mkVersionRange 4 clntVersion}
        in getSMPAgentClient' agentCfg {smpCfg} servers testDB
 
-testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe SMPTestFailure)
+testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
 testSMPServerConnectionTest t newQueueBasicAuth srv =
   withSmpServerConfigOn t cfg {newQueueBasicAuth} testPort2 $ \_ -> do
     a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running
-    runRight $ testSMPServerConnection a 1 srv
+    runRight $ testProtocolServer a 1 srv
 
 testRatchetAdHash :: IO ()
 testRatchetAdHash = do
@@ -1003,7 +1004,7 @@ testTwoUsers = do
     ("", "", UP _ _) <- nGet a
     a `hasClients` 1
 
-    aUserId2 <- createUser a [noAuthSrv testSMPServer]
+    aUserId2 <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer]
     (aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1
     exchangeGreetings a bId2 b aId2
     (aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1

tests/XFTPAgent.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -13,10 +14,13 @@ import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import SMPAgentClient (agentCfg, initAgentServers, testDB)
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..))
-import Simplex.Messaging.Agent (AgentClient, disconnectAgentClient, xftpDeleteRcvFile, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
-import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType (AUTH))
+import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
+import Simplex.Messaging.Agent (AgentClient, disconnectAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
+import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
+import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv)
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
+import Simplex.Messaging.Protocol (BasicAuth, ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
 import System.Directory (doesDirectoryExist, getFileSize, listDirectory)
 import System.FilePath ((</>))
 import System.Timeout (timeout)
@@ -30,6 +34,18 @@ xftpAgentTests = around_ testBracket . describe "Functional API" $ do
   it "should resume receiving file after restart" testXFTPAgentReceiveRestore
   it "should cleanup tmp path after permanent error" testXFTPAgentReceiveCleanup
   it "should send file using experimental api" testXFTPAgentSendExperimental
+  describe "XFTP server test via agent API" $ do
+    it "should pass without basic auth" $ testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing
+    let srv1 = testXFTPServer2 {keyHash = "1234"}
+    it "should fail with incorrect fingerprint" $ do
+      testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) NETWORK)
+    describe "server with password" $ do
+      let auth = Just "abcd"
+          srv = ProtoServerWithAuth testXFTPServer2
+          authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP AUTH)
+      it "should pass with correct password" $ testXFTPServerTest auth (srv auth) `shouldReturn` Nothing
+      it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr
+      it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr
 
 rfProgress :: (MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
 rfProgress c expected = loop 0
@@ -208,3 +224,9 @@ testXFTPAgentSendExperimental = withXFTPServer $ do
     liftIO $ do
       rfId' `shouldBe` rfId
       B.readFile path `shouldReturn` file
+
+testXFTPServerTest :: Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
+testXFTPServerTest newFileBasicAuth srv =
+  withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do
+    a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running
+    runRight $ testProtocolServer a 1 srv

tests/XFTPClient.hs

@@ -71,6 +71,9 @@ xftpTestPort2 = "7001"
 testXFTPServer :: XFTPServer
 testXFTPServer = fromString testXFTPServerStr
 
+testXFTPServer2 :: XFTPServer
+testXFTPServer2 = fromString testXFTPServerStr2
+
 testXFTPServerStr :: String
 testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000"