mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-25 16:22:16 +00:00
refactor: remove dead test wrappers after parameterization
Remove old non-parameterized test wrapper functions that were superseded by the store-backend-parameterized test suites. All test bodies (run* and _ functions) are preserved and called from the parameterized specs. Clean up unused imports.
This commit is contained in:
shum
@@ -33,7 +33,7 @@ import System.Environment (setEnv)
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util
|
||||
import XFTPAgent (xftpAgentTests, xftpAgentFileTests, xftpAgentRestoreTests)
|
||||
import XFTPCLI (xftpCLITests, xftpCLIFileTests)
|
||||
import XFTPCLI (xftpCLIFileTests)
|
||||
import XFTPClient (xftpMemoryBracket, xftpMemoryBracket2, xftpMemoryBracketClear, xftpServerFiles)
|
||||
import XFTPServerTests (xftpServerTests, xftpFileTests)
|
||||
import WebTests (webTests)
|
||||
@@ -156,7 +156,6 @@ main = do
|
||||
describe "XFTP file delivery (memory)" $
|
||||
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
|
||||
|
||||
@@ -38,7 +38,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Protocol (NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
|
||||
@@ -54,44 +54,19 @@ import Fixtures
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
|
||||
#endif
|
||||
|
||||
-- Memory-only tests (version negotiation uses transport-specific server configs)
|
||||
xftpAgentTests :: Spec
|
||||
xftpAgentTests =
|
||||
around_ testBracket
|
||||
#if defined(dbPostgres)
|
||||
. after_ (dropAllSchemasExceptSystem testDBConnectInfo)
|
||||
#endif
|
||||
. describe "agent XFTP API" $ do
|
||||
it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive
|
||||
. describe "agent XFTP API (memory)" $ do
|
||||
-- uncomment CPP option slow_servers and run hpack to run this test
|
||||
xit "should send and receive file with slow server responses" $
|
||||
withXFTPServerCfg testXFTPServerConfig {responseDelay = 500000} $
|
||||
\_ -> testXFTPAgentSendReceive
|
||||
it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted
|
||||
it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect
|
||||
it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect
|
||||
describe "sending and receiving with version negotiation" testXFTPAgentSendReceiveMatrix
|
||||
it "should resume receiving file after restart" testXFTPAgentReceiveRestore
|
||||
it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup
|
||||
it "should resume sending file after restart" testXFTPAgentSendRestore
|
||||
xit'' "should cleanup snd prefix path after permanent error" testXFTPAgentSendCleanup
|
||||
it "should delete sent file on server" testXFTPAgentDelete
|
||||
it "should resume deleting file after restart" testXFTPAgentDeleteRestore
|
||||
-- TODO when server is fixed to correctly send AUTH error, this test has to be modified to expect AUTH error
|
||||
it "if file is deleted on server, should limit retries and continue receiving next file" testXFTPAgentDeleteOnServer
|
||||
it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer
|
||||
it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs
|
||||
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 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" $ 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
|
||||
|
||||
-- Tests that restart the server between steps (restore/cleanup).
|
||||
-- clearStore wipes metadata to simulate "server lost state" for cleanup tests.
|
||||
@@ -201,9 +176,6 @@ testXFTPAgentSendReceive = do
|
||||
rfId <- runRight $ testReceive rcp rfd originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveEncrypted = withXFTPServer testXFTPAgentSendReceiveEncrypted_
|
||||
|
||||
testXFTPAgentSendReceiveEncrypted_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveEncrypted_ = do
|
||||
g <- C.newRandom
|
||||
@@ -225,9 +197,6 @@ testXFTPAgentSendReceiveEncrypted_ = do
|
||||
rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveRedirect = withXFTPServer testXFTPAgentSendReceiveRedirect_
|
||||
|
||||
testXFTPAgentSendReceiveRedirect_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveRedirect_ = do
|
||||
--- sender
|
||||
@@ -286,9 +255,6 @@ testXFTPAgentSendReceiveRedirect_ = do
|
||||
inBytes <- B.readFile filePathIn
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
|
||||
testXFTPAgentSendReceiveNoRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveNoRedirect = withXFTPServer testXFTPAgentSendReceiveNoRedirect_
|
||||
|
||||
testXFTPAgentSendReceiveNoRedirect_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveNoRedirect_ = do
|
||||
--- sender
|
||||
@@ -457,50 +423,6 @@ testXFTPAgentReceiveRestore_ withSrv = do
|
||||
threadDelay 100000
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentReceiveRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveRestore = do
|
||||
filePath <- createRandomFile
|
||||
|
||||
rfd <- withXFTPServerStoreLogOn $ \_ ->
|
||||
-- send file
|
||||
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 -- wait for worker attempt
|
||||
pure rfId
|
||||
|
||||
[prefixDir] <- listDirectory recipientFiles
|
||||
let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
|
||||
doesDirectoryExist tmpPath `shouldReturn` True
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ ->
|
||||
-- receive file - should start downloading with server up
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
("", rfId', RFPROG _ _) <- rfGet rcp'
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
threadDelay 100000
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ ->
|
||||
-- receive file - should continue downloading with server up
|
||||
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
|
||||
-- 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
|
||||
@@ -532,37 +454,6 @@ testXFTPAgentReceiveCleanup_ withSrv clearStore = withGlobalLogging logCfgNoLogs
|
||||
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
rfd <- withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- send file
|
||||
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 -- wait for worker attempt
|
||||
pure rfId
|
||||
|
||||
[prefixDir] <- listDirectory recipientFiles
|
||||
let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
|
||||
doesDirectoryExist tmpPath `shouldReturn` True
|
||||
|
||||
withXFTPServerThreadOn $ \_ ->
|
||||
-- receive file - should fail with AUTH error
|
||||
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
|
||||
|
||||
-- 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
|
||||
@@ -606,53 +497,6 @@ testXFTPAgentSendRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
withAgent 4 agentCfg initAgentServers testDB2 $ \rcp ->
|
||||
runRight_ . void $ testReceive rcp rfd1 filePath
|
||||
|
||||
testXFTPAgentSendRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentSendRestore = 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 -- wait for worker to encrypt and attempt to create file
|
||||
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
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ ->
|
||||
-- send file - should start uploading with server up
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
("", sfId', SFPROG _ _) <- sfGet sndr'
|
||||
liftIO $ sfId' `shouldBe` sfId
|
||||
|
||||
threadDelay 200000
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- send file - should continue uploading with server up
|
||||
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
|
||||
|
||||
-- prefix path should be removed after sending file
|
||||
threadDelay 500000
|
||||
doesDirectoryExist prefixPath `shouldReturn` False
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
|
||||
-- receive file
|
||||
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
|
||||
@@ -685,44 +529,6 @@ testXFTPAgentSendCleanup_ withSrv clearStore = withGlobalLogging logCfgNoLogs $
|
||||
doesDirectoryExist prefixPath `shouldReturn` False
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentSendCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
sfId <- withXFTPServerStoreLogOn $ \_ ->
|
||||
-- send file
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
xftpStartWorkers sndr (Just senderFiles)
|
||||
sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
|
||||
-- wait for progress events for 5 out of 6 chunks - at this point all chunks should be created on the server
|
||||
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
|
||||
|
||||
withXFTPServerThreadOn $ \_ ->
|
||||
-- send file - should fail with AUTH error
|
||||
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
|
||||
|
||||
-- prefix path should be removed after permanent error
|
||||
doesDirectoryExist prefixPath `shouldReturn` False
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentDelete :: HasCallStack => IO ()
|
||||
testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServer testXFTPAgentDelete_
|
||||
|
||||
testXFTPAgentDelete_ :: HasCallStack => IO ()
|
||||
testXFTPAgentDelete_ = do
|
||||
filePath <- createRandomFile
|
||||
@@ -787,48 +593,6 @@ testXFTPAgentDeleteRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
|
||||
testXFTPAgentDeleteRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
(sfId, sndDescr, rfd2) <- withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- 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 ->
|
||||
runRight_ . void $ testReceive rcp1 rfd1 filePath
|
||||
pure (sfId, sndDescr, rfd2)
|
||||
|
||||
-- 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 -- wait for worker attempt
|
||||
threadDelay 300000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- delete file - should succeed with server up
|
||||
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 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)) <-
|
||||
rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
|
||||
testXFTPAgentDeleteOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServer testXFTPAgentDeleteOnServer_
|
||||
|
||||
testXFTPAgentDeleteOnServer_ :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteOnServer_ = do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
@@ -866,13 +630,6 @@ testXFTPAgentDeleteOnServer_ = do
|
||||
-- receive file 2
|
||||
testReceive' rcp rfd2 filePath2
|
||||
|
||||
testXFTPAgentExpiredOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServerCfg testXFTPServerConfig {fileExpiration = Just fastExpiration} $ \_ ->
|
||||
testXFTPAgentExpiredOnServer_
|
||||
where
|
||||
fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1}
|
||||
|
||||
testXFTPAgentExpiredOnServer_ :: HasCallStack => IO ()
|
||||
testXFTPAgentExpiredOnServer_ = do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
@@ -910,9 +667,6 @@ testXFTPAgentExpiredOnServer_ = do
|
||||
-- receive file 2 successfully
|
||||
runRight_ . void $ testReceive' rcp rfd2 filePath2
|
||||
|
||||
testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO ()
|
||||
testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer testXFTPAgentRequestAdditionalRecipientIDs_
|
||||
|
||||
testXFTPAgentRequestAdditionalRecipientIDs_ :: HasCallStack => IO ()
|
||||
testXFTPAgentRequestAdditionalRecipientIDs_ = do
|
||||
filePath <- createRandomFile
|
||||
@@ -938,11 +692,6 @@ testXFTPAgentRequestAdditionalRecipientIDs_ = do
|
||||
void $ testReceive rcp (rfds !! 299) filePath
|
||||
void $ testReceive rcp (rfds !! 499) filePath
|
||||
|
||||
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testXFTPServerTest newFileBasicAuth srv =
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
|
||||
testXFTPServerTest_ srv
|
||||
|
||||
testXFTPServerTest_ :: HasCallStack => XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testXFTPServerTest_ srv =
|
||||
-- initially passed server is not running
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module XFTPCLI (xftpCLITests, xftpCLIFileTests, xftpCLI, senderFiles, recipientFiles, testBracket) where
|
||||
module XFTPCLI (xftpCLIFileTests, xftpCLI, senderFiles, recipientFiles, testBracket) where
|
||||
|
||||
import Control.Exception (bracket_)
|
||||
import qualified Data.ByteString as LB
|
||||
@@ -11,14 +11,7 @@ import System.FilePath ((</>))
|
||||
import System.IO.Silently (capture_)
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util
|
||||
import XFTPClient (XFTPTestBracket (..), testXFTPServerStr, testXFTPServerStr2, withXFTPServer, withXFTPServer2, xftpServerFiles, xftpServerFiles2)
|
||||
|
||||
xftpCLITests :: Spec
|
||||
xftpCLITests = around_ testBracket . describe "XFTP CLI" $ do
|
||||
it "should send and receive file" testXFTPCLISendReceive
|
||||
it "should send and receive file with 2 servers" testXFTPCLISendReceive2servers
|
||||
it "should delete file from 2 servers" testXFTPCLIDelete
|
||||
it "prepareChunkSizes should use 2 chunk sizes" testPrepareChunkSizes
|
||||
import XFTPClient (XFTPTestBracket (..), testXFTPServerStr, testXFTPServerStr2, xftpServerFiles, xftpServerFiles2)
|
||||
|
||||
xftpCLIFileTests :: SpecWith (XFTPTestBracket, XFTPTestBracket)
|
||||
xftpCLIFileTests = around_ testBracket $ do
|
||||
@@ -47,9 +40,6 @@ recipientFiles = "tests/tmp/xftp-recipient-files"
|
||||
xftpCLI :: [String] -> IO [String]
|
||||
xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI)
|
||||
|
||||
testXFTPCLISendReceive :: IO ()
|
||||
testXFTPCLISendReceive = withXFTPServer testXFTPCLISendReceive_
|
||||
|
||||
testXFTPCLISendReceive_ :: IO ()
|
||||
testXFTPCLISendReceive_ = do
|
||||
let filePath = senderFiles </> "testfile"
|
||||
@@ -86,9 +76,6 @@ testXFTPCLISendReceive_ = do
|
||||
recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
|
||||
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
|
||||
|
||||
testXFTPCLISendReceive2servers :: IO ()
|
||||
testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ testXFTPCLISendReceive2servers_
|
||||
|
||||
testXFTPCLISendReceive2servers_ :: IO ()
|
||||
testXFTPCLISendReceive2servers_ = do
|
||||
let filePath = senderFiles </> "testfile"
|
||||
@@ -127,9 +114,6 @@ testXFTPCLISendReceive2servers_ = do
|
||||
recvResult `shouldBe` ["File description " <> fd <> " is deleted."]
|
||||
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
|
||||
|
||||
testXFTPCLIDelete :: IO ()
|
||||
testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ testXFTPCLIDelete_
|
||||
|
||||
testXFTPCLIDelete_ :: IO ()
|
||||
testXFTPCLIDelete_ = do
|
||||
let filePath = senderFiles </> "testfile"
|
||||
|
||||
@@ -94,36 +94,6 @@ clearXFTPPostgresStore = do
|
||||
PSQL.close conn
|
||||
#endif
|
||||
|
||||
-- Original test helpers (memory backend)
|
||||
|
||||
xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation
|
||||
xftpTest test = runXFTPTest test `shouldReturn` ()
|
||||
|
||||
xftpTestN :: HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> Expectation
|
||||
xftpTestN n test = runXFTPTestN n test `shouldReturn` ()
|
||||
|
||||
xftpTest2 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> Expectation
|
||||
xftpTest2 test = xftpTestN 2 _test
|
||||
where
|
||||
_test [h1, h2] = test h1 h2
|
||||
_test _ = error "expected 2 handles"
|
||||
|
||||
xftpTest4 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> Expectation
|
||||
xftpTest4 test = xftpTestN 4 _test
|
||||
where
|
||||
_test [h1, h2, h3, h4] = test h1 h2 h3 h4
|
||||
_test _ = error "expected 4 handles"
|
||||
|
||||
runXFTPTest :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
|
||||
runXFTPTest test = withXFTPServer $ testXFTPClient test
|
||||
|
||||
runXFTPTestN :: forall a. HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO a) -> IO a
|
||||
runXFTPTestN nClients test = withXFTPServer $ run nClients []
|
||||
where
|
||||
run :: Int -> [XFTPClient] -> IO a
|
||||
run 0 hs = test hs
|
||||
run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
|
||||
|
||||
-- Core server bracket (store-parameterized)
|
||||
|
||||
withXFTPServerCfg_ :: (HasCallStack, FileStoreClass s) => XFTPStoreConfig s -> XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
@@ -146,12 +116,6 @@ withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile
|
||||
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
|
||||
|
||||
withXFTPServer :: HasCallStack => IO a -> IO a
|
||||
withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const
|
||||
|
||||
withXFTPServer2 :: HasCallStack => IO a -> IO a
|
||||
withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig2 . const
|
||||
|
||||
-- Constants
|
||||
|
||||
xftpTestPort :: ServiceName
|
||||
|
||||
@@ -52,30 +52,11 @@ import UnliftIO.STM
|
||||
import Util
|
||||
import XFTPClient
|
||||
|
||||
-- Memory-only tests (store log persistence and SNI/CORS transport tests)
|
||||
xftpServerTests :: Spec
|
||||
xftpServerTests =
|
||||
before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $ do
|
||||
describe "XFTP file chunk delivery" $ do
|
||||
it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
|
||||
it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
|
||||
it "should create, add recipients, upload and receive file chunk" testFileChunkDeliveryAddRecipients
|
||||
it "should delete file chunk (1 client)" testFileChunkDelete
|
||||
it "should delete file chunk (2 clients)" testFileChunkDelete2
|
||||
it "should acknowledge file chunk reception (1 client)" testFileChunkAck
|
||||
it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
|
||||
it "should not allow chunks of wrong size" testWrongChunkSize
|
||||
it "should expire chunks after set interval" testFileChunkExpiration
|
||||
it "should disconnect inactive clients" testInactiveClientExpiration
|
||||
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
|
||||
it "allowed with correct basic auth" $ testFileBasicAuth True (Just "pwd") (Just "pwd") True
|
||||
it "allowed with auth on server without auth" $ testFileBasicAuth True Nothing (Just "any") True
|
||||
it "should not change content for uploaded and committed files" testFileSkipCommitted
|
||||
it "should store file records to log and restore them after server restart" testFileLog
|
||||
describe "XFTP SNI and CORS" $ do
|
||||
it "should select web certificate when SNI is used" testSNICertSelection
|
||||
it "should select XFTP certificate when SNI is not used" testNoSNICertSelection
|
||||
@@ -151,12 +132,6 @@ createTestChunk fp = do
|
||||
readChunk :: XFTPFileId -> IO ByteString
|
||||
readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
|
||||
|
||||
testFileChunkDelivery :: Expectation
|
||||
testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
|
||||
|
||||
testFileChunkDelivery2 :: Expectation
|
||||
testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r
|
||||
|
||||
runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkDelivery s r = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -177,9 +152,6 @@ runTestFileChunkDelivery s r = do
|
||||
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
|
||||
testFileChunkDeliveryAddRecipients :: Expectation
|
||||
testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ runTestFileChunkDeliveryAddRecipients s r1 r2 r3
|
||||
|
||||
runTestFileChunkDeliveryAddRecipients :: XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkDeliveryAddRecipients s r1 r2 r3 = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -201,12 +173,6 @@ runTestFileChunkDeliveryAddRecipients s r1 r2 r3 = do
|
||||
testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2"
|
||||
testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3"
|
||||
|
||||
testFileChunkDelete :: Expectation
|
||||
testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
|
||||
|
||||
testFileChunkDelete2 :: Expectation
|
||||
testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r
|
||||
|
||||
runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkDelete s r = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -230,12 +196,6 @@ runTestFileChunkDelete s r = do
|
||||
deleteXFTPChunk s spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testFileChunkAck :: Expectation
|
||||
testFileChunkAck = xftpTest $ \c -> runRight_ $ runTestFileChunkAck c c
|
||||
|
||||
testFileChunkAck2 :: Expectation
|
||||
testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
|
||||
|
||||
runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkAck s r = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -257,9 +217,6 @@ runTestFileChunkAck s r = do
|
||||
ackXFTPChunk r rpKey rId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testWrongChunkSize :: Expectation
|
||||
testWrongChunkSize = xftpTest runTestWrongChunkSize
|
||||
|
||||
runTestWrongChunkSize :: XFTPClient -> IO ()
|
||||
runTestWrongChunkSize c = do
|
||||
g <- C.newRandom
|
||||
@@ -272,12 +229,6 @@ runTestWrongChunkSize c = do
|
||||
void (createXFTPChunk c spKey file [rcvKey] Nothing)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
|
||||
|
||||
testFileChunkExpiration :: Expectation
|
||||
testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration = shortExpiration} $
|
||||
\_ -> testXFTPClient $ \c -> runRight_ $ runTestFileChunkExpiration c
|
||||
where
|
||||
shortExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
|
||||
runTestFileChunkExpiration :: XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkExpiration c = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -297,12 +248,6 @@ runTestFileChunkExpiration c = do
|
||||
deleteXFTPChunk c spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testInactiveClientExpiration :: Expectation
|
||||
testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration = shortInactiveExpiration} $ \_ ->
|
||||
runRight_ runTestInactiveClientExpiration
|
||||
where
|
||||
shortInactiveExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
|
||||
runTestInactiveClientExpiration :: ExceptT XFTPClientError IO ()
|
||||
runTestInactiveClientExpiration = do
|
||||
disconnected <- newEmptyTMVarIO
|
||||
@@ -317,10 +262,6 @@ runTestInactiveClientExpiration = do
|
||||
threadDelay 3000000
|
||||
atomically (tryTakeTMVar disconnected) `shouldReturn` Just ()
|
||||
|
||||
testFileStorageQuota :: Expectation
|
||||
testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $
|
||||
\_ -> testXFTPClient $ \c -> runRight_ $ runTestFileStorageQuota c
|
||||
|
||||
runTestFileStorageQuota :: XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileStorageQuota c = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -438,11 +379,6 @@ testFileLog = do
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
|
||||
testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> IO ()
|
||||
testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success =
|
||||
withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $
|
||||
\_ -> testXFTPClient $ \c -> runTestFileBasicAuth clntAuth success c
|
||||
|
||||
runTestFileBasicAuth :: Maybe BasicAuth -> Bool -> XFTPClient -> IO ()
|
||||
runTestFileBasicAuth clntAuth success c = do
|
||||
g <- C.newRandom
|
||||
@@ -463,11 +399,6 @@ runTestFileBasicAuth clntAuth success c = do
|
||||
void (createXFTPChunk c spKey file [rcvKey] clntAuth)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testFileSkipCommitted :: IO ()
|
||||
testFileSkipCommitted =
|
||||
withXFTPServerCfg testXFTPServerConfig $
|
||||
\_ -> testXFTPClient runTestFileSkipCommitted
|
||||
|
||||
runTestFileSkipCommitted :: XFTPClient -> IO ()
|
||||
runTestFileSkipCommitted c = do
|
||||
g <- C.newRandom
|
||||
|
||||
Reference in New Issue
Block a user