From 9f8db135537a121dc1210e3dff96b4a480666c6f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 5 Apr 2023 20:37:03 +0100 Subject: [PATCH] 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 | 11 +-- src/Simplex/Messaging/Agent.hs | 37 ++++++---- src/Simplex/Messaging/Agent/Client.hs | 96 +++++++++++++++++++++----- src/Simplex/Messaging/Protocol.hs | 21 +++++- tests/AgentTests/FunctionalAPITests.hs | 19 ++--- tests/XFTPAgent.hs | 28 +++++++- tests/XFTPClient.hs | 3 + 7 files changed, 162 insertions(+), 53 deletions(-) diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index eb5a7fa41..4674c4109 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/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" diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index b33fad818..785e76d08 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/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 = diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 245c17d09..ef9ab0710 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 20e35aae5..31245e887 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/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, diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index e477acdc5..47f423bbd 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/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 diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index a3bb4aef9..fcc942f16 100644 --- a/tests/XFTPAgent.hs +++ b/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 diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index d985fef5b..4bd91997a 100644 --- a/tests/XFTPClient.hs +++ b/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"