mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-12 08:04:47 +00:00
refactor: minimize diff in tests
Restore xftpServerTests and xftpAgentTests bodies to match master byte-for-byte (only type signatures change for XFTPTestBracket parameterization); inline the runTestXXX helpers that were split on this branch.
This commit is contained in:
shum
+8
-19
@@ -32,10 +32,10 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
|
||||
import System.Environment (setEnv)
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util
|
||||
import XFTPAgent (xftpAgentTests, xftpAgentFileTests, xftpAgentRestoreTests)
|
||||
import XFTPAgent
|
||||
import XFTPCLI (xftpCLIFileTests)
|
||||
import XFTPClient (xftpMemoryBracket, xftpMemoryBracket2, xftpMemoryBracketClear, xftpServerFiles)
|
||||
import XFTPServerTests (xftpServerTests, xftpFileTests)
|
||||
import XFTPClient (xftpMemoryBracket, xftpMemoryBracket2)
|
||||
import XFTPServerTests (xftpServerTests)
|
||||
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, xftpPostgresBracket2, xftpPostgresBracketClear)
|
||||
import XFTPClient (testXFTPDBConnectInfo, xftpPostgresBracket, xftpPostgresBracket2)
|
||||
#endif
|
||||
|
||||
#if defined(dbPostgres) || defined(dbServerPostgres)
|
||||
@@ -151,29 +151,18 @@ main = do
|
||||
describe "SMP proxy, jornal message store" $
|
||||
before (pure $ ASType SQSMemory SMSJournal) smpProxyTests
|
||||
describe "XFTP" $ do
|
||||
describe "XFTP server" xftpServerTests
|
||||
before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $
|
||||
describe "XFTP file delivery (memory)" $
|
||||
before (pure xftpMemoryBracket) xftpFileTests
|
||||
describe "XFTP server" $
|
||||
before (pure xftpMemoryBracket) xftpServerTests
|
||||
describe "XFTP file description" fileDescriptionTests
|
||||
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
|
||||
describe "XFTP migration round-trip" xftpMigrationTests
|
||||
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 server (PostgreSQL)" $
|
||||
before (pure xftpPostgresBracket) xftpServerTests
|
||||
describe "XFTP CLI (PostgreSQL)" $
|
||||
before (pure (xftpPostgresBracket, xftpPostgresBracket2)) xftpCLIFileTests
|
||||
#endif
|
||||
|
||||
+175
-189
@@ -8,7 +8,7 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module XFTPAgent (xftpAgentTests, xftpAgentFileTests, xftpAgentRestoreTests) where
|
||||
module XFTPAgent where
|
||||
|
||||
import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent)
|
||||
|
||||
@@ -27,6 +27,7 @@ import Simplex.FileTransfer.Client (XFTPClientConfig (..))
|
||||
import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription)
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
|
||||
import Simplex.FileTransfer.Server.Store (STMFileStore)
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
|
||||
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
|
||||
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
|
||||
@@ -38,7 +39,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 (NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
|
||||
@@ -54,85 +55,51 @@ 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 (memory)" $ do
|
||||
. describe "agent XFTP API" $ do
|
||||
it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive
|
||||
-- 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
|
||||
|
||||
-- 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_
|
||||
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" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {xftpPort = xftpTestPort2}) $
|
||||
testXFTPServerTest_ (noAuthSrv testXFTPServer2) `shouldReturn` Nothing
|
||||
it "should pass without basic auth" $ testXFTPServerTest Nothing (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)
|
||||
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" $ \(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
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
rfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
|
||||
rfProgress c expected = loop 0
|
||||
@@ -176,8 +143,8 @@ testXFTPAgentSendReceive = do
|
||||
rfId <- runRight $ testReceive rcp rfd originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveEncrypted_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveEncrypted_ = do
|
||||
testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
|
||||
g <- C.newRandom
|
||||
filePath <- createRandomFile
|
||||
s <- LB.readFile filePath
|
||||
@@ -197,8 +164,8 @@ testXFTPAgentSendReceiveEncrypted_ = do
|
||||
rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveRedirect_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveRedirect_ = do
|
||||
testXFTPAgentSendReceiveRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
|
||||
--- sender
|
||||
filePathIn <- createRandomFile
|
||||
let fileSize = mb 17
|
||||
@@ -255,8 +222,8 @@ testXFTPAgentSendReceiveRedirect_ = do
|
||||
inBytes <- B.readFile filePathIn
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
|
||||
testXFTPAgentSendReceiveNoRedirect_ :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveNoRedirect_ = do
|
||||
testXFTPAgentSendReceiveNoRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
|
||||
--- sender
|
||||
let fileSize = mb 5
|
||||
filePathIn <- createRandomFile_ fileSize "testfile"
|
||||
@@ -313,7 +280,7 @@ testXFTPAgentSendReceiveMatrix = do
|
||||
newClient = agentCfg
|
||||
oldServer = withXFTPServerCfgNoALPN
|
||||
newServer = withXFTPServerCfg
|
||||
run :: HasCallStack => (HasCallStack => XFTPServerConfig -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO ()
|
||||
run :: HasCallStack => (HasCallStack => XFTPServerConfig STMFileStore -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO ()
|
||||
run withServer sender receiver =
|
||||
withServer testXFTPServerConfig $ \_t -> do
|
||||
filePath <- createRandomFile_ (kb 319 :: Integer) "testfile"
|
||||
@@ -383,11 +350,12 @@ 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
|
||||
testXFTPAgentReceiveRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveRestore = do
|
||||
filePath <- createRandomFile
|
||||
|
||||
rfd <- withSrv id $
|
||||
rfd <- withXFTPServerStoreLogOn $ \_ ->
|
||||
-- send file
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(_, _, rfd, _) <- testSend sndr filePath
|
||||
pure rfd
|
||||
@@ -396,21 +364,23 @@ testXFTPAgentReceiveRestore_ withSrv = do
|
||||
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
|
||||
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
|
||||
|
||||
withSrv id $
|
||||
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
|
||||
|
||||
withSrv id $
|
||||
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
|
||||
@@ -421,13 +391,15 @@ testXFTPAgentReceiveRestore_ withSrv = do
|
||||
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
|
||||
testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
rfd <- withSrv id $
|
||||
rfd <- withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- send file
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(_, _, rfd, _) <- testSend sndr filePath
|
||||
pure rfd
|
||||
@@ -436,33 +408,32 @@ testXFTPAgentReceiveCleanup_ withSrv clearStore = withGlobalLogging logCfgNoLogs
|
||||
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
|
||||
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
|
||||
|
||||
-- wipe server metadata so file is gone
|
||||
clearStore
|
||||
|
||||
withSrv id $
|
||||
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
|
||||
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
|
||||
liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing -- wait for worker to encrypt and attempt to create file
|
||||
pure sfId
|
||||
|
||||
dirEntries <- listDirectory senderFiles
|
||||
@@ -472,7 +443,8 @@ testXFTPAgentSendRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
doesDirectoryExist prefixPath `shouldReturn` True
|
||||
doesFileExist encPath `shouldReturn` True
|
||||
|
||||
withSrv id $
|
||||
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'
|
||||
@@ -480,7 +452,8 @@ testXFTPAgentSendRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
|
||||
threadDelay 200000
|
||||
|
||||
withSrv id $ do
|
||||
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
|
||||
@@ -490,21 +463,25 @@ testXFTPAgentSendRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
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
|
||||
testXFTPAgentSendCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
sfId <- withSrv id $
|
||||
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 ()
|
||||
@@ -517,56 +494,60 @@ testXFTPAgentSendCleanup_ withSrv clearStore = withGlobalLogging logCfgNoLogs $
|
||||
doesDirectoryExist prefixPath `shouldReturn` True
|
||||
doesFileExist encPath `shouldReturn` True
|
||||
|
||||
clearStore
|
||||
|
||||
withSrv id $
|
||||
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_ = do
|
||||
filePath <- createRandomFile
|
||||
testXFTPAgentDelete :: HasCallStack => IO ()
|
||||
testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServer $ 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
|
||||
-- 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 => 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)
|
||||
@@ -575,17 +556,19 @@ testXFTPAgentDeleteRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
withAgent 3 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
||||
xftpDeleteSndFileRemote sndr 1 sfId sndDescr
|
||||
timeout 300000 (get sndr) `shouldReturn` Nothing
|
||||
timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt
|
||||
threadDelay 300000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
withSrv id $ do
|
||||
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
|
||||
@@ -593,82 +576,85 @@ testXFTPAgentDeleteRestore_ withSrv = withGlobalLogging logCfgNoLogs $ do
|
||||
rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
|
||||
testXFTPAgentDeleteOnServer_ :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteOnServer_ = do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
testXFTPAgentDeleteOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServer $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
|
||||
-- delete file 1 on server from file system
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
-- delete file 1 on server from file system
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
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'
|
||||
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
|
||||
-- receive file 2
|
||||
testReceive' rcp rfd2 filePath2
|
||||
|
||||
testXFTPAgentExpiredOnServer_ :: HasCallStack => IO ()
|
||||
testXFTPAgentExpiredOnServer_ = do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
testXFTPAgentExpiredOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
|
||||
let fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1}
|
||||
withXFTPServerCfg testXFTPServerConfig {fileExpiration = Just fastExpiration} . const $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
-- send file 1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
-- receive file 1 successfully
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
runRight_ . void $ testReceive rcp rfd1_1 filePath1
|
||||
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
serverFiles <- listDirectory xftpServerFiles
|
||||
length serverFiles `shouldBe` 6
|
||||
|
||||
-- wait until file 1 expires on server
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
-- wait until file 1 expires on server
|
||||
forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
|
||||
|
||||
threadDelay 3500000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
threadDelay 3500000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
-- 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
|
||||
-- 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
|
||||
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
-- create and send file 2
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
(_, _, rfd2, _) <- runRight $ testSend sndr filePath2
|
||||
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
-- receive file 2 successfully
|
||||
runRight_ . void $ testReceive' rcp rfd2 filePath2
|
||||
-- receive file 2 successfully
|
||||
runRight_ . void $ testReceive' rcp rfd2 filePath2
|
||||
|
||||
testXFTPAgentRequestAdditionalRecipientIDs_ :: HasCallStack => IO ()
|
||||
testXFTPAgentRequestAdditionalRecipientIDs_ = do
|
||||
testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO ()
|
||||
testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
-- send file
|
||||
|
||||
+44
-22
@@ -19,7 +19,7 @@ import Simplex.FileTransfer.Client
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Server (runXFTPServerBlocking)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig (..), defaultFileExpiration, defaultInactiveClientExpiration)
|
||||
import Simplex.FileTransfer.Server.Store (FileStoreClass)
|
||||
import Simplex.FileTransfer.Server.Store (FileStoreClass, STMFileStore)
|
||||
import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
|
||||
import Simplex.Messaging.Protocol (XFTPServer)
|
||||
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
||||
@@ -36,24 +36,24 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
||||
-- Parameterized server bracket
|
||||
|
||||
newtype XFTPTestBracket = XFTPTestBracket
|
||||
{ runBracket :: forall a. (XFTPServerConfig -> XFTPServerConfig) -> IO a -> IO a
|
||||
{ runBracket :: forall a. (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> 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
|
||||
xftpMemoryBracket = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg (cfgF testXFTPServerConfig) $ \_ -> test
|
||||
|
||||
xftpMemoryBracketWithLog :: XFTPTestBracket
|
||||
xftpMemoryBracketWithLog = XFTPTestBracket $ \cfgF test ->
|
||||
withXFTPServerCfg (cfgF testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}) $ \_ -> test
|
||||
withXFTPServerCfg (cfgF testXFTPServerConfig {serverStoreCfg = XSCMemory (Just testXFTPLogFile), 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
|
||||
xftpMemoryBracket2 = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg (cfgF testXFTPServerConfig2) $ \_ -> test
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
testXFTPDBConnectInfo :: ConnectInfo
|
||||
@@ -77,10 +77,10 @@ testXFTPPostgresCfg =
|
||||
}
|
||||
|
||||
xftpPostgresBracket :: XFTPTestBracket
|
||||
xftpPostgresBracket = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg_ (XSCDatabase testXFTPPostgresCfg) (cfgF testXFTPServerConfig) $ \_ -> test
|
||||
xftpPostgresBracket = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg (cfgF testXFTPServerConfig {serverStoreCfg = XSCDatabase testXFTPPostgresCfg}) $ \_ -> test
|
||||
|
||||
xftpPostgresBracket2 :: XFTPTestBracket
|
||||
xftpPostgresBracket2 = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg_ (XSCDatabase testXFTPPostgresCfg) (cfgF testXFTPServerConfig2) $ \_ -> test
|
||||
xftpPostgresBracket2 = XFTPTestBracket $ \cfgF test -> withXFTPServerCfg (cfgF testXFTPServerConfig2 {serverStoreCfg = XSCDatabase testXFTPPostgresCfg}) $ \_ -> test
|
||||
|
||||
xftpPostgresBracketClear :: XFTPTestBracketClear
|
||||
xftpPostgresBracketClear = (xftpPostgresBracket, clearXFTPPostgresStore)
|
||||
@@ -94,24 +94,45 @@ clearXFTPPostgresStore = do
|
||||
PSQL.close conn
|
||||
#endif
|
||||
|
||||
-- Core server bracket (store-parameterized)
|
||||
xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> XFTPTestBracket -> Expectation
|
||||
xftpTest test (XFTPTestBracket withSrv) = withSrv id (testXFTPClient test) `shouldReturn` ()
|
||||
|
||||
withXFTPServerCfg_ :: (HasCallStack, FileStoreClass s) => XFTPStoreConfig s -> XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfg_ storeCfg cfg =
|
||||
xftpTestN :: HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> XFTPTestBracket -> Expectation
|
||||
xftpTestN nClients test (XFTPTestBracket withSrv) = withSrv id (run nClients []) `shouldReturn` ()
|
||||
where
|
||||
run :: Int -> [XFTPClient] -> IO ()
|
||||
run 0 hs = test hs
|
||||
run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs)
|
||||
|
||||
xftpTest2 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> XFTPTestBracket -> 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 ()) -> XFTPTestBracket -> Expectation
|
||||
xftpTest4 test = xftpTestN 4 _test
|
||||
where
|
||||
_test [h1, h2, h3, h4] = test h1 h2 h3 h4
|
||||
_test _ = error "expected 4 handles"
|
||||
|
||||
withXFTPServerCfg :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfg cfg =
|
||||
serverBracket
|
||||
(\started -> runXFTPServerBlocking started storeCfg cfg)
|
||||
(\started -> runXFTPServerBlocking started 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 :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerCfgNoALPN cfg = withXFTPServerCfg cfg {transportConfig = (transportConfig cfg) {serverALPN = Nothing}}
|
||||
|
||||
withXFTPServer :: HasCallStack => IO a -> IO a
|
||||
withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const
|
||||
|
||||
withXFTPServer2 :: HasCallStack => IO a -> IO a
|
||||
withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const
|
||||
|
||||
withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
|
||||
withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {serverStoreCfg = XSCMemory (Just testXFTPLogFile), storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile}
|
||||
|
||||
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
|
||||
@@ -151,12 +172,13 @@ testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log"
|
||||
xftpTestPrometheusMetricsFile :: FilePath
|
||||
xftpTestPrometheusMetricsFile = "tests/tmp/xftp-server-metrics.txt"
|
||||
|
||||
testXFTPServerConfig :: XFTPServerConfig
|
||||
testXFTPServerConfig :: XFTPServerConfig STMFileStore
|
||||
testXFTPServerConfig =
|
||||
XFTPServerConfig
|
||||
{ xftpPort = xftpTestPort,
|
||||
controlPort = Nothing,
|
||||
fileIdSize = 16,
|
||||
serverStoreCfg = XSCMemory Nothing,
|
||||
storeLogFile = Nothing,
|
||||
filesPath = xftpServerFiles,
|
||||
fileSizeQuota = Nothing,
|
||||
@@ -187,7 +209,7 @@ testXFTPServerConfig =
|
||||
webStaticPath = Nothing
|
||||
}
|
||||
|
||||
testXFTPServerConfig2 :: XFTPServerConfig
|
||||
testXFTPServerConfig2 :: XFTPServerConfig STMFileStore
|
||||
testXFTPServerConfig2 = testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2}
|
||||
|
||||
testXFTPClientConfig :: XFTPClientConfig
|
||||
@@ -203,7 +225,7 @@ testXFTPClientWith cfg client = do
|
||||
Right c -> client c
|
||||
Left e -> error $ show e
|
||||
|
||||
testXFTPServerConfigSNI :: XFTPServerConfig
|
||||
testXFTPServerConfigSNI :: XFTPServerConfig STMFileStore
|
||||
testXFTPServerConfigSNI =
|
||||
testXFTPServerConfig
|
||||
{ httpCredentials =
|
||||
@@ -222,7 +244,7 @@ testXFTPServerConfigSNI =
|
||||
withXFTPServerSNI :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerSNI = withXFTPServerCfg testXFTPServerConfigSNI
|
||||
|
||||
testXFTPServerConfigEd25519SNI :: XFTPServerConfig
|
||||
testXFTPServerConfigEd25519SNI :: XFTPServerConfig STMFileStore
|
||||
testXFTPServerConfigEd25519SNI =
|
||||
testXFTPServerConfig
|
||||
{ xftpCredentials =
|
||||
|
||||
+141
-138
@@ -6,7 +6,7 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module XFTPServerTests (xftpServerTests, xftpFileTests) where
|
||||
module XFTPServerTests (xftpServerTests) where
|
||||
|
||||
import AgentTests.FunctionalAPITests (runRight_)
|
||||
import Control.Concurrent (threadDelay)
|
||||
@@ -52,12 +52,31 @@ import UnliftIO.STM
|
||||
import Util
|
||||
import XFTPClient
|
||||
|
||||
-- Memory-only tests (store log persistence and SNI/CORS transport tests)
|
||||
xftpServerTests :: Spec
|
||||
xftpServerTests :: SpecWith XFTPTestBracket
|
||||
xftpServerTests =
|
||||
before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $ do
|
||||
it "should store file records to log and restore them after server restart" testFileLog
|
||||
describe "XFTP SNI and CORS" $ 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
|
||||
describe "XFTP SNI and CORS" $ beforeWith (const (pure ())) $ do
|
||||
it "should select web certificate when SNI is used" testSNICertSelection
|
||||
it "should select XFTP certificate when SNI is not used" testNoSNICertSelection
|
||||
it "should add CORS headers when SNI is used" testCORSHeaders
|
||||
@@ -68,54 +87,6 @@ xftpServerTests =
|
||||
it "should re-handshake on same connection with xftp-web-hello header" testWebReHandshake
|
||||
it "should return padded SESSION error for stale web session" testStaleWebSession
|
||||
|
||||
-- Tests parameterized over store backend (memory or PostgreSQL)
|
||||
xftpFileTests :: SpecWith XFTPTestBracket
|
||||
xftpFileTests = do
|
||||
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)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \s -> testXFTPClient $ \r -> runRight_ $ runTestFileChunkDelivery s r
|
||||
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)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \c -> runRight_ $ runTestFileChunkDelete c c
|
||||
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)" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient $ \c -> runRight_ $ runTestFileChunkAck c c
|
||||
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" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient runTestWrongChunkSize
|
||||
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" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}) $
|
||||
runRight_ runTestInactiveClientExpiration
|
||||
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" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Just "pwd"}) $
|
||||
testXFTPClient $ runTestFileBasicAuth Nothing False
|
||||
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" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = False, newFileBasicAuth = Just "pwd"}) $
|
||||
testXFTPClient $ runTestFileBasicAuth (Just "pwd") False
|
||||
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" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Nothing}) $
|
||||
testXFTPClient $ runTestFileBasicAuth (Just "any") True
|
||||
it "should not change content for uploaded and committed files" $ \(XFTPTestBracket withSrv) ->
|
||||
withSrv id $ testXFTPClient runTestFileSkipCommitted
|
||||
|
||||
chSize :: Integral a => a
|
||||
chSize = kb 128
|
||||
|
||||
@@ -132,6 +103,12 @@ createTestChunk fp = do
|
||||
readChunk :: XFTPFileId -> IO ByteString
|
||||
readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
|
||||
|
||||
testFileChunkDelivery :: XFTPTestBracket -> Expectation
|
||||
testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
|
||||
|
||||
testFileChunkDelivery2 :: XFTPTestBracket -> Expectation
|
||||
testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r
|
||||
|
||||
runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkDelivery s r = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -152,8 +129,8 @@ 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
|
||||
|
||||
runTestFileChunkDeliveryAddRecipients :: XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkDeliveryAddRecipients s r1 r2 r3 = do
|
||||
testFileChunkDeliveryAddRecipients :: XFTPTestBracket -> Expectation
|
||||
testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
|
||||
g <- liftIO C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
@@ -173,6 +150,12 @@ runTestFileChunkDeliveryAddRecipients s r1 r2 r3 = do
|
||||
testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2"
|
||||
testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3"
|
||||
|
||||
testFileChunkDelete :: XFTPTestBracket -> Expectation
|
||||
testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
|
||||
|
||||
testFileChunkDelete2 :: XFTPTestBracket -> Expectation
|
||||
testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r
|
||||
|
||||
runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkDelete s r = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -196,6 +179,12 @@ runTestFileChunkDelete s r = do
|
||||
deleteXFTPChunk s spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testFileChunkAck :: XFTPTestBracket -> Expectation
|
||||
testFileChunkAck = xftpTest $ \c -> runRight_ $ runTestFileChunkAck c c
|
||||
|
||||
testFileChunkAck2 :: XFTPTestBracket -> Expectation
|
||||
testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
|
||||
|
||||
runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkAck s r = do
|
||||
g <- liftIO C.newRandom
|
||||
@@ -217,8 +206,8 @@ runTestFileChunkAck s r = do
|
||||
ackXFTPChunk r rpKey rId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
runTestWrongChunkSize :: XFTPClient -> IO ()
|
||||
runTestWrongChunkSize c = do
|
||||
testWrongChunkSize :: XFTPTestBracket -> Expectation
|
||||
testWrongChunkSize = xftpTest $ \c -> do
|
||||
g <- C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, _rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
@@ -229,27 +218,32 @@ runTestWrongChunkSize c = do
|
||||
void (createXFTPChunk c spKey file [rcvKey] Nothing)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
|
||||
|
||||
runTestFileChunkExpiration :: XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkExpiration c = do
|
||||
g <- liftIO C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- liftIO $ createTestChunk testChunkPath
|
||||
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
liftIO $ threadDelay 1000000
|
||||
downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
deleteXFTPChunk c spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
testFileChunkExpiration :: XFTPTestBracket -> Expectation
|
||||
testFileChunkExpiration _ = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $
|
||||
\_ -> testXFTPClient $ \c -> runRight_ $ do
|
||||
g <- liftIO C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- liftIO $ createTestChunk testChunkPath
|
||||
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
|
||||
runTestInactiveClientExpiration :: ExceptT XFTPClientError IO ()
|
||||
runTestInactiveClientExpiration = do
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
|
||||
liftIO $ threadDelay 1000000
|
||||
downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
deleteXFTPChunk c spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
where
|
||||
fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
|
||||
testInactiveClientExpiration :: XFTPTestBracket -> Expectation
|
||||
testInactiveClientExpiration _ = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
|
||||
disconnected <- newEmptyTMVarIO
|
||||
ts <- liftIO getCurrentTime
|
||||
c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> atomically $ putTMVar disconnected ())
|
||||
@@ -261,34 +255,39 @@ runTestInactiveClientExpiration = do
|
||||
liftIO $ do
|
||||
threadDelay 3000000
|
||||
atomically (tryTakeTMVar disconnected) `shouldReturn` Just ()
|
||||
where
|
||||
inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
|
||||
runTestFileStorageQuota :: XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileStorageQuota c = do
|
||||
g <- liftIO C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- liftIO $ createTestChunk testChunkPath
|
||||
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
download rId = do
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
(sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId1 chunkSpec
|
||||
download rId1
|
||||
(sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId2 chunkSpec
|
||||
download rId2
|
||||
(sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId3 chunkSpec
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA))
|
||||
deleteXFTPChunk c spKey sId1
|
||||
uploadXFTPChunk c spKey sId3 chunkSpec
|
||||
download rId3
|
||||
testFileStorageQuota :: XFTPTestBracket -> Expectation
|
||||
testFileStorageQuota _ = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $
|
||||
\_ -> testXFTPClient $ \c -> runRight_ $ do
|
||||
g <- liftIO C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- liftIO $ createTestChunk testChunkPath
|
||||
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
download rId = do
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
(sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId1 chunkSpec
|
||||
download rId1
|
||||
(sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId2 chunkSpec
|
||||
download rId2
|
||||
|
||||
testFileLog :: Expectation
|
||||
testFileLog = do
|
||||
(sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId3 chunkSpec
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA))
|
||||
|
||||
deleteXFTPChunk c spKey sId1
|
||||
uploadXFTPChunk c spKey sId3 chunkSpec
|
||||
download rId3
|
||||
|
||||
testFileLog :: XFTPTestBracket -> Expectation
|
||||
testFileLog _ = do
|
||||
g <- C.newRandom
|
||||
bytes <- liftIO $ createTestChunk testChunkPath
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
@@ -379,42 +378,46 @@ testFileLog = do
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
|
||||
runTestFileBasicAuth :: Maybe BasicAuth -> Bool -> XFTPClient -> IO ()
|
||||
runTestFileBasicAuth clntAuth success c = do
|
||||
g <- C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- createTestChunk testChunkPath
|
||||
digest <- LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
runRight_ $
|
||||
if success
|
||||
then do
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
|
||||
else do
|
||||
void (createXFTPChunk c spKey file [rcvKey] clntAuth)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> XFTPTestBracket -> IO ()
|
||||
testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success _ =
|
||||
withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $
|
||||
\_ -> testXFTPClient $ \c -> do
|
||||
g <- C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- createTestChunk testChunkPath
|
||||
digest <- LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
runRight_ $
|
||||
if success
|
||||
then do
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes
|
||||
else do
|
||||
void (createXFTPChunk c spKey file [rcvKey] clntAuth)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
runTestFileSkipCommitted :: XFTPClient -> IO ()
|
||||
runTestFileSkipCommitted c = do
|
||||
g <- C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- createTestChunk testChunkPath
|
||||
digest <- LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
runRight_ $ do
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
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 -- new chunk content got ignored
|
||||
testFileSkipCommitted :: XFTPTestBracket -> IO ()
|
||||
testFileSkipCommitted _ =
|
||||
withXFTPServerCfg testXFTPServerConfig $
|
||||
\_ -> testXFTPClient $ \c -> do
|
||||
g <- C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- createTestChunk testChunkPath
|
||||
digest <- LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
runRight_ $ do
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
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 -- new chunk content got ignored
|
||||
|
||||
-- SNI and CORS tests
|
||||
|
||||
|
||||
+10
-9
@@ -45,6 +45,7 @@ import System.Process (CreateProcess (..), StdStream (..), createProcess, proc,
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig)
|
||||
import Simplex.FileTransfer.Server.Store (STMFileStore)
|
||||
import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpTestPort)
|
||||
import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent)
|
||||
import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
|
||||
@@ -2854,7 +2855,7 @@ tsIntegrationTests dbCleanup = describe "integration" $
|
||||
it "cross-language: Haskell upload, TS download" $
|
||||
haskellUploadTsDownloadTest testXFTPServerConfigSNI
|
||||
|
||||
webHandshakeTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
webHandshakeTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
webHandshakeTest cfg caFile = do
|
||||
withXFTPServerCfg cfg $ \_ -> do
|
||||
Fingerprint fp <- loadFileFingerprint caFile
|
||||
@@ -2895,7 +2896,7 @@ webHandshakeTest cfg caFile = do
|
||||
<> jsOut "new Uint8Array([idOk ? 1 : 0, ack.length === 0 ? 1 : 0])"
|
||||
result `shouldBe` B.pack [1, 1]
|
||||
|
||||
pingTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
pingTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
pingTest cfg caFile = do
|
||||
withXFTPServerCfg cfg $ \_ -> do
|
||||
Fingerprint fp <- loadFileFingerprint caFile
|
||||
@@ -2917,7 +2918,7 @@ pingTest cfg caFile = do
|
||||
<> jsOut "new Uint8Array([1])"
|
||||
result `shouldBe` B.pack [1]
|
||||
|
||||
fullRoundTripTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
fullRoundTripTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
fullRoundTripTest cfg caFile = do
|
||||
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
||||
withXFTPServerCfg cfg $ \_ -> do
|
||||
@@ -2998,7 +2999,7 @@ agentURIRoundTripTest = do
|
||||
<> jsOut "new Uint8Array([match])"
|
||||
result `shouldBe` B.pack [1]
|
||||
|
||||
agentUploadDownloadTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
agentUploadDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
agentUploadDownloadTest cfg caFile = do
|
||||
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
||||
withXFTPServerCfg cfg $ \_ -> do
|
||||
@@ -3031,7 +3032,7 @@ agentUploadDownloadTest cfg caFile = do
|
||||
<> jsOut "new Uint8Array([nameMatch, sizeMatch, dataMatch])"
|
||||
result `shouldBe` B.pack [1, 1, 1]
|
||||
|
||||
agentDeleteTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
agentDeleteTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
agentDeleteTest cfg caFile = do
|
||||
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
||||
withXFTPServerCfg cfg $ \_ -> do
|
||||
@@ -3063,7 +3064,7 @@ agentDeleteTest cfg caFile = do
|
||||
<> jsOut "new Uint8Array([deleted])"
|
||||
result `shouldBe` B.pack [1]
|
||||
|
||||
agentRedirectTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
agentRedirectTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
agentRedirectTest cfg caFile = do
|
||||
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
||||
withXFTPServerCfg cfg $ \_ -> do
|
||||
@@ -3097,7 +3098,7 @@ agentRedirectTest cfg caFile = do
|
||||
<> jsOut "new Uint8Array([hasRedirect, nameMatch, sizeMatch, dataMatch])"
|
||||
result `shouldBe` B.pack [1, 1, 1, 1]
|
||||
|
||||
tsUploadHaskellDownloadTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
tsUploadHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
tsUploadHaskellDownloadTest cfg caFile = do
|
||||
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
||||
createDirectoryIfMissing False recipientFiles
|
||||
@@ -3132,7 +3133,7 @@ tsUploadHaskellDownloadTest cfg caFile = do
|
||||
downloadedData <- B.readFile outPath
|
||||
downloadedData `shouldBe` originalData
|
||||
|
||||
tsUploadRedirectHaskellDownloadTest :: XFTPServerConfig -> FilePath -> Expectation
|
||||
tsUploadRedirectHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation
|
||||
tsUploadRedirectHaskellDownloadTest cfg caFile = do
|
||||
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
||||
createDirectoryIfMissing False recipientFiles
|
||||
@@ -3167,7 +3168,7 @@ tsUploadRedirectHaskellDownloadTest cfg caFile = do
|
||||
downloadedData <- B.readFile outPath
|
||||
downloadedData `shouldBe` originalData
|
||||
|
||||
haskellUploadTsDownloadTest :: XFTPServerConfig -> Expectation
|
||||
haskellUploadTsDownloadTest :: XFTPServerConfig STMFileStore -> Expectation
|
||||
haskellUploadTsDownloadTest cfg = do
|
||||
createDirectoryIfMissing False "tests/tmp/xftp-server-files"
|
||||
createDirectoryIfMissing False senderFiles
|
||||
|
||||
Reference in New Issue
Block a user