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