mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-28 05:04:40 +00:00
dispose agent instances, fix tests, (#1089)
* dispose agent instances in tests * fix quota test * tests: fix tests with -threaded (#1088) * fix some tests * match RTS opts with apps * less verbose rts stats * enable sqlite extended error codes * clean up * unfocus * remove extendedErrorCode It's actually setExtendedResultCodes, which isn't yet available. * diff --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com> * fix switch test * fix --------- Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
co-authored by
Alexander Bondarenko
Alexander Bondarenko
parent
b994fd9f0f
commit
1219446996
@@ -169,6 +169,11 @@ tests:
|
||||
- silently == 1.2.*
|
||||
- main-tester == 0.2.*
|
||||
- timeit == 2.0.*
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-A64M
|
||||
- -with-rtsopts=-N1
|
||||
|
||||
ghc-options:
|
||||
# - -haddock
|
||||
|
||||
+1
-1
@@ -661,7 +661,7 @@ test-suite simplexmq-test
|
||||
tests
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2
|
||||
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
|
||||
build-depends:
|
||||
HUnit ==1.6.*
|
||||
, QuickCheck ==2.14.*
|
||||
|
||||
@@ -2351,10 +2351,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
|
||||
case L.nonEmpty keepSqs of
|
||||
Just sqs' -> do
|
||||
-- move inside case?
|
||||
withStore' c $ \db -> mapM_ (deleteConnSndQueue db connId) delSqs
|
||||
sq_@SndQueue {sndPublicKey, e2ePubKey} <- lift $ newSndQueue userId connId qInfo
|
||||
let sq'' = (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
sq2 <- withStore c $ \db -> addConnSndQueue db connId sq''
|
||||
sq2 <- withStore c $ \db -> do
|
||||
liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs
|
||||
addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
case (sndPublicKey, e2ePubKey) of
|
||||
(Just sndPubKey, Just dhPublicKey) -> do
|
||||
logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress)
|
||||
|
||||
@@ -133,7 +133,7 @@ import Control.Applicative ((<|>))
|
||||
import Control.Concurrent (ThreadId, forkIO, threadDelay)
|
||||
import Control.Concurrent.Async (Async, uninterruptibleCancel)
|
||||
import Control.Concurrent.STM (retry, throwSTM)
|
||||
import Control.Exception (AsyncException (..))
|
||||
import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
@@ -790,7 +790,7 @@ closeClient c clientSel tSess =
|
||||
closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -> IO ()
|
||||
closeClient_ c v = do
|
||||
NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
|
||||
tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
|
||||
E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
|
||||
Just (Right client) -> closeProtocolServerClient client `catchAll_` pure ()
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
@@ -1214,7 +1214,7 @@ setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
|
||||
db
|
||||
[sql|
|
||||
UPDATE ratchets
|
||||
SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ?
|
||||
SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ?
|
||||
WHERE conn_id = ?
|
||||
|]
|
||||
(x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId)
|
||||
|
||||
+3
-3
@@ -194,8 +194,8 @@ pqMatrix2_ pqInv _ smpTest test = do
|
||||
|
||||
pqMatrix3 ::
|
||||
HasCallStack =>
|
||||
TProxy c ->
|
||||
(HasCallStack => (c -> c -> c -> IO ()) -> Expectation) ->
|
||||
TProxy c ->
|
||||
(HasCallStack => (c -> c -> c -> IO ()) -> Expectation) ->
|
||||
(HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) ->
|
||||
Spec
|
||||
pqMatrix3 _ smpTest test = do
|
||||
@@ -452,7 +452,7 @@ testServerConnectionAfterError t _ = do
|
||||
where
|
||||
server = SMPServer "localhost" testPort2 testKeyHash
|
||||
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
|
||||
withAgent1 = withAgent agentTestPort testDB 0
|
||||
withAgent1 = withAgent agentTestPort testDB 0
|
||||
withAgent2 = withAgent agentTestPort2 testDB2 10
|
||||
withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a
|
||||
withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -17,7 +17,10 @@ import AgentTests.FunctionalAPITests
|
||||
createConnection,
|
||||
exchangeGreetingsMsgId,
|
||||
get,
|
||||
getSMPAgentClient',
|
||||
withAgent,
|
||||
withAgentClients2,
|
||||
withAgentClientsCfgServers2,
|
||||
withAgentClients3,
|
||||
joinConnection,
|
||||
makeConnection,
|
||||
nGet,
|
||||
@@ -47,7 +50,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import NtfClient
|
||||
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer, testNtfServer2)
|
||||
import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
|
||||
import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
|
||||
import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
|
||||
@@ -165,8 +168,7 @@ runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest =
|
||||
|
||||
testNotificationToken :: APNSMockServer -> IO ()
|
||||
testNotificationToken APNSMockServer {apnsQ} = do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
runRight_ $ do
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
|
||||
let tkn = DeviceToken PPApnsTest "abcd"
|
||||
NTRegistered <- registerNtfToken a tkn NMPeriodic
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
|
||||
@@ -179,7 +181,7 @@ testNotificationToken APNSMockServer {apnsQ} = do
|
||||
deleteNtfToken a tkn
|
||||
-- agent deleted this token
|
||||
Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
|
||||
liftIO $ disposeAgentClient a
|
||||
pure ()
|
||||
|
||||
(.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
|
||||
v .-> key = do
|
||||
@@ -193,8 +195,7 @@ testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
|
||||
testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
|
||||
-- setLogLevel LogError -- LogDebug
|
||||
-- withGlobalLogging logCfg $ do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
runRight_ $ do
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
|
||||
let tkn = DeviceToken PPApnsTest "abcd"
|
||||
NTRegistered <- registerNtfToken a tkn NMPeriodic
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
|
||||
@@ -211,15 +212,13 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
|
||||
-- can still use the first verification code, it is the same after decryption
|
||||
verifyNtfToken a tkn nonce verification
|
||||
NTActive <- checkNtfToken a tkn
|
||||
liftIO $ disposeAgentClient a
|
||||
pure ()
|
||||
|
||||
testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
|
||||
testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
|
||||
testNtfTokenSecondRegistration APNSMockServer {apnsQ} =
|
||||
-- setLogLevel LogError -- LogDebug
|
||||
-- withGlobalLogging logCfg $ do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
runRight_ $ do
|
||||
withAgentClients2 $ \a a' -> runRight_ $ do
|
||||
let tkn = DeviceToken PPApnsTest "abcd"
|
||||
NTRegistered <- registerNtfToken a tkn NMPeriodic
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
|
||||
@@ -248,37 +247,34 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
|
||||
-- and the second is active
|
||||
NTActive <- checkNtfToken a' tkn
|
||||
pure ()
|
||||
disposeAgentClient a
|
||||
disposeAgentClient a'
|
||||
|
||||
testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
|
||||
testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
let tkn = DeviceToken PPApnsTest "abcd"
|
||||
ntfData <- withNtfServer t . runRight $ do
|
||||
NTRegistered <- registerNtfToken a tkn NMPeriodic
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
|
||||
atomically $ readTBQueue apnsQ
|
||||
liftIO $ sendApnsResponse APNSRespOk
|
||||
pure ntfData
|
||||
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
|
||||
ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
withNtfServer t . runRight $ do
|
||||
NTRegistered <- registerNtfToken a tkn NMPeriodic
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
|
||||
atomically $ readTBQueue apnsQ
|
||||
liftIO $ sendApnsResponse APNSRespOk
|
||||
pure ntfData
|
||||
-- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
|
||||
threadDelay 1000000
|
||||
disposeAgentClient a
|
||||
a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
|
||||
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
|
||||
-- so that repeat verification happens without restarting the clients, when notification arrives
|
||||
withNtfServer t . runRight_ $ do
|
||||
verification <- ntfData .-> "verification"
|
||||
nonce <- C.cbNonce <$> ntfData .-> "nonce"
|
||||
Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
|
||||
atomically $ readTBQueue apnsQ
|
||||
verification' <- ntfData' .-> "verification"
|
||||
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
|
||||
liftIO $ sendApnsResponse' APNSRespOk
|
||||
verifyNtfToken a' tkn nonce' verification'
|
||||
NTActive <- checkNtfToken a' tkn
|
||||
liftIO $ disposeAgentClient a'
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \a' ->
|
||||
-- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
|
||||
-- so that repeat verification happens without restarting the clients, when notification arrives
|
||||
withNtfServer t . runRight_ $ do
|
||||
verification <- ntfData .-> "verification"
|
||||
nonce <- C.cbNonce <$> ntfData .-> "nonce"
|
||||
Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
|
||||
atomically $ readTBQueue apnsQ
|
||||
verification' <- ntfData' .-> "verification"
|
||||
nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
|
||||
liftIO $ sendApnsResponse' APNSRespOk
|
||||
verifyNtfToken a' tkn nonce' verification'
|
||||
NTActive <- checkNtfToken a' tkn
|
||||
pure ()
|
||||
|
||||
getTestNtfTokenPort :: AgentClient -> AE String
|
||||
getTestNtfTokenPort a =
|
||||
@@ -289,66 +285,62 @@ getTestNtfTokenPort a =
|
||||
testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO ()
|
||||
testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do
|
||||
let tkn = DeviceToken PPApnsTest "abcd"
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB
|
||||
withNtfServerThreadOn t ntfTestPort $ \ntf ->
|
||||
withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do
|
||||
-- register a new token, the agent picks a server and stores its choice
|
||||
NTRegistered <- registerNtfToken a tkn NMPeriodic
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
|
||||
atomically $ readTBQueue apnsQ
|
||||
verification <- ntfData .-> "verification"
|
||||
nonce <- C.cbNonce <$> ntfData .-> "nonce"
|
||||
liftIO $ sendApnsResponse APNSRespOk
|
||||
verifyNtfToken a tkn nonce verification
|
||||
NTActive <- checkNtfToken a tkn
|
||||
-- shut down the "other" server
|
||||
port <- getTestNtfTokenPort a
|
||||
liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf
|
||||
-- still works
|
||||
NTActive <- checkNtfToken a tkn
|
||||
liftIO . killThread $ if port == ntfTestPort then ntf else ntf2
|
||||
-- negative test, the correct server is now gone
|
||||
Left _ <- tryError (checkNtfToken a tkn)
|
||||
pure ()
|
||||
withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
|
||||
withNtfServerThreadOn t ntfTestPort $ \ntf ->
|
||||
withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do
|
||||
-- register a new token, the agent picks a server and stores its choice
|
||||
NTRegistered <- registerNtfToken a tkn NMPeriodic
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
|
||||
atomically $ readTBQueue apnsQ
|
||||
verification <- ntfData .-> "verification"
|
||||
nonce <- C.cbNonce <$> ntfData .-> "nonce"
|
||||
liftIO $ sendApnsResponse APNSRespOk
|
||||
verifyNtfToken a tkn nonce verification
|
||||
NTActive <- checkNtfToken a tkn
|
||||
-- shut down the "other" server
|
||||
port <- getTestNtfTokenPort a
|
||||
liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf
|
||||
-- still works
|
||||
NTActive <- checkNtfToken a tkn
|
||||
liftIO . killThread $ if port == ntfTestPort then ntf else ntf2
|
||||
-- negative test, the correct server is now gone
|
||||
Left _ <- tryError (checkNtfToken a tkn)
|
||||
pure ()
|
||||
|
||||
testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
|
||||
testNtfTokenChangeServers t APNSMockServer {apnsQ} =
|
||||
withNtfServerThreadOn t ntfTestPort $ \ntf -> do
|
||||
tkn1 <- runRight $ do
|
||||
a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
|
||||
tkn <- registerTestToken a "abcd" NMInstant apnsQ
|
||||
NTActive <- checkNtfToken a tkn
|
||||
liftIO $ setNtfServers a [testNtfServer2]
|
||||
NTActive <- checkNtfToken a tkn -- still works on old server
|
||||
liftIO $ disposeAgentClient a
|
||||
pure tkn
|
||||
|
||||
threadDelay 1000000
|
||||
|
||||
a <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
|
||||
runRight_ $ do
|
||||
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
|
||||
NTActive <- checkNtfToken a tkn1
|
||||
liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list
|
||||
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
|
||||
-- trigger token replace
|
||||
tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ
|
||||
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
|
||||
deleteNtfToken a tkn2 -- force server switch
|
||||
Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now
|
||||
getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
|
||||
killThread ntf
|
||||
withNtfServerOn t ntfTestPort2 $ runRight_ $ do
|
||||
tkn <- registerTestToken a "qwer" NMInstant apnsQ
|
||||
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \a -> do
|
||||
runRight_ $ do
|
||||
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
|
||||
NTActive <- checkNtfToken a tkn1
|
||||
liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list
|
||||
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
|
||||
-- trigger token replace
|
||||
tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ
|
||||
getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
|
||||
deleteNtfToken a tkn2 -- force server switch
|
||||
Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now
|
||||
getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
|
||||
killThread ntf
|
||||
withNtfServerOn t ntfTestPort2 $ runRight_ $ do
|
||||
tkn <- registerTestToken a "qwer" NMInstant apnsQ
|
||||
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
|
||||
|
||||
testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
|
||||
testRunNTFServerTests t srv =
|
||||
withNtfServerThreadOn t ntfTestPort $ \ntf -> do
|
||||
a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
r <- testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
|
||||
killThread ntf
|
||||
pure r
|
||||
withNtfServerOn t ntfTestPort $
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
|
||||
|
||||
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
|
||||
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do
|
||||
@@ -383,11 +375,9 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen
|
||||
Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
|
||||
|
||||
-- aliceNtf client doesn't have subscription and is allowed to get notification message
|
||||
aliceNtf <- getSMPAgentClient' 3 aliceCfg initAgentServers testDB
|
||||
runRight_ $ do
|
||||
withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
|
||||
(_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
|
||||
pure ()
|
||||
disposeAgentClient aliceNtf
|
||||
|
||||
runRight_ $ do
|
||||
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
|
||||
@@ -459,10 +449,8 @@ registerTestToken a token mode apnsQ = do
|
||||
pure tkn
|
||||
|
||||
testChangeNotificationsMode :: APNSMockServer -> IO ()
|
||||
testChangeNotificationsMode APNSMockServer {apnsQ} = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
runRight_ $ do
|
||||
testChangeNotificationsMode APNSMockServer {apnsQ} =
|
||||
withAgentClients2 $ \alice bob -> runRight_ $ do
|
||||
-- establish connection
|
||||
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
||||
aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
||||
@@ -518,17 +506,13 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
|
||||
ackMessage alice bobId (baseId + 5) Nothing
|
||||
-- no notifications should follow
|
||||
noNotification apnsQ
|
||||
disposeAgentClient alice
|
||||
disposeAgentClient bob
|
||||
where
|
||||
baseId = 3
|
||||
msgId = subtract baseId
|
||||
|
||||
testChangeToken :: APNSMockServer -> IO ()
|
||||
testChangeToken APNSMockServer {apnsQ} = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
(aliceId, bobId) <- runRight $ do
|
||||
testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do
|
||||
(aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
|
||||
-- establish connection
|
||||
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
||||
aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
||||
@@ -547,10 +531,8 @@ testChangeToken APNSMockServer {apnsQ} = do
|
||||
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId (baseId + 1) Nothing
|
||||
pure (aliceId, bobId)
|
||||
disposeAgentClient alice
|
||||
|
||||
alice1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
|
||||
runRight_ $ do
|
||||
withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do
|
||||
subscribeConnection alice1 bobId
|
||||
-- change notification token
|
||||
void $ registerTestToken alice1 "bcde" NMInstant apnsQ
|
||||
@@ -563,16 +545,12 @@ testChangeToken APNSMockServer {apnsQ} = do
|
||||
ackMessage alice1 bobId (baseId + 2) Nothing
|
||||
-- no notifications should follow
|
||||
noNotification apnsQ
|
||||
disposeAgentClient alice1
|
||||
disposeAgentClient bob
|
||||
where
|
||||
baseId = 3
|
||||
msgId = subtract baseId
|
||||
|
||||
testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
|
||||
testNotificationsStoreLog t APNSMockServer {apnsQ} = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
|
||||
(aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
_ <- registerTestToken alice "abcd" NMInstant apnsQ
|
||||
@@ -594,13 +572,9 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
|
||||
void $ messageNotificationData alice apnsQ
|
||||
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
|
||||
liftIO $ killThread threadId
|
||||
disposeAgentClient alice
|
||||
disposeAgentClient bob
|
||||
|
||||
testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
|
||||
testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
|
||||
(aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
_ <- registerTestToken alice "abcd" NMInstant apnsQ
|
||||
@@ -626,49 +600,44 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
|
||||
_ <- messageNotificationData alice apnsQ
|
||||
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
|
||||
liftIO $ killThread threadId
|
||||
disposeAgentClient alice
|
||||
disposeAgentClient bob
|
||||
|
||||
testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
|
||||
testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB
|
||||
b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2
|
||||
threadDelay 1000000
|
||||
conns <- runServers $ do
|
||||
conns <- replicateM (n :: Int) $ makeConnection a b
|
||||
_ <- registerTestToken a "abcd" NMInstant apnsQ
|
||||
liftIO $ threadDelay 5000000
|
||||
forM_ conns $ \(aliceId, bobId) -> do
|
||||
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
|
||||
get b ##> ("", aliceId, SENT msgId)
|
||||
void $ messageNotificationData a apnsQ
|
||||
get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
|
||||
ackMessage a bobId msgId Nothing
|
||||
pure conns
|
||||
testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} =
|
||||
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
|
||||
threadDelay 1000000
|
||||
conns <- runServers $ do
|
||||
conns <- replicateM (n :: Int) $ makeConnection a b
|
||||
_ <- registerTestToken a "abcd" NMInstant apnsQ
|
||||
liftIO $ threadDelay 5000000
|
||||
forM_ conns $ \(aliceId, bobId) -> do
|
||||
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
|
||||
get b ##> ("", aliceId, SENT msgId)
|
||||
void $ messageNotificationData a apnsQ
|
||||
get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
|
||||
ackMessage a bobId msgId Nothing
|
||||
pure conns
|
||||
|
||||
runRight_ @AgentErrorType $ do
|
||||
("", "", DOWN _ bcs1) <- nGet a
|
||||
("", "", DOWN _ bcs2) <- nGet a
|
||||
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
|
||||
("", "", DOWN _ acs1) <- nGet b
|
||||
("", "", DOWN _ acs2) <- nGet b
|
||||
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
|
||||
runRight_ @AgentErrorType $ do
|
||||
("", "", DOWN _ bcs1) <- nGet a
|
||||
("", "", DOWN _ bcs2) <- nGet a
|
||||
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
|
||||
("", "", DOWN _ acs1) <- nGet b
|
||||
("", "", DOWN _ acs2) <- nGet b
|
||||
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
|
||||
|
||||
runServers $ do
|
||||
("", "", UP _ bcs1) <- nGet a
|
||||
("", "", UP _ bcs2) <- nGet a
|
||||
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
|
||||
("", "", UP _ acs1) <- nGet b
|
||||
("", "", UP _ acs2) <- nGet b
|
||||
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
|
||||
liftIO $ threadDelay 1500000
|
||||
forM_ conns $ \(aliceId, bobId) -> do
|
||||
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
|
||||
get b ##> ("", aliceId, SENT msgId)
|
||||
_ <- messageNotificationData a apnsQ
|
||||
get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
|
||||
disposeAgentClient a
|
||||
disposeAgentClient b
|
||||
runServers $ do
|
||||
("", "", UP _ bcs1) <- nGet a
|
||||
("", "", UP _ bcs2) <- nGet a
|
||||
liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
|
||||
("", "", UP _ acs1) <- nGet b
|
||||
("", "", UP _ acs2) <- nGet b
|
||||
liftIO $ length (acs1 <> acs2) `shouldBe` length conns
|
||||
liftIO $ threadDelay 1500000
|
||||
forM_ conns $ \(aliceId, bobId) -> do
|
||||
msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
|
||||
get b ##> ("", aliceId, SENT msgId)
|
||||
_ <- messageNotificationData a apnsQ
|
||||
get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
|
||||
where
|
||||
runServers :: ExceptT AgentErrorType IO a -> IO a
|
||||
runServers a = do
|
||||
@@ -679,10 +648,8 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
|
||||
pure res
|
||||
|
||||
testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
|
||||
testSwitchNotifications servers APNSMockServer {apnsQ} = do
|
||||
a <- getSMPAgentClient' 1 agentCfg servers testDB
|
||||
b <- getSMPAgentClient' 2 agentCfg servers testDB2
|
||||
runRight_ $ do
|
||||
testSwitchNotifications servers APNSMockServer {apnsQ} =
|
||||
withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
_ <- registerTestToken a "abcd" NMInstant apnsQ
|
||||
@@ -698,15 +665,10 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
|
||||
switchComplete a bId b aId
|
||||
liftIO $ threadDelay 500000
|
||||
testMessage "hello again"
|
||||
disposeAgentClient a
|
||||
disposeAgentClient b
|
||||
|
||||
testNotificationsOldToken :: APNSMockServer -> IO ()
|
||||
testNotificationsOldToken APNSMockServer {apnsQ} = do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3
|
||||
runRight_ $ do
|
||||
testNotificationsOldToken APNSMockServer {apnsQ} =
|
||||
withAgentClients3 $ \a b c -> runRight_ $ do
|
||||
(abId, baId) <- makeConnection a b
|
||||
let testMessageAB = testMessage_ apnsQ a abId b baId
|
||||
_ <- registerTestToken a "abcd" NMInstant apnsQ
|
||||
@@ -722,16 +684,10 @@ testNotificationsOldToken APNSMockServer {apnsQ} = do
|
||||
(acId, caId) <- makeConnection a c
|
||||
let testMessageAC = testMessage_ apnsQ a acId c caId
|
||||
testMessageAC "greetings"
|
||||
disposeAgentClient a
|
||||
disposeAgentClient b
|
||||
disposeAgentClient c
|
||||
|
||||
testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
|
||||
testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3
|
||||
runRight_ $ do
|
||||
testNotificationsNewToken APNSMockServer {apnsQ} oldNtf =
|
||||
withAgentClients3 $ \a b c -> runRight_ $ do
|
||||
(abId, baId) <- makeConnection a b
|
||||
let testMessageAB = testMessage_ apnsQ a abId b baId
|
||||
tkn <- registerTestToken a "abcd" NMInstant apnsQ
|
||||
@@ -750,9 +706,6 @@ testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do
|
||||
(acId, caId) <- makeConnection a c
|
||||
let testMessageAC = testMessage_ apnsQ a acId c caId
|
||||
testMessageAC "greetings"
|
||||
disposeAgentClient a
|
||||
disposeAgentClient b
|
||||
disposeAgentClient c
|
||||
|
||||
testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
|
||||
testMessage_ apnsQ a aId b bId msg = do
|
||||
|
||||
+1
-1
@@ -123,7 +123,7 @@ withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceNa
|
||||
withSmpServerConfigOn t cfg' port' =
|
||||
serverBracket
|
||||
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
|
||||
(pure ())
|
||||
(threadDelay 10000)
|
||||
|
||||
withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withSmpServerThreadOn t = withSmpServerConfigOn t cfg
|
||||
|
||||
@@ -769,7 +769,7 @@ testTiming (ATransport t) =
|
||||
(C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type
|
||||
]
|
||||
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
|
||||
similarTime t1 t2 = abs (t2 / t1 - 1) < 0.15 -- normally the difference between "no queue" and "wrong key" is less than 5%
|
||||
similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5%
|
||||
testSameTiming :: forall c. Transport c => THandleSMP c -> THandleSMP c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
|
||||
testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do
|
||||
g <- C.newRandom
|
||||
|
||||
+232
-264
@@ -8,7 +8,7 @@
|
||||
|
||||
module XFTPAgent where
|
||||
|
||||
import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight, runRight_, sfGet)
|
||||
import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent)
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
@@ -24,7 +24,7 @@ import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), F
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
|
||||
import Simplex.Messaging.Agent (AgentClient, disposeAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
|
||||
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
|
||||
import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -100,8 +100,7 @@ testXFTPAgentSendReceive :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceive = withXFTPServer $ do
|
||||
filePath <- createRandomFile
|
||||
-- send file, delete snd file internally
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
(rfd1, rfd2) <- runRight $ do
|
||||
(rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(sfId, _, rfd1, rfd2) <- testSend sndr filePath
|
||||
liftIO $ xftpDeleteSndFileInternal sndr sfId
|
||||
pure (rfd1, rfd2)
|
||||
@@ -109,11 +108,10 @@ testXFTPAgentSendReceive = withXFTPServer $ do
|
||||
testReceiveDelete 2 rfd1 filePath
|
||||
testReceiveDelete 3 rfd2 filePath
|
||||
where
|
||||
testReceiveDelete clientId rfd originalFilePath = do
|
||||
rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2
|
||||
rfId <- runRight $ testReceive rcp rfd originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
disposeAgentClient rcp
|
||||
testReceiveDelete clientId rfd originalFilePath =
|
||||
withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
rfId <- runRight $ testReceive rcp rfd originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
|
||||
@@ -122,8 +120,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
|
||||
s <- LB.readFile filePath
|
||||
file <- atomically $ CryptoFile (senderFiles </> "encrypted_testfile") . Just <$> CF.randomArgs g
|
||||
runRight_ $ CF.writeFile file s
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
(rfd1, rfd2) <- runRight $ do
|
||||
(rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(sfId, _, rfd1, rfd2) <- testSendCF sndr file
|
||||
liftIO $ xftpDeleteSndFileInternal sndr sfId
|
||||
pure (rfd1, rfd2)
|
||||
@@ -131,12 +128,11 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
|
||||
testReceiveDelete 2 rfd1 filePath g
|
||||
testReceiveDelete 3 rfd2 filePath g
|
||||
where
|
||||
testReceiveDelete clientId rfd originalFilePath g = do
|
||||
rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2
|
||||
cfArgs <- atomically $ Just <$> CF.randomArgs g
|
||||
rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
disposeAgentClient rcp
|
||||
testReceiveDelete clientId rfd originalFilePath g =
|
||||
withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
cfArgs <- atomically $ Just <$> CF.randomArgs g
|
||||
rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
|
||||
xftpDeleteRcvFile rcp rfId
|
||||
|
||||
testXFTPAgentSendReceiveRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
|
||||
@@ -144,102 +140,98 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
|
||||
filePathIn <- createRandomFile
|
||||
let fileSize = mb 17
|
||||
totalSize = fileSize + mb 1
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
|
||||
vfdDirect <-
|
||||
sfGet sndr >>= \case
|
||||
(_, _, SFDONE _snd (vfd : _)) -> pure vfd
|
||||
r -> error $ "Expected SFDONE, got " <> show r
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
|
||||
vfdDirect <-
|
||||
sfGet sndr >>= \case
|
||||
(_, _, SFDONE _snd (vfd : _)) -> pure vfd
|
||||
r -> error $ "Expected SFDONE, got " <> show r
|
||||
|
||||
testNoRedundancy vfdDirect
|
||||
testNoRedundancy vfdDirect
|
||||
|
||||
redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1
|
||||
logInfo $ "File sent, sending redirect: " <> tshow redirectFileId
|
||||
sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536)
|
||||
vfdRedirect@(ValidFileDescription fdRedirect) <-
|
||||
sfGet sndr >>= \case
|
||||
(_, _, SFDONE _snd (vfd : _)) -> pure vfd
|
||||
r -> error $ "Expected SFDONE, got " <> show r
|
||||
redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1
|
||||
logInfo $ "File sent, sending redirect: " <> tshow redirectFileId
|
||||
sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536)
|
||||
vfdRedirect@(ValidFileDescription fdRedirect) <-
|
||||
sfGet sndr >>= \case
|
||||
(_, _, SFDONE _snd (vfd : _)) -> pure vfd
|
||||
r -> error $ "Expected SFDONE, got " <> show r
|
||||
|
||||
testNoRedundancy vfdRedirect
|
||||
testNoRedundancy vfdRedirect
|
||||
|
||||
case fdRedirect of
|
||||
FileDescription {redirect = Just _} -> pure ()
|
||||
_ -> error "missing RedirectFileInfo"
|
||||
let uri = strEncode $ fileDescriptionURI vfdRedirect
|
||||
case strDecode uri of
|
||||
Left err -> fail err
|
||||
Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect
|
||||
disposeAgentClient sndr
|
||||
--- recipient
|
||||
rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
FileDescriptionURI {description} <- either fail pure $ strDecode uri
|
||||
case fdRedirect of
|
||||
FileDescription {redirect = Just _} -> pure ()
|
||||
_ -> error "missing RedirectFileInfo"
|
||||
let uri = strEncode $ fileDescriptionURI vfdRedirect
|
||||
case strDecode uri of
|
||||
Left err -> fail err
|
||||
Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect
|
||||
--- recipient
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
FileDescriptionURI {description} <- either fail pure $ strDecode uri
|
||||
|
||||
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
|
||||
out <-
|
||||
rfGet rcp >>= \case
|
||||
(_, _, RFDONE out) -> pure out
|
||||
r -> error $ "Expected RFDONE, got " <> show r
|
||||
disposeAgentClient rcp
|
||||
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
|
||||
out <-
|
||||
rfGet rcp >>= \case
|
||||
(_, _, RFDONE out) -> pure out
|
||||
r -> error $ "Expected RFDONE, got " <> show r
|
||||
|
||||
inBytes <- B.readFile filePathIn
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
inBytes <- B.readFile filePathIn
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
|
||||
testXFTPAgentSendReceiveNoRedirect :: HasCallStack => IO ()
|
||||
testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
|
||||
--- sender
|
||||
let fileSize = mb 5
|
||||
filePathIn <- createRandomFile_ fileSize "testfile"
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
|
||||
let totalSize = fileSize + mb 1
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
|
||||
vfdDirect <-
|
||||
sfGet sndr >>= \case
|
||||
(_, _, SFDONE _snd (vfd : _)) -> pure vfd
|
||||
r -> error $ "Expected SFDONE, got " <> show r
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
|
||||
let totalSize = fileSize + mb 1
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize)
|
||||
sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
|
||||
vfdDirect <-
|
||||
sfGet sndr >>= \case
|
||||
(_, _, SFDONE _snd (vfd : _)) -> pure vfd
|
||||
r -> error $ "Expected SFDONE, got " <> show r
|
||||
|
||||
testNoRedundancy vfdDirect
|
||||
testNoRedundancy vfdDirect
|
||||
|
||||
let uri = strEncode $ fileDescriptionURI vfdDirect
|
||||
B.length uri `shouldSatisfy` (< qrSizeLimit)
|
||||
case strDecode uri of
|
||||
Left err -> fail err
|
||||
Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect
|
||||
disposeAgentClient sndr
|
||||
--- recipient
|
||||
rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
FileDescriptionURI {description} <- either fail pure $ strDecode uri
|
||||
let ValidFileDescription FileDescription {redirect} = description
|
||||
redirect `shouldBe` Nothing
|
||||
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
|
||||
-- NO extra "RFPROG 65k 65k" before switching to real file
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
|
||||
out <-
|
||||
rfGet rcp >>= \case
|
||||
(_, _, RFDONE out) -> pure out
|
||||
r -> error $ "Expected RFDONE, got " <> show r
|
||||
disposeAgentClient rcp
|
||||
let uri = strEncode $ fileDescriptionURI vfdDirect
|
||||
B.length uri `shouldSatisfy` (< qrSizeLimit)
|
||||
case strDecode uri of
|
||||
Left err -> fail err
|
||||
Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect
|
||||
--- recipient
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
|
||||
FileDescriptionURI {description} <- either fail pure $ strDecode uri
|
||||
let ValidFileDescription FileDescription {redirect} = description
|
||||
redirect `shouldBe` Nothing
|
||||
rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
|
||||
-- NO extra "RFPROG 65k 65k" before switching to real file
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize)
|
||||
rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
|
||||
out <-
|
||||
rfGet rcp >>= \case
|
||||
(_, _, RFDONE out) -> pure out
|
||||
r -> error $ "Expected RFDONE, got " <> show r
|
||||
|
||||
inBytes <- B.readFile filePathIn
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
inBytes <- B.readFile filePathIn
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
|
||||
createRandomFile :: HasCallStack => IO FilePath
|
||||
createRandomFile = createRandomFile' "testfile"
|
||||
@@ -298,52 +290,48 @@ logCfgNoLogs :: LogConfig
|
||||
logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
|
||||
|
||||
testXFTPAgentReceiveRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
testXFTPAgentReceiveRestore = do
|
||||
filePath <- createRandomFile
|
||||
|
||||
rfd <- withXFTPServerStoreLogOn $ \_ -> do
|
||||
rfd <- withXFTPServerStoreLogOn $ \_ ->
|
||||
-- send file
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
runRight $ do
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(_, _, rfd, _) <- testSend sndr filePath
|
||||
pure rfd
|
||||
|
||||
-- receive file - should not succeed with server down
|
||||
rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
rfId <- runRight $ do
|
||||
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
|
||||
xftpStartWorkers rcp (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp 1 rfd Nothing
|
||||
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
|
||||
pure rfId
|
||||
disposeAgentClient rcp
|
||||
|
||||
[prefixDir] <- listDirectory recipientFiles
|
||||
let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
|
||||
doesDirectoryExist tmpPath `shouldReturn` True
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> do
|
||||
withXFTPServerStoreLogOn $ \_ ->
|
||||
-- receive file - should start downloading with server up
|
||||
rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
("", rfId', RFPROG _ _) <- rfGet rcp'
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
disposeAgentClient rcp'
|
||||
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
("", rfId', RFPROG _ _) <- rfGet rcp'
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
threadDelay 100000
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> do
|
||||
withXFTPServerStoreLogOn $ \_ ->
|
||||
-- receive file - should continue downloading with server up
|
||||
rcp' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
|
||||
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
|
||||
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
|
||||
|
||||
-- tmp path should be removed after receiving file
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
threadDelay 100000
|
||||
-- tmp path should be removed after receiving file
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
@@ -351,30 +339,27 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
|
||||
rfd <- withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- send file
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
runRight $ do
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
(_, _, rfd, _) <- testSend sndr filePath
|
||||
pure rfd
|
||||
|
||||
-- receive file - should not succeed with server down
|
||||
rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
rfId <- runRight $ do
|
||||
rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
|
||||
xftpStartWorkers rcp (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp 1 rfd Nothing
|
||||
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
|
||||
pure rfId
|
||||
disposeAgentClient rcp
|
||||
|
||||
[prefixDir] <- listDirectory recipientFiles
|
||||
let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
|
||||
doesDirectoryExist tmpPath `shouldReturn` True
|
||||
|
||||
withXFTPServerThreadOn $ \_ -> do
|
||||
withXFTPServerThreadOn $ \_ ->
|
||||
-- receive file - should fail with AUTH error
|
||||
rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
|
||||
rfId' `shouldBe` rfId
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
|
||||
runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
|
||||
rfId' `shouldBe` rfId
|
||||
|
||||
-- tmp path should be removed after permanent error
|
||||
doesDirectoryExist tmpPath `shouldReturn` False
|
||||
@@ -384,13 +369,11 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
-- send file - should not succeed with server down
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
sfId <- runRight $ do
|
||||
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
|
||||
disposeAgentClient sndr
|
||||
|
||||
dirEntries <- listDirectory senderFiles
|
||||
let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
|
||||
@@ -399,25 +382,25 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
doesDirectoryExist prefixPath `shouldReturn` True
|
||||
doesFileExist encPath `shouldReturn` True
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> do
|
||||
withXFTPServerStoreLogOn $ \_ ->
|
||||
-- send file - should start uploading with server up
|
||||
sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
("", sfId', SFPROG _ _) <- sfGet sndr'
|
||||
liftIO $ sfId' `shouldBe` sfId
|
||||
disposeAgentClient sndr'
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
("", sfId', SFPROG _ _) <- sfGet sndr'
|
||||
liftIO $ sfId' `shouldBe` sfId
|
||||
|
||||
threadDelay 100000
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- send file - should continue uploading with server up
|
||||
sndr' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
|
||||
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
|
||||
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 100000
|
||||
@@ -425,18 +408,16 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
|
||||
-- receive file
|
||||
rcp <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
|
||||
runRight_ . void $
|
||||
testReceive rcp rfd1 filePath
|
||||
withAgent 4 agentCfg initAgentServers testDB2 $ \rcp ->
|
||||
runRight_ . void $ testReceive rcp rfd1 filePath
|
||||
|
||||
testXFTPAgentSendCleanup :: HasCallStack => IO ()
|
||||
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
sfId <- withXFTPServerStoreLogOn $ \_ -> do
|
||||
sfId <- withXFTPServerStoreLogOn $ \_ ->
|
||||
-- send file
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
sfId <- runRight $ do
|
||||
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
|
||||
@@ -444,8 +425,6 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
(_, _, SFPROG _ _) <- sfGet sndr
|
||||
pure ()
|
||||
pure sfId
|
||||
disposeAgentClient sndr
|
||||
pure sfId
|
||||
|
||||
dirEntries <- listDirectory senderFiles
|
||||
let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
|
||||
@@ -454,16 +433,16 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
|
||||
doesDirectoryExist prefixPath `shouldReturn` True
|
||||
doesFileExist encPath `shouldReturn` True
|
||||
|
||||
withXFTPServerThreadOn $ \_ -> do
|
||||
withXFTPServerThreadOn $ \_ ->
|
||||
-- send file - should fail with AUTH error
|
||||
sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr'
|
||||
sfId' `shouldBe` sfId
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr'
|
||||
sfId' `shouldBe` sfId
|
||||
|
||||
-- prefix path should be removed after permanent error
|
||||
doesDirectoryExist prefixPath `shouldReturn` False
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
-- prefix path should be removed after permanent error
|
||||
doesDirectoryExist prefixPath `shouldReturn` False
|
||||
doesFileExist encPath `shouldReturn` False
|
||||
|
||||
testXFTPAgentDelete :: HasCallStack => IO ()
|
||||
testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
|
||||
@@ -471,32 +450,30 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
|
||||
filePath <- createRandomFile
|
||||
|
||||
-- send file
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
(sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
|
||||
|
||||
-- receive file
|
||||
rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
runRight_ . void $
|
||||
testReceive rcp1 rfd1 filePath
|
||||
-- receive file
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> do
|
||||
runRight_ . void $ testReceive rcp1 rfd1 filePath
|
||||
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 6
|
||||
|
||||
-- delete file
|
||||
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
||||
xftpDeleteSndFileRemote sndr 1 sfId sndDescr
|
||||
Nothing <- 100000 `timeout` sfGet sndr
|
||||
disposeAgentClient rcp1
|
||||
-- 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
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
-- receive file - should fail with AUTH error
|
||||
rcp2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
||||
runRight $ do
|
||||
xftpStartWorkers rcp2 (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
-- 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
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
|
||||
testXFTPAgentDeleteRestore :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
@@ -504,42 +481,37 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
|
||||
|
||||
(sfId, sndDescr, rfd2) <- withXFTPServerStoreLogOn $ \_ -> do
|
||||
-- send file
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
(sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
|
||||
|
||||
-- receive file
|
||||
rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
runRight_ . void $
|
||||
testReceive rcp1 rfd1 filePath
|
||||
disposeAgentClient rcp1
|
||||
disposeAgentClient sndr
|
||||
pure (sfId, sndDescr, rfd2)
|
||||
-- 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
|
||||
sndr <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
|
||||
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
||||
xftpDeleteSndFileRemote sndr 1 sfId sndDescr
|
||||
timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt
|
||||
disposeAgentClient sndr
|
||||
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
|
||||
sndr' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
withAgent 4 agentCfg initAgentServers testDB $ \sndr' -> do
|
||||
runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
|
||||
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
threadDelay 1000000
|
||||
length <$> listDirectory xftpServerFiles `shouldReturn` 0
|
||||
|
||||
-- receive file - should fail with AUTH error
|
||||
rcp2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB3
|
||||
runRight $ do
|
||||
xftpStartWorkers rcp2 (Just recipientFiles)
|
||||
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
-- 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
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
|
||||
liftIO $ rfId' `shouldBe` rfId
|
||||
|
||||
testXFTPAgentDeleteOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
|
||||
@@ -547,36 +519,35 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- send file 1
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
|
||||
-- receive file 1 successfully
|
||||
rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
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
|
||||
-- TODO should fail with AUTH error
|
||||
_rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing
|
||||
runRight_ . void $ do
|
||||
-- receive file 1 again
|
||||
-- TODO should fail with AUTH error
|
||||
_rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing
|
||||
|
||||
-- receive file 2
|
||||
testReceive' rcp rfd2 filePath2
|
||||
-- receive file 2
|
||||
testReceive' rcp rfd2 filePath2
|
||||
|
||||
testXFTPAgentExpiredOnServer :: HasCallStack => IO ()
|
||||
testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
|
||||
@@ -585,46 +556,43 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- send file 1
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
|
||||
(_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
|
||||
|
||||
-- receive file 1 successfully
|
||||
rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
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
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = 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
|
||||
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = 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 = withXFTPServer $ do
|
||||
filePath <- createRandomFile
|
||||
|
||||
-- send file
|
||||
sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
rfds <- runRight $ do
|
||||
rfds <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
xftpStartWorkers sndr (Just senderFiles)
|
||||
sfId <- xftpSendFile sndr 1 (CF.plain filePath) 500
|
||||
sfProgress sndr $ mb 18
|
||||
@@ -638,8 +606,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
|
||||
|
||||
-- receive file using different descriptions
|
||||
-- ! revise number of recipients and indexes if xftpMaxRecipientsPerRequest is changed
|
||||
rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
||||
runRight_ $ do
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight_ $ do
|
||||
void $ testReceive rcp (head rfds) filePath
|
||||
void $ testReceive rcp (rfds !! 99) filePath
|
||||
void $ testReceive rcp (rfds !! 299) filePath
|
||||
@@ -647,6 +614,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
|
||||
|
||||
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testXFTPServerTest newFileBasicAuth srv =
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do
|
||||
a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running
|
||||
testProtocolServer a 1 srv
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a 1 srv
|
||||
|
||||
+2
-2
@@ -5,7 +5,7 @@
|
||||
|
||||
module XFTPClient where
|
||||
|
||||
import Control.Concurrent (ThreadId)
|
||||
import Control.Concurrent (ThreadId, threadDelay)
|
||||
import Data.String (fromString)
|
||||
import Network.Socket (ServiceName)
|
||||
import SMPClient (serverBracket)
|
||||
@@ -53,7 +53,7 @@ withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => Thread
|
||||
withXFTPServerCfg cfg =
|
||||
serverBracket
|
||||
(`runXFTPServerBlocking` cfg)
|
||||
(pure ())
|
||||
(threadDelay 10000)
|
||||
|
||||
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
|
||||
|
||||
Reference in New Issue
Block a user