mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-28 07:50:12 +00:00
test: parameterize XFTP server, agent and CLI tests over store backend
- xftpTest/xftpTest2/xftpTest4/xftpTestN now take XFTPTestBracket as first argument, enabling the same test to run against both memory and PostgreSQL backends. - xftpFileTests (server tests), xftpAgentFileTests (agent tests), and xftpCLIFileTests (CLI tests) are SpecWith-parameterized suites that receive the bracket from HSpec's before combinator. - Test.hs runs each parameterized suite twice: once with xftpMemoryBracket, once with xftpPostgresBracket (CPP-guarded). - STM-specific tests (store log restore/replay) stay in memory-only xftpAgentTests. SNI/CORS tests stay in memory-only xftpServerTests.
This commit is contained in:
shum
@@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module CoreTests.XFTPStoreTests (xftpStoreTests, xftpMigrationTests) where
|
||||
|
||||
@@ -55,9 +54,6 @@ testSenderId = EntityId "sender001_______"
|
||||
testRecipientId :: EntityId
|
||||
testRecipientId = EntityId "recipient001____"
|
||||
|
||||
testRecipientId2 :: EntityId
|
||||
testRecipientId2 = EntityId "recipient002____"
|
||||
|
||||
testFileInfo :: C.APublicAuthKey -> FileInfo
|
||||
testFileInfo sndKey =
|
||||
FileInfo
|
||||
|
||||
+16
-4
@@ -32,9 +32,9 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
|
||||
import System.Environment (setEnv)
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util
|
||||
import XFTPAgent
|
||||
import XFTPCLI
|
||||
import XFTPClient (xftpMemoryBracket, xftpServerFiles)
|
||||
import XFTPAgent (xftpAgentTests, xftpAgentFileTests, xftpAgentRestoreTests)
|
||||
import XFTPCLI (xftpCLITests, xftpCLIFileTests)
|
||||
import XFTPClient (xftpMemoryBracket, xftpMemoryBracket2, xftpMemoryBracketClear, xftpServerFiles)
|
||||
import XFTPServerTests (xftpServerTests, xftpFileTests)
|
||||
import WebTests (webTests)
|
||||
import XFTPWebTests (xftpWebTests)
|
||||
@@ -54,7 +54,7 @@ import PostgresSchemaDump (postgresSchemaDumpTest)
|
||||
import SMPClient (testServerDBConnectInfo, testStoreDBOpts)
|
||||
import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations)
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations)
|
||||
import XFTPClient (testXFTPDBConnectInfo, xftpPostgresBracket)
|
||||
import XFTPClient (testXFTPDBConnectInfo, xftpPostgresBracket, xftpPostgresBracket2, xftpPostgresBracketClear)
|
||||
#endif
|
||||
|
||||
#if defined(dbPostgres) || defined(dbServerPostgres)
|
||||
@@ -157,7 +157,13 @@ main = do
|
||||
before (pure xftpMemoryBracket) xftpFileTests
|
||||
describe "XFTP file description" fileDescriptionTests
|
||||
describe "XFTP CLI" xftpCLITests
|
||||
describe "XFTP CLI (memory)" $
|
||||
before (pure (xftpMemoryBracket, xftpMemoryBracket2)) xftpCLIFileTests
|
||||
describe "XFTP agent" xftpAgentTests
|
||||
describe "XFTP agent (memory)" $
|
||||
before (pure xftpMemoryBracket) xftpAgentFileTests
|
||||
describe "XFTP agent restore (memory)" $
|
||||
before (pure xftpMemoryBracketClear) xftpAgentRestoreTests
|
||||
#if defined(dbServerPostgres)
|
||||
around_ (postgressBracket testXFTPDBConnectInfo) $ do
|
||||
describe "XFTP Postgres store operations" xftpStoreTests
|
||||
@@ -165,6 +171,12 @@ main = do
|
||||
before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $
|
||||
describe "XFTP file delivery (PostgreSQL)" $
|
||||
before (pure xftpPostgresBracket) xftpFileTests
|
||||
describe "XFTP agent (PostgreSQL)" $
|
||||
before (pure xftpPostgresBracket) xftpAgentFileTests
|
||||
describe "XFTP agent restore (PostgreSQL)" $
|
||||
before (pure xftpPostgresBracketClear) xftpAgentRestoreTests
|
||||
describe "XFTP CLI (PostgreSQL)" $
|
||||
before (pure (xftpPostgresBracket, xftpPostgresBracket2)) xftpCLIFileTests
|
||||
#endif
|
||||
#if defined(dbPostgres)
|
||||
describe "XFTP Web Client" $ xftpWebTests (dropAllSchemasExceptSystem testDBConnectInfo)
|
||||
|
||||
+348
-76
@@ -8,7 +8,7 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module XFTPAgent where
|
||||
module XFTPAgent (xftpAgentTests, xftpAgentFileTests, xftpAgentRestoreTests) where
|
||||
|
||||
import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent)
|
||||
|
||||
@@ -93,6 +93,72 @@ xftpAgentTests =
|
||||
it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr
|
||||
it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr
|
||||
|
||||
-- Tests that restart the server between steps (restore/cleanup).
|
||||
-- clearStore wipes metadata to simulate "server lost state" for cleanup tests.
|
||||
xftpAgentRestoreTests :: SpecWith XFTPTestBracketClear
|
||||
xftpAgentRestoreTests =
|
||||
around_ testBracket
|
||||
#if defined(dbPostgres)
|
||||
. after_ (dropAllSchemasExceptSystem testDBConnectInfo)
|
||||
#endif
|
||||
$ do
|
||||
it "should resume receiving file after restart" $ \(XFTPTestBracket withSrv, _clearStore) ->
|
||||
testXFTPAgentReceiveRestore_ withSrv
|
||||
it "should resume sending file after restart" $ \(XFTPTestBracket withSrv, _clearStore) ->
|
||||
testXFTPAgentSendRestore_ withSrv
|
||||
it "should resume deleting file after restart" $ \(XFTPTestBracket withSrv, _clearStore) ->
|
||||
testXFTPAgentDeleteRestore_ withSrv
|
||||
it "should cleanup rcv tmp path after permanent error" $ \(XFTPTestBracket withSrv, clearStore) ->
|
||||
testXFTPAgentReceiveCleanup_ withSrv clearStore
|
||||
xit'' "should cleanup snd prefix path after permanent error" $ \(XFTPTestBracket withSrv, clearStore) ->
|
||||
testXFTPAgentSendCleanup_ withSrv clearStore
|
||||
|
||||
xftpAgentFileTests :: SpecWith XFTPTestBracket
|
||||
xftpAgentFileTests =
|
||||
around_ testBracket
|
||||
#if defined(dbPostgres)
|
||||
. after_ (dropAllSchemasExceptSystem testDBConnectInfo)
|
||||
#endif
|
||||
$ do
|
||||
it "should send and receive file" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id testXFTPAgentSendReceive
|
||||
it "should send and receive with encrypted local files" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id testXFTPAgentSendReceiveEncrypted_
|
||||
it "should send and receive large file with a redirect" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id testXFTPAgentSendReceiveRedirect_
|
||||
it "should send and receive small file without a redirect" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id testXFTPAgentSendReceiveNoRedirect_
|
||||
it "should request additional recipient IDs when number of recipients exceeds maximum per request" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id testXFTPAgentRequestAdditionalRecipientIDs_
|
||||
it "should delete sent file on server" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ withGlobalLogging logCfgNoLogs testXFTPAgentDelete_
|
||||
it "if file is deleted on server, should limit retries and continue receiving next file" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ withGlobalLogging logCfgNoLogs testXFTPAgentDeleteOnServer_
|
||||
it "if file is expired on server, should report error and continue receiving next file" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {fileExpiration = Just ExpirationConfig {ttl = 2, checkInterval = 1}}) $
|
||||
withGlobalLogging logCfgNoLogs testXFTPAgentExpiredOnServer_
|
||||
describe "XFTP server test via agent API" $ do
|
||||
it "should pass without basic auth" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {xftpPort = xftpTestPort2}) $
|
||||
testXFTPServerTest_ (noAuthSrv testXFTPServer2) `shouldReturn` Nothing
|
||||
let srv1 = testXFTPServer2 {keyHash = "1234"}
|
||||
it "should fail with incorrect fingerprint" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {xftpPort = xftpTestPort2}) $
|
||||
testXFTPServerTest_ (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
describe "server with password" $ do
|
||||
let auth = Just "abcd"
|
||||
srv = ProtoServerWithAuth testXFTPServer2
|
||||
authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH)
|
||||
it "should pass with correct password" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {newFileBasicAuth = auth, xftpPort = xftpTestPort2}) $
|
||||
testXFTPServerTest_ (srv auth) `shouldReturn` Nothing
|
||||
it "should fail without password" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {newFileBasicAuth = auth, xftpPort = xftpTestPort2}) $
|
||||
testXFTPServerTest_ (srv Nothing) `shouldReturn` authErr
|
||||
it "should fail with incorrect password" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {newFileBasicAuth = auth, xftpPort = xftpTestPort2}) $
|
||||
testXFTPServerTest_ (srv $ Just "wrong") `shouldReturn` authErr
|
||||
|
||||
rfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
|
||||
rfProgress c expected = loop 0
|
||||
where
|
||||
@@ -136,7 +202,10 @@ testXFTPAgentSendReceive = do
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
|
||||
testXFTPAgentSendReceiveEncrypted = withXFTPServer testXFTPAgentSendReceiveEncrypted_
|
||||
|
||||
testXFTPAgentSendReceiveEncrypted_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveEncrypted_ = do
|
||||
g <- C.newRandom
|
||||
filePath <- createRandomFile
|
||||
s <- LB.readFile filePath
|
||||
@@ -157,7 +226,10 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
|
||||
testXFTPAgentSendReceiveRedirect = withXFTPServer testXFTPAgentSendReceiveRedirect_
|
||||
|
||||
testXFTPAgentSendReceiveRedirect_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveRedirect_ = do
|
||||
--- sender
|
||||
filePathIn <- createRandomFile
|
||||
let fileSize = mb 17
|
||||
@@ -215,7 +287,10 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
|
||||
testXFTPAgentSendReceiveNoRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
|
||||
testXFTPAgentSendReceiveNoRedirect = withXFTPServer testXFTPAgentSendReceiveNoRedirect_
|
||||
|
||||
testXFTPAgentSendReceiveNoRedirect_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveNoRedirect_ = do
|
||||
--- sender
|
||||
let fileSize = mb 5
|
||||
filePathIn <- createRandomFile_ fileSize "testfile"
|
||||
@@ -342,6 +417,46 @@ testReceiveCF' rcp rfd cfArgs originalFilePath size = do
|
||||
logCfgNoLogs :: LogConfig
|
||||
logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
|
||||
|
||||
testXFTPAgentReceiveRestore_ :: HasCallStack => (forall a. (XFTPServerConfig -> XFTPServerConfig) -> IO a -> IO a) -> IO ()
|
||||
testXFTPAgentReceiveRestore_ withSrv = do
|
||||
filePath <- createRandomFile
|
||||
|
||||
rfd <- withSrv id $
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(_, _, rfd, _) <- testSend sndr filePath
|
||||
pure rfd
|
||||
|
||||
-- receive file - should not succeed with server down
|
||||
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
|
||||
xftpStartWorkers rcp (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp 1 rfd Nothing True
|
||||
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing
|
||||
pure rfId
|
||||
|
||||
[prefixDir] <- listDirectory recipientFiles
|
||||
let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
|
||||
doesDirectoryExist tmpPath `shouldReturn` True
|
||||
|
||||
withSrv id $
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
("", rfId', RFPROG _ _) <- rfGet rcp'
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
threadDelay 100000
|
||||
|
||||
withSrv id $
|
||||
withAgent 4 agentCfg initAgentServers testDB2 $ \rcp' -> do
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
rfProgress rcp' $ mb 18
|
||||
("", rfId', RFDONE path) <- rfGet rcp'
|
||||
liftIO $ do
|
||||
rfId' `shouldBe` rfId
|
||||
file <- B.readFile filePath
|
||||
B.readFile path `shouldReturn` file
|
||||
|
||||
threadDelay 100000
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentReceiveRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveRestore = do
|
||||
filePath <- createRandomFile
|
||||
@@ -386,6 +501,37 @@ testXFTPAgentReceiveRestore = do
|
||||
-- tmp path should be removed after receiving file
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentReceiveCleanup_ :: HasCallStack => (forall a. (XFTPServerConfig -> XFTPServerConfig) -> IO a -> IO a) -> IO () -> IO ()
|
||||
testXFTPAgentReceiveCleanup_ withSrv clearStore = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
rfd <- withSrv id $
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(_, _, rfd, _) <- testSend sndr filePath
|
||||
pure rfd
|
||||
|
||||
-- receive file - should not succeed with server down
|
||||
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
|
||||
xftpStartWorkers rcp (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp 1 rfd Nothing True
|
||||
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing
|
||||
pure rfId
|
||||
|
||||
[prefixDir] <- listDirectory recipientFiles
|
||||
let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
|
||||
doesDirectoryExist tmpPath `shouldReturn` True
|
||||
|
||||
-- wipe server metadata so file is gone
|
||||
clearStore
|
||||
|
||||
withSrv id $
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp'
|
||||
rfId' `shouldBe` rfId
|
||||
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
@@ -417,6 +563,49 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
-- tmp path should be removed after permanent error
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentSendRestore_ :: HasCallStack => (forall a. (XFTPServerConfig -> XFTPServerConfig) -> IO a -> IO a) -> IO ()
|
||||
testXFTPAgentSendRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
-- send file - should not succeed with server down
|
||||
sfId <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
xftpStartWorkers sndr (Just senderFiles)
|
||||
sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
|
||||
liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing
|
||||
pure sfId
|
||||
|
||||
dirEntries <- listDirectory senderFiles
|
||||
let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
|
||||
prefixPath = senderFiles </> prefixDir
|
||||
encPath = prefixPath </> "xftp.encrypted"
|
||||
doesDirectoryExist prefixPath `shouldReturn` True
|
||||
doesFileExist encPath `shouldReturn` True
|
||||
|
||||
withSrv id $
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
("", sfId', SFPROG _ _) <- sfGet sndr'
|
||||
liftIO $ sfId' `shouldBe` sfId
|
||||
|
||||
threadDelay 200000
|
||||
|
||||
withSrv id $ do
|
||||
rfd1 <- withAgent 3 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
sfProgress sndr' $ mb 18
|
||||
("", sfId', SFDONE _sndDescr [rfd1, rfd2]) <- sfGet sndr'
|
||||
liftIO $ testNoRedundancy rfd1
|
||||
liftIO $ testNoRedundancy rfd2
|
||||
liftIO $ sfId' `shouldBe` sfId
|
||||
pure rfd1
|
||||
|
||||
threadDelay 500000
|
||||
doesDirectoryExist prefixPath `shouldReturn` False
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
|
||||
withAgent 4 agentCfg initAgentServers testDB2 $ \rcp ->
|
||||
runRight_ . void $ testReceive rcp rfd1 filePath
|
||||
|
||||
testXFTPAgentSendRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
@@ -464,6 +653,38 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
withAgent 4 agentCfg initAgentServers testDB2 $ \rcp ->
|
||||
runRight_ . void $ testReceive rcp rfd1 filePath
|
||||
|
||||
testXFTPAgentSendCleanup_ :: HasCallStack => (forall a. (XFTPServerConfig -> XFTPServerConfig) -> IO a -> IO a) -> IO () -> IO ()
|
||||
testXFTPAgentSendCleanup_ withSrv clearStore = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
sfId <- withSrv id $
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
xftpStartWorkers sndr (Just senderFiles)
|
||||
sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
|
||||
forM_ [1 .. 5 :: Integer] $ \_ -> do
|
||||
(_, _, SFPROG _ _) <- sfGet sndr
|
||||
pure ()
|
||||
pure sfId
|
||||
|
||||
dirEntries <- listDirectory senderFiles
|
||||
let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
|
||||
prefixPath = senderFiles </> prefixDir
|
||||
encPath = prefixPath </> "xftp.encrypted"
|
||||
doesDirectoryExist prefixPath `shouldReturn` True
|
||||
doesFileExist encPath `shouldReturn` True
|
||||
|
||||
clearStore
|
||||
|
||||
withSrv id $
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
|
||||
sfGet sndr'
|
||||
sfId' `shouldBe` sfId
|
||||
|
||||
doesDirectoryExist prefixPath `shouldReturn` False
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentSendCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
@@ -500,30 +721,66 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
|
||||
testXFTPAgentDelete :: HasCallStack => IO ()
|
||||
testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServer $ do
|
||||
filePath <- createRandomFile
|
||||
withXFTPServer testXFTPAgentDelete_
|
||||
|
||||
-- send file
|
||||
testXFTPAgentDelete_ :: HasCallStack => IO ()
|
||||
testXFTPAgentDelete_ = do
|
||||
filePath <- createRandomFile
|
||||
|
||||
-- send file
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
|
||||
|
||||
-- receive file
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> do
|
||||
runRight_ . void $ testReceive rcp1 rfd1 filePath
|
||||
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
-- delete file
|
||||
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
||||
xftpDeleteSndFileRemote sndr 1 sfId sndDescr
|
||||
Nothing <- 100000 `timeout` sfGet sndr
|
||||
pure ()
|
||||
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
-- receive file - should fail with AUTH error
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do
|
||||
xftpStartWorkers rcp2 (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
|
||||
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
|
||||
rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
|
||||
testXFTPAgentDeleteRestore_ :: HasCallStack => (forall a. (XFTPServerConfig -> XFTPServerConfig) -> IO a -> IO a) -> IO ()
|
||||
testXFTPAgentDeleteRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
(sfId, sndDescr, rfd2) <- withSrv id $ do
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
|
||||
|
||||
-- receive file
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> do
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 ->
|
||||
runRight_ . void $ testReceive rcp1 rfd1 filePath
|
||||
pure (sfId, sndDescr, rfd2)
|
||||
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
-- delete file - should not succeed with server down
|
||||
withAgent 3 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
||||
xftpDeleteSndFileRemote sndr 1 sfId sndDescr
|
||||
timeout 300000 (get sndr) `shouldReturn` Nothing
|
||||
threadDelay 300000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
-- delete file
|
||||
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
||||
xftpDeleteSndFileRemote sndr 1 sfId sndDescr
|
||||
Nothing <- 100000 `timeout` sfGet sndr
|
||||
pure ()
|
||||
withSrv id $ do
|
||||
withAgent 4 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
-- receive file - should fail with AUTH error
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do
|
||||
withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do
|
||||
xftpStartWorkers rcp2 (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True
|
||||
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
|
||||
@@ -570,83 +827,94 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
|
||||
testXFTPAgentDeleteOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServer $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
withXFTPServer testXFTPAgentDeleteOnServer_
|
||||
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
testXFTPAgentDeleteOnServer_ :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteOnServer_ = do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
|
||||
-- delete file 1 on server from file system
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
-- delete file 1 on server from file system
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
|
||||
runRight_ . void $ do
|
||||
-- receive file 1 again
|
||||
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
|
||||
("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
|
||||
rfGet rcp
|
||||
liftIO $ rfId1 `shouldBe` rfId1'
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
-- receive file 2
|
||||
testReceive' rcp rfd2 filePath2
|
||||
runRight_ . void $ do
|
||||
-- receive file 1 again
|
||||
rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
|
||||
("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
|
||||
rfGet rcp
|
||||
liftIO $ rfId1 `shouldBe` rfId1'
|
||||
|
||||
-- receive file 2
|
||||
testReceive' rcp rfd2 filePath2
|
||||
|
||||
testXFTPAgentExpiredOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
|
||||
let fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1}
|
||||
withXFTPServerCfg testXFTPServerConfig {fileExpiration = Just fastExpiration} . const $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServerCfg testXFTPServerConfig {fileExpiration = Just fastExpiration} $ \_ ->
|
||||
testXFTPAgentExpiredOnServer_
|
||||
where
|
||||
fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1}
|
||||
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
testXFTPAgentExpiredOnServer_ :: HasCallStack => IO ()
|
||||
testXFTPAgentExpiredOnServer_ = do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
|
||||
-- wait until file 1 expires on server
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
|
||||
threadDelay 3500000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
-- wait until file 1 expires on server
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
|
||||
-- receive file 1 again - should fail with AUTH error
|
||||
runRight $ do
|
||||
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
|
||||
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
|
||||
rfGet rcp
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
threadDelay 3500000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
-- receive file 1 again - should fail with AUTH error
|
||||
runRight $ do
|
||||
rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True
|
||||
("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <-
|
||||
rfGet rcp
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
|
||||
-- receive file 2 successfully
|
||||
runRight_ . void $ testReceive' rcp rfd2 filePath2
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
-- receive file 2 successfully
|
||||
runRight_ . void $ testReceive' rcp rfd2 filePath2
|
||||
|
||||
testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO ()
|
||||
testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
|
||||
testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer testXFTPAgentRequestAdditionalRecipientIDs_
|
||||
|
||||
testXFTPAgentRequestAdditionalRecipientIDs_ :: HasCallStack => IO ()
|
||||
testXFTPAgentRequestAdditionalRecipientIDs_ = do
|
||||
filePath <- createRandomFile
|
||||
|
||||
-- send file
|
||||
@@ -673,6 +941,10 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
|
||||
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testXFTPServerTest newFileBasicAuth srv =
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a NRMInteractive 1 srv
|
||||
testXFTPServerTest_ srv
|
||||
|
||||
testXFTPServerTest_ :: HasCallStack => XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testXFTPServerTest_ srv =
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a NRMInteractive 1 srv
|
||||
|
||||
+24
-5
@@ -1,4 +1,4 @@
|
||||
module XFTPCLI where
|
||||
module XFTPCLI (xftpCLITests, xftpCLIFileTests, xftpCLI, senderFiles, recipientFiles, testBracket) where
|
||||
|
||||
import Control.Exception (bracket_)
|
||||
import qualified Data.ByteString as LB
|
||||
@@ -11,7 +11,7 @@ import System.FilePath ((</>))
|
||||
import System.IO.Silently (capture_)
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util
|
||||
import XFTPClient (testXFTPServerStr, testXFTPServerStr2, withXFTPServer, withXFTPServer2, xftpServerFiles, xftpServerFiles2)
|
||||
import XFTPClient (XFTPTestBracket (..), testXFTPServerStr, testXFTPServerStr2, withXFTPServer, withXFTPServer2, xftpServerFiles, xftpServerFiles2)
|
||||
|
||||
xftpCLITests :: Spec
|
||||
xftpCLITests = around_ testBracket . describe "XFTP CLI" $ do
|
||||
@@ -20,6 +20,16 @@ xftpCLITests = around_ testBracket . describe "XFTP CLI" $ do
|
||||
it "should delete file from 2 servers" testXFTPCLIDelete
|
||||
it "prepareChunkSizes should use 2 chunk sizes" testPrepareChunkSizes
|
||||
|
||||
xftpCLIFileTests :: SpecWith (XFTPTestBracket, XFTPTestBracket)
|
||||
xftpCLIFileTests = around_ testBracket $ do
|
||||
it "should send and receive file" $ \(XFTPTestBracket withSrv, _) ->
|
||||
withSrv id testXFTPCLISendReceive_
|
||||
it "should send and receive file with 2 servers" $ \(XFTPTestBracket withSrv1, XFTPTestBracket withSrv2) ->
|
||||
withSrv1 id $ withSrv2 id testXFTPCLISendReceive2servers_
|
||||
it "should delete file from 2 servers" $ \(XFTPTestBracket withSrv1, XFTPTestBracket withSrv2) ->
|
||||
withSrv1 id $ withSrv2 id testXFTPCLIDelete_
|
||||
it "prepareChunkSizes should use 2 chunk sizes" $ \(_, _) -> testPrepareChunkSizes
|
||||
|
||||
testBracket :: IO () -> IO ()
|
||||
testBracket =
|
||||
bracket_
|
||||
@@ -38,7 +48,10 @@ xftpCLI :: [String] -> IO [String]
|
||||
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)
|
||||
|
||||
testXFTPCLISendReceive :: IO ()
|
||||
testXFTPCLISendReceive = withXFTPServer $ do
|
||||
testXFTPCLISendReceive = withXFTPServer testXFTPCLISendReceive_
|
||||
|
||||
testXFTPCLISendReceive_ :: IO ()
|
||||
testXFTPCLISendReceive_ = do
|
||||
let filePath = senderFiles </> "testfile"
|
||||
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
|
||||
file <- LB.readFile filePath
|
||||
@@ -74,7 +87,10 @@ testXFTPCLISendReceive = withXFTPServer $ do
|
||||
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
|
||||
|
||||
testXFTPCLISendReceive2servers :: IO ()
|
||||
testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
|
||||
testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ testXFTPCLISendReceive2servers_
|
||||
|
||||
testXFTPCLISendReceive2servers_ :: IO ()
|
||||
testXFTPCLISendReceive2servers_ = do
|
||||
let filePath = senderFiles </> "testfile"
|
||||
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
|
||||
file <- LB.readFile filePath
|
||||
@@ -112,7 +128,10 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
|
||||
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
|
||||
|
||||
testXFTPCLIDelete :: IO ()
|
||||
testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do
|
||||
testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ testXFTPCLIDelete_
|
||||
|
||||
testXFTPCLIDelete_ :: IO ()
|
||||
testXFTPCLIDelete_ = do
|
||||
let filePath = senderFiles </> "testfile"
|
||||
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
|
||||
file <- LB.readFile filePath
|
||||
|
||||
+87
-50
@@ -8,6 +8,9 @@
|
||||
module XFTPClient where
|
||||
|
||||
import Control.Concurrent (ThreadId, threadDelay)
|
||||
import Control.Exception (SomeException, catch)
|
||||
import System.Directory (removeFile)
|
||||
import Control.Monad (void)
|
||||
import Data.String (fromString)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Network.Socket (ServiceName)
|
||||
@@ -23,12 +26,76 @@ import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
||||
import Simplex.Messaging.Transport.Server
|
||||
import Test.Hspec hiding (fit, it)
|
||||
#if defined(dbServerPostgres)
|
||||
import qualified Database.PostgreSQL.Simple as PSQL
|
||||
import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
|
||||
import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
||||
#endif
|
||||
|
||||
-- Parameterized server bracket
|
||||
|
||||
newtype XFTPTestBracket = XFTPTestBracket
|
||||
{ runBracket :: forall a. (XFTPServerConfig -> XFTPServerConfig) -> IO a -> IO a
|
||||
}
|
||||
|
||||
-- Store-log-dependent agent tests need the bracket + a way to clear server state
|
||||
type XFTPTestBracketClear = (XFTPTestBracket, IO ())
|
||||
|
||||
xftpMemoryBracket :: XFTPTestBracket
|
||||
xftpMemoryBracket = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg_ (XSCMemory Nothing) (cfgF testXFTPServerConfig) $ \_ -> test
|
||||
|
||||
xftpMemoryBracketWithLog :: XFTPTestBracket
|
||||
xftpMemoryBracketWithLog = XFTPTestBracket $ \cfgF test ->
|
||||
withXFTPServerCfg (cfgF testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}) $ \_ -> test
|
||||
|
||||
xftpMemoryBracketClear :: XFTPTestBracketClear
|
||||
xftpMemoryBracketClear = (xftpMemoryBracketWithLog, removeFile testXFTPLogFile `catch` \(_ :: SomeException) -> pure ())
|
||||
|
||||
xftpMemoryBracket2 :: XFTPTestBracket
|
||||
xftpMemoryBracket2 = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg_ (XSCMemory Nothing) (cfgF testXFTPServerConfig2) $ \_ -> test
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
testXFTPDBConnectInfo :: ConnectInfo
|
||||
testXFTPDBConnectInfo =
|
||||
defaultConnectInfo
|
||||
{ connectUser = "test_xftp_server_user",
|
||||
connectDatabase = "test_xftp_server_db"
|
||||
}
|
||||
|
||||
testXFTPPostgresCfg :: PostgresFileStoreCfg
|
||||
testXFTPPostgresCfg =
|
||||
PostgresFileStoreCfg
|
||||
{ dbOpts = defaultXFTPDBOpts
|
||||
{ connstr = "postgresql://test_xftp_server_user@/test_xftp_server_db",
|
||||
schema = "xftp_server_test",
|
||||
poolSize = 10,
|
||||
createSchema = True
|
||||
},
|
||||
dbStoreLogPath = Nothing,
|
||||
confirmMigrations = MCYesUp
|
||||
}
|
||||
|
||||
xftpPostgresBracket :: XFTPTestBracket
|
||||
xftpPostgresBracket = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg_ (XSCDatabase testXFTPPostgresCfg) (cfgF testXFTPServerConfig) $ \_ -> test
|
||||
|
||||
xftpPostgresBracket2 :: XFTPTestBracket
|
||||
xftpPostgresBracket2 = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg_ (XSCDatabase testXFTPPostgresCfg) (cfgF testXFTPServerConfig2) $ \_ -> test
|
||||
|
||||
xftpPostgresBracketClear :: XFTPTestBracketClear
|
||||
xftpPostgresBracketClear = (xftpPostgresBracket, clearXFTPPostgresStore)
|
||||
|
||||
clearXFTPPostgresStore :: IO ()
|
||||
clearXFTPPostgresStore = do
|
||||
let DBOpts {connstr} = dbOpts testXFTPPostgresCfg
|
||||
conn <- PSQL.connectPostgreSQL connstr
|
||||
void $ PSQL.execute_ conn "SET search_path TO xftp_server_test,public"
|
||||
void $ PSQL.execute_ conn "DELETE FROM files"
|
||||
PSQL.close conn
|
||||
#endif
|
||||
|
||||
-- Original test helpers (memory backend)
|
||||
|
||||
xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation
|
||||
xftpTest test = runXFTPTest test `shouldReturn` ()
|
||||
|
||||
@@ -57,17 +124,24 @@ runXFTPTestN nClients test = withXFTPServer $ run nClients []
|
||||
run 0 hs = test hs
|
||||
run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
|
||||
|
||||
withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
|
||||
-- Core server bracket (store-parameterized)
|
||||
|
||||
withXFTPServerCfg_ :: (HasCallStack, FileStoreClass s) => XFTPStoreConfig s -> XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfg_ storeCfg cfg =
|
||||
serverBracket
|
||||
(\started -> runXFTPServerBlocking started storeCfg cfg)
|
||||
(threadDelay 10000)
|
||||
|
||||
-- Memory-only server helpers (used by tests that don't parameterize)
|
||||
|
||||
withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfg cfg = withXFTPServerCfg_ (XSCMemory $ storeLogFile cfg) cfg
|
||||
|
||||
withXFTPServerCfgNoALPN :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfgNoALPN cfg = withXFTPServerCfg cfg {transportConfig = (transportConfig cfg) {serverALPN = Nothing}}
|
||||
|
||||
withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfg cfg =
|
||||
serverBracket
|
||||
(\started -> runXFTPServerBlocking started (XSCMemory $ storeLogFile cfg) cfg)
|
||||
(threadDelay 10000)
|
||||
withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
|
||||
|
||||
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
|
||||
@@ -76,7 +150,9 @@ withXFTPServer :: HasCallStack => IO a -> IO a
|
||||
withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const
|
||||
|
||||
withXFTPServer2 :: HasCallStack => IO a -> IO a
|
||||
withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const
|
||||
withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig2 . const
|
||||
|
||||
-- Constants
|
||||
|
||||
xftpTestPort :: ServiceName
|
||||
xftpTestPort = "8000"
|
||||
@@ -147,6 +223,9 @@ testXFTPServerConfig =
|
||||
webStaticPath = Nothing
|
||||
}
|
||||
|
||||
testXFTPServerConfig2 :: XFTPServerConfig
|
||||
testXFTPServerConfig2 = testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2}
|
||||
|
||||
testXFTPClientConfig :: XFTPClientConfig
|
||||
testXFTPClientConfig = defaultXFTPClientConfig
|
||||
|
||||
@@ -200,45 +279,3 @@ testXFTPServerConfigEd25519SNI =
|
||||
{ addCORSHeaders = True
|
||||
}
|
||||
}
|
||||
|
||||
-- Store-parameterized server bracket
|
||||
|
||||
type XFTPTestBracket = (XFTPServerConfig -> XFTPServerConfig) -> IO () -> IO ()
|
||||
|
||||
xftpMemoryBracket :: XFTPTestBracket
|
||||
xftpMemoryBracket cfgF test = withXFTPServerCfg (cfgF testXFTPServerConfig) $ \_ -> test
|
||||
|
||||
withXFTPServerCfgStore :: (HasCallStack, FileStoreClass s) => XFTPStoreConfig s -> XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfgStore storeCfg cfg =
|
||||
serverBracket
|
||||
(\started -> runXFTPServerBlocking started storeCfg cfg)
|
||||
(threadDelay 10000)
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
testXFTPDBConnectInfo :: ConnectInfo
|
||||
testXFTPDBConnectInfo =
|
||||
defaultConnectInfo
|
||||
{ connectUser = "test_xftp_server_user",
|
||||
connectDatabase = "test_xftp_server_db"
|
||||
}
|
||||
|
||||
testXFTPStoreDBOpts :: DBOpts
|
||||
testXFTPStoreDBOpts =
|
||||
defaultXFTPDBOpts
|
||||
{ connstr = "postgresql://test_xftp_server_user@/test_xftp_server_db",
|
||||
schema = "xftp_server_test",
|
||||
poolSize = 10,
|
||||
createSchema = True
|
||||
}
|
||||
|
||||
testXFTPPostgresCfg :: PostgresFileStoreCfg
|
||||
testXFTPPostgresCfg =
|
||||
PostgresFileStoreCfg
|
||||
{ dbOpts = testXFTPStoreDBOpts,
|
||||
dbStoreLogPath = Nothing,
|
||||
confirmMigrations = MCYesUp
|
||||
}
|
||||
|
||||
xftpPostgresBracket :: XFTPTestBracket
|
||||
xftpPostgresBracket cfgF test = withXFTPServerCfgStore (XSCDatabase testXFTPPostgresCfg) (cfgF testXFTPServerConfig) $ \_ -> test
|
||||
#endif
|
||||
|
||||
+23
-22
@@ -45,7 +45,7 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
|
||||
import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
|
||||
import Simplex.Messaging.Transport.Server (loadFileFingerprint)
|
||||
import Simplex.Messaging.Transport.Shared (ChainCertificates (..), chainIdCaCerts)
|
||||
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile, removePathForcibly)
|
||||
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import UnliftIO.STM
|
||||
@@ -69,6 +69,7 @@ xftpServerTests =
|
||||
it "should not allow uploading chunks after specified storage quota" testFileStorageQuota
|
||||
it "should store file records to log and restore them after server restart" testFileLog
|
||||
describe "XFTP basic auth" $ do
|
||||
-- allow FNEW | server auth | clnt auth | success
|
||||
it "prohibited without basic auth" $ testFileBasicAuth True (Just "pwd") Nothing False
|
||||
it "prohibited when auth is incorrect" $ testFileBasicAuth True (Just "pwd") (Just "wrong") False
|
||||
it "prohibited when FNEW disabled" $ testFileBasicAuth False (Just "pwd") (Just "pwd") False
|
||||
@@ -89,49 +90,49 @@ xftpServerTests =
|
||||
-- Tests parameterized over store backend (memory or PostgreSQL)
|
||||
xftpFileTests :: SpecWith XFTPTestBracket
|
||||
xftpFileTests = do
|
||||
it "should create, upload and receive file chunk (1 client)" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should create, upload and receive file chunk (1 client)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \c -> runRight_ $ runTestFileChunkDelivery c c
|
||||
it "should create, upload and receive file chunk (2 clients)" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should create, upload and receive file chunk (2 clients)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \s -> testXFTPClient $ \r -> runRight_ $ runTestFileChunkDelivery s r
|
||||
it "should create, add recipients, upload and receive file chunk" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should create, add recipients, upload and receive file chunk" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \s -> testXFTPClient $ \r1 -> testXFTPClient $ \r2 -> testXFTPClient $ \r3 ->
|
||||
runRight_ $ runTestFileChunkDeliveryAddRecipients s r1 r2 r3
|
||||
it "should delete file chunk (1 client)" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should delete file chunk (1 client)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \c -> runRight_ $ runTestFileChunkDelete c c
|
||||
it "should delete file chunk (2 clients)" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should delete file chunk (2 clients)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \s -> testXFTPClient $ \r -> runRight_ $ runTestFileChunkDelete s r
|
||||
it "should acknowledge file chunk reception (1 client)" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should acknowledge file chunk reception (1 client)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \c -> runRight_ $ runTestFileChunkAck c c
|
||||
it "should acknowledge file chunk reception (2 clients)" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should acknowledge file chunk reception (2 clients)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \s -> testXFTPClient $ \r -> runRight_ $ runTestFileChunkAck s r
|
||||
it "should not allow chunks of wrong size" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should not allow chunks of wrong size" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient runTestWrongChunkSize
|
||||
it "should expire chunks after set interval" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should expire chunks after set interval" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}) $
|
||||
testXFTPClient $ \c -> runRight_ $ runTestFileChunkExpiration c
|
||||
it "should disconnect inactive clients" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should disconnect inactive clients" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}) $
|
||||
runRight_ runTestInactiveClientExpiration
|
||||
it "should not allow uploading chunks after specified storage quota" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should not allow uploading chunks after specified storage quota" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {fileSizeQuota = Just $ chSize * 2}) $
|
||||
testXFTPClient $ \c -> runRight_ $ runTestFileStorageQuota c
|
||||
describe "XFTP basic auth" $ do
|
||||
it "prohibited without basic auth" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "prohibited without basic auth" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Just "pwd"}) $
|
||||
testXFTPClient $ runTestFileBasicAuth Nothing False
|
||||
it "prohibited when auth is incorrect" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "prohibited when auth is incorrect" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Just "pwd"}) $
|
||||
testXFTPClient $ runTestFileBasicAuth (Just "wrong") False
|
||||
it "prohibited when FNEW disabled" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "prohibited when FNEW disabled" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = False, newFileBasicAuth = Just "pwd"}) $
|
||||
testXFTPClient $ runTestFileBasicAuth (Just "pwd") False
|
||||
it "allowed with correct basic auth" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "allowed with correct basic auth" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Just "pwd"}) $
|
||||
testXFTPClient $ runTestFileBasicAuth (Just "pwd") True
|
||||
it "allowed with auth on server without auth" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "allowed with auth on server without auth" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Nothing}) $
|
||||
testXFTPClient $ runTestFileBasicAuth (Just "any") True
|
||||
it "should not change content for uploaded and committed files" $ \(withSrv :: XFTPTestBracket) ->
|
||||
it "should not change content for uploaded and committed files" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient runTestFileSkipCommitted
|
||||
|
||||
chSize :: Integral a => a
|
||||
@@ -257,7 +258,7 @@ runTestFileChunkAck s r = do
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testWrongChunkSize :: Expectation
|
||||
testWrongChunkSize = xftpTest $ runTestWrongChunkSize
|
||||
testWrongChunkSize = xftpTest runTestWrongChunkSize
|
||||
|
||||
runTestWrongChunkSize :: XFTPClient -> IO ()
|
||||
runTestWrongChunkSize c = do
|
||||
@@ -479,10 +480,10 @@ runTestFileSkipCommitted c = do
|
||||
runRight_ $ do
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
void . liftIO $ createTestChunk testChunkPath
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
void . liftIO $ createTestChunk testChunkPath -- trash chunk contents
|
||||
uploadXFTPChunk c spKey sId chunkSpec -- upload again to get FROk without getting stuck
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes -- new chunk content got ignored
|
||||
|
||||
-- SNI and CORS tests
|
||||
|
||||
|
||||
Reference in New Issue
Block a user