diff --git a/tests/Test.hs b/tests/Test.hs index c795be770..df503c025 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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 diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 129d5b3da..1e58f1e65 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -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 diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs index 3e21a8a2c..2b16e5206 100644 --- a/tests/XFTPCLI.hs +++ b/tests/XFTPCLI.hs @@ -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" diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 6773a91ec..8f03e9651 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -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 diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 13ea74f00..bf9616269 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -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