{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module SMPProxyTests where import AgentTests.EqInstances () import AgentTests.FunctionalAPITests import Control.Concurrent (ThreadId, threadDelay) import Control.Logger.Simple import Control.Monad (forM, forM_, forever, replicateM_) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Data.ByteString.Char8 (ByteString) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Time.Clock (getCurrentTime) import SMPAgentClient import SMPClient import ServerTests (decryptMsgV3, sendRecv) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..)) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ) import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, QueueReqData (..), RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) import Simplex.Messaging.Server.MsgStore.Types (SQSType (..)) import Simplex.Messaging.Transport import Simplex.Messaging.Util (bshow, tshow) import Simplex.Messaging.Version (mkVersionRange) import System.FilePath (splitExtensions) import System.Random (randomRIO) import Test.Hspec hiding (fit, it) import UnliftIO import Util #if defined(dbPostgres) import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #endif smpProxyTests :: SpecWith AStoreType smpProxyTests = do describe "server configuration" $ do it "refuses proxy handshake unless enabled" testNoProxy it "checks basic auth in proxy requests" testProxyAuth describe "proxy requests" $ do describe "bad relay URIs" $ do xit "host not resolved" todo xit "when SMP port blackholed" todo xit "no SMP service at host/port" todo xit "bad SMP fingerprint" todo xit "batching proxy requests" todo describe "deliver message via SMP proxy" $ do let srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost2 testPort2 testKeyHash describe "client API" $ do let maxLen = maxMessageLength encryptedBlockSMPVersion describe "one server" $ do it "deliver via proxy" . oneServer $ do deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2" describe "two servers" $ do let proxyServ = srv1 relayServ = srv2 (msg1, msg2) <- runIO $ do g <- C.newRandom atomically $ (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g it "deliver via proxy" . twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2" it "max message size, Ed448 keys" . twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SEd448 msg1 msg2 it "max message size, Ed25519 keys" . twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg1 msg2 it "max message size, X25519 keys" . twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SX25519 msg1 msg2 describe "stress test 1k" $ do let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n]) it "1x1000" . twoServersFirstProxy $ deliver 1000 it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200 it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100 describe "stress test - no host" $ do it "1x1000, no delay" . oneServer $ proxyConnectDeadRelay 1000 0 srv1 xit "1x1000, 100ms" . oneServer $ proxyConnectDeadRelay 1000 100000 srv1 xit "100x1000, 100ms" . oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1) xdescribe "stress test 10k" $ do let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n]) it "1x10000" . twoServersFirstProxy $ deliver 10000 it "5x2000" . twoServersFirstProxy $ 5 `inParrallel` deliver 2000 it "10x1000" . twoServersFirstProxy $ 10 `inParrallel` deliver 1000 it "100x100 N1" . twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100 it "100x100 N4 C1" . twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 it "100x100 N4 C2" . twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100 it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20 #if defined(dbPostgres) after_ (dropAllSchemasExceptSystem testDBConnectInfo) . describe "agent API" $ do #else describe "agent API" $ do #endif describe "one server" $ do it "always via proxy" . oneServer $ agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 it "without proxy" . oneServer $ agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 describe "two servers" $ do it "always via proxy" $ \msType -> twoServers (agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1) msType it "both via proxy" . twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy" . twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 it "without proxy" . twoServers $ agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy for unknown" . twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1 it "without proxy with fallback" . twoServers_ proxyCfg cfgV7 $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 3 it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $ agentViaProxyVersionError it "retries sending when destination or proxy relay is offline" $ \_ -> agentViaProxyRetryOffline it "retries sending when destination relay session disconnects in proxy" $ \_ -> agentViaProxyRetryNoSession describe "stress test 1k" $ do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) it "2 agents, 250 messages" . oneServer $ deliver 2 250 it "5 agents, 10 pairs, 50 messages, N1" . oneServer . withNumCapabilities 1 $ deliver 5 50 it "5 agents, 10 pairs, 50 messages. N4" . oneServer . withNumCapabilities 4 $ deliver 5 50 xdescribe "stress test 10k" $ do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17 where oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) testPort $ const test twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType twoServersNoConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 1}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType twoServers_ :: AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO () twoServers_ cfg1 cfg2 runTest (ASType qsType _) = withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> let cfg2' = case qsType of SQSMemory -> journalCfg cfg2 testStoreLogFile2 testStoreMsgsDir2 SQSPostgres -> journalCfgDB cfg2 testStoreDBOpts2 testStoreMsgsDir2 in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg'] deliverMessagesViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> [ByteString] -> [ByteString] -> IO () deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do g <- C.newRandom -- set up proxy ts <- getCurrentTime pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- set up relay msgQ <- newTBQueueIO 1024 rc' <- getProtocolClient g NRMInteractive (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ()) rc <- either (fail . show) pure rc' -- prepare receiving queue (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) Nothing let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv -- get proxy session sess0 <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct") sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct") sess0 `shouldBe` sess -- send via proxy to unsecured queue forM_ unsecuredMsgs $ \msg -> do runExceptT' (proxySMPMessage pc NRMInteractive sess Nothing sndId noMsgFlags msg) `shouldReturn` Right () runExceptT' (proxySMPMessage pc NRMInteractive sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION) -- receive 1 (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})))]) <- atomically $ readTBQueue msgQ dec msgId encBody `shouldBe` Right msg runExceptT' $ ackSMPMessage rc rPriv rcvId msgId -- secure queue (sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g runExceptT' $ secureSMPQueue rc NRMInteractive rPriv rcvId sPub -- send via proxy to secured queue waitSendRecv ( forM_ securedMsgs $ \msg' -> runExceptT' (proxySMPMessage pc NRMInteractive sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right () ) ( forM_ securedMsgs $ \msg' -> do (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})))]) <- atomically $ readTBQueue msgQ dec msgId' encBody' `shouldBe` Right msg' runExceptT' $ ackSMPMessage rc rPriv rcvId msgId' ) proxyConnectDeadRelay :: Int -> Int -> SMPServer -> IO () proxyConnectDeadRelay n d proxyServ = do g <- C.newRandom -- set up proxy ts <- getCurrentTime pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- get proxy session replicateM_ n $ do sess0 <- runExceptT $ connectSMPProxiedRelay pc NRMInteractive (SMPServer testHost "45678" testKeyHash) (Just "correct") case sess0 of Right !_noWay -> error "got unexpected client" Left !_err -> threadDelay d agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO () agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId = withAgent 1 aCfg (servers aTestCfg) testDB $ \alice -> withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn allowConnection alice bobId confId "alice's connInfo" let pqEnc = CR.PQEncOn get alice ##> ("", bobId, A.CON pqEnc) get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4 let aProxySrv = if aViaProxy then Just $ L.head aSrvs else Nothing 1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv) 2 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg2 get alice ##> ("", bobId, A.SENT (baseId + 2) aProxySrv) get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False ackMessage bob aliceId (baseId + 1) Nothing get bob =##> \case ("", c, Msg' _ pq msg2') -> c == aliceId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage bob aliceId (baseId + 2) Nothing let bProxySrv = if bViaProxy then Just $ L.head bSrvs else Nothing 3 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg1 get bob ##> ("", aliceId, A.SENT (baseId + 3) bProxySrv) 4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 get bob ##> ("", aliceId, A.SENT (baseId + 4) bProxySrv) get alice =##> \case ("", c, Msg' _ pq msg1') -> c == bobId && pq == pqEnc && msg1 == msg1'; _ -> False ackMessage alice bobId (baseId + 3) Nothing get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage alice bobId (baseId + 4) Nothing where msgId = subtract baseId . fst aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} servers (srvs, smpProxyMode, _) = (initAgentServersProxy_ smpProxyMode SPFAllow) {smp = userServers srvs} agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO () agentDeliverMessagesViaProxyConc agentServers msgs = withAgents $ \agents -> do let pairs = combinations 2 agents logNote $ "Pairing " <> tshow (length agents) <> " agents into " <> tshow (length pairs) <> " connections" connections <- forM pairs $ \case [a, b] -> prePair a b _ -> error "agents must be paired" logNote "Running..." mapConcurrently_ run connections where withAgents :: ([AgentClient] -> IO ()) -> IO () withAgents action = go [] (zip [1 :: Int ..] agentServers) where go agents = \case [] -> action agents (aId, aSrvs) : next -> withAgent aId aCfg (servers aSrvs) (dbPrefix <> show aId <> dbSuffix) $ \a -> (a : agents) `go` next (dbPrefix, dbSuffix) = splitExtensions testDB -- agent connections have to be set up in advance -- otherwise the CONF messages would get mixed with MSG prePair alice bob = do (bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn (sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True confId <- get alice >>= \case ("", _, A.CONF confId pqSup' _ "bob's connInfo") -> do pqSup' `shouldBe` PQSupportOn pure confId huh -> fail $ show huh runExceptT' $ allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, A.CON pqEnc) get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) pure (alice, bobId, bob, aliceId) -- stream messages in opposite directions, while getting deliveries and sending ACKs run (alice, bobId, bob, aliceId) = do aSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage alice bobId pqEnc noMsgFlags bRecipient <- async $ forever $ get bob >>= \case ("", _, A.SENT _ _) -> pure () ("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing huh -> fail (show huh) bSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage bob aliceId pqEnc noMsgFlags aRecipient <- async $ forever $ get alice >>= \case ("", _, A.SENT _ _) -> pure () ("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing huh -> fail (show huh) logDebug "run waiting..." a2b <- async $ (waitCatch aSender >>= either throwIO pure) `finally` cancel bRecipient -- stopped sender cancels paired recipient loop b2a <- async $ (waitCatch bSender >>= either throwIO pure) `finally` cancel aRecipient waitEitherCatch a2b b2a >>= \case Right (Right ()) -> wait b2a Right (Left e) -> cancel bSender >> throwIO e Left (Right ()) -> wait a2b Left (Left e) -> cancel aSender >> throwIO e logDebug "run finished" pqEnc = CR.PQEncOn aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} servers srvs = (initAgentServersProxy_ SPMAlways SPFAllow) {smp = userServers srvs} agentViaProxyVersionError :: IO () agentViaProxyVersionError = withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do Left (A.BROKER _ (TRANSPORT TEVersion)) <- withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do (_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () where servers srvs = (initAgentServersProxy_ SPMUnknown SPFProhibit) {smp = userServers srvs} agentViaProxyRetryOffline :: IO () agentViaProxyRetryOffline = do let srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost testPort2 testKeyHash msg1 = "hello 1" msg2 = "hello 2" aProxySrv = Just srv1 bProxySrv = Just srv2 withAgent 1 aCfg (servers srv1) testDB $ \alice -> withAgent 2 aCfg (servers srv2) testDB2 $ \bob -> do let pqEnc = CR.PQEncOn withServer $ \_ -> do (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, A.CON pqEnc) get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) 1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv) get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False ackMessage bob aliceId (baseId + 1) Nothing 2 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 get bob ##> ("", aliceId, A.SENT (baseId + 2) bProxySrv) get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage alice bobId (baseId + 2) Nothing pure (aliceId, bobId) runRight_ $ do -- destination relay down 3 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 bob `down` aliceId withServer2 $ \_ -> runRight_ $ do bob `up` aliceId get alice ##> ("", bobId, A.SENT (baseId + 3) aProxySrv) get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False ackMessage bob aliceId (baseId + 3) Nothing runRight_ $ do -- proxy relay down 4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 bob `down` aliceId withServer2 $ \_ -> do getInAnyOrder bob [ \case ("", "", AEvt SAENone (UP _ [c])) -> c == aliceId; _ -> False, \case ("", c, AEvt SAEConn (A.SENT mId srv)) -> c == aliceId && mId == baseId + 4 && srv == bProxySrv; _ -> False ] runRight_ $ do get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage alice bobId (baseId + 4) Nothing where withServer :: (ThreadId -> IO a) -> IO a withServer = withServer_ testStoreLogFile testStoreMsgsDir testStoreNtfsFile testPort -- TODO [postgres] -- withServer = withServer_ testStoreDBOpts testStoreMsgsDir testStoreNtfsFile testPort withServer2 :: (ThreadId -> IO a) -> IO a withServer2 = withServer_ testStoreLogFile2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2 -- TODO [postgres] -- withServer2 = withServer_ testStoreDBOpts2 testStoreMsgsDir2 testStoreNtfsFile2 testPort2 withServer_ storeLog storeMsgs storeNtfs = let cfg' = updateCfg (journalCfg proxyCfg storeLog storeMsgs) $ \cfg_ -> cfg_ {storeNtfsFile = Just storeNtfs} in withSmpServerConfigOn (transport @TLS) cfg' a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} baseId = 1 msgId = subtract baseId . fst servers srv = initAgentServersProxy {smp = userServers [srv]} agentViaProxyRetryNoSession :: IO () agentViaProxyRetryNoSession = do let srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost testPort2 testKeyHash withAgent 1 agentCfg (servers srv1) testDB $ \a -> withAgent 2 agentCfg (servers srv2) testDB2 $ \b -> do withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> do (aId, _) <- withServer2 $ \_ -> runRight $ makeConnection a b nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False withServer2 $ \_ -> do nGet b =##> \case ("", "", UP _ [c]) -> c == aId; _ -> False -- to test retry in case of NO_SESSION error, -- the client using server 1 as proxy and server 2 as destination -- should be joining the connection, so the order is swapped here. _ <- runRight $ makeConnection b a pure () where withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 servers srv = initAgentServersProxy {smp = userServers [srv]} testNoProxy :: AStoreType -> IO () testNoProxy msType = do withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing) reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) testProxyAuth :: AStoreType -> IO () testProxyAuth msType = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer2 $ Just "wrong") reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) where proxyCfgAuth = updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth = Just "correct"} todo :: AStoreType -> IO () todo _ = fail "TODO" runExceptT' :: Exception e => ExceptT e IO a -> IO a runExceptT' a = runExceptT a >>= either throwIO pure waitSendRecv :: IO () -> IO () -> IO () waitSendRecv s r = do s' <- async s r' <- async r waitCatch s' >>= either (\e -> cancel r' >> fail (show e)) pure waitCatch r' >>= either (\e -> cancel s' >> fail (show e)) pure