mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-06-06 19:51:57 +00:00
f0b7a4be73
* smp server: messaging services (#1565)
* smp server: refactor message delivery to always respond SOK to subscriptions
* refactor ntf subscribe
* cancel subscription thread and reduce service subscription count when queue is deleted
* subscribe rcv service, deliver sent messages to subscribed service
* subscribe rcv service to messages (TODO delivery on subscription)
* WIP
* efficient initial delivery of messages to subscribed service
* test: delivery to client with service certificate
* test: upgrade/downgrade to/from service subscriptions
* remove service association from agent API, add per-user flag to use the service
* agent client (WIP)
* service certificates in the client
* rfc about drift detection, and SALL to mark end of message delivery
* fix test
* fix test
* add function for postgresql message storage
* update migration
* servers: maintain xor-hash of all associated queue IDs in PostgreSQL (#1668)
* servers: maintain xor-hash of all associated queue IDs in PostgreSQL (#1615)
* ntf server: maintain xor-hash of all associated queue IDs via PostgreSQL triggers
* smp server: xor hash with triggers
* fix sql and using pgcrypto extension in tests
* track counts and hashes in smp/ntf servers via triggers, smp server stats for service subscription, update SMP protocol to pass expected count and hash in SSUB/NSSUB commands
* agent migrations with functions/triggers
* remove agent triggers
* try tracking service subs in the agent (WIP, does not compile)
* Revert "try tracking service subs in the agent (WIP, does not compile)"
This reverts commit 59e908100d.
* comment
* agent database triggers
* service subscriptions in the client
* test / fix client services
* update schema
* fix postgres migration
* update schema
* move schema test to the end
* use static function with SQLite to avoid dynamic wrapper
* agent: fail when per-connection transport isolation is used with services (#1670)
* agent: service subscription events (#1671)
* agent: use server keyhash when loading service record
* agent: process queue/service associations with delayed subscription results
* agent: service subscription events
* agent: finalize initial service subscriptions, remove associations on service ID changes (#1672)
* agent: remove service/queue associations when service ID changes
* agent: check that service ID in NEW response matches session ID in transport session
* agent subscription WIP
* test
* comment
* enable tests
* update queries
* agent: option to add SQLite aggregates to DB connection (#1673)
* agent: add build_relations_vector function to sqlite
* update aggregate
* use static aggregate
* remove relations
---------
Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
* add test, treat BAD_SERVICE as temp error, only remove queue associations on service errors
* add packZipWith for backward compatibility with GHC 8.10.7
---------
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
* servers: service stats and logging, allow services without option (removed), report errors during service message delivery, remove threads when service subscription ended (#1676)
* smp server: always allow services without option
* smp server: maintain IDs hash in session subscription states
* smp server: service message delivery error handling
* ntf server: log subscription count and hash differences
* smp server: remove delivery threads when service subscription ended/client disconnected
* agent: remove service queue association when service ID changed, process ENDS event, test migrating to/from service (#1677)
* agent: remove service queue association when service ID changed
* agent: process ENDS event
* agent: send service subscription error event
* agent: test migrating to/from service subscriptions, fixes
* agent: always remove service when disabled, fix service subscriptions
* ntf server: use different client certs for each SMP server, remove support for store log (#1681)
* ntf server: remove support for store log
* ntf server: use different client certificates for each SMP server
* smp protocol: fix encoding for SOKS/ENDS responses (#1683)
* agent: create user with option to enable client service (#1684)
* agent: create user with option to enable client service
* handle HTTP2 errors
* do not catch async exceptions
* agent: minor fixes
* docs: update protocol (#1705)
* docs: agent threat model
* update protocol docs
* update RFCs (#1730)
* update RFCs
* update
* update overview
* update terminology
* original language in threat model
---------
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
* docs: fix minor issues in protocols
* docs: add e2e encrypted message wire encoding to PQDR spec
* docs: add missing encodings and other protocol corrections
* docs: move implemented rfcs
* smp: service fixes (#1737)
* smp: deliver service subscription to correct client
* tests: more resilient to concurrency
* optimize PostgreSQL query
* fix service re-association after server "downgrade"
* correctly handle service removed from server (and ID changed)
* remove unused
---------
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
* prometheus: fix metrics names (#1747)
* test: rcv service re-association on restart (#1746)
* agent: correct log message
* docs: update whitepaper
* smp: fix messaging client service issues (#1751)
* services: fix minor issues
* fix accounting for subscribed service queues, add prometheus stats
* fix uncorrelated subquery
* fix potential race condition when inserting service defensively, as it is also prevented by how client is created
---------
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
* agent: refactor cleanup if no pending subs (#1757)
* smp server: batch processing of subscription messages (#1753)
* smp server: batch processing of subscription messages
* refactor
* empty line
* fix
---------
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
* smp: batch queue association updates on subscriptions (#1760)
* smp: batch queue association updates on subscriptions
* refactor to fused batching
* simpler
* batch assoc functions
* clean up
* fix
---------
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
* agent: use primary key index in setRcvServiceAssocs (#1783)
* agent: use primary key index in setRcvServiceAssocs
Previous WHERE rcv_id = ? did not match the (host, port, rcv_id)
primary key prefix and fell back to a table scan via
idx_rcv_queues_client_notice_id. With ~390k rows per queue, each
update in a 1350-row batch scanned the whole table, yielding ~290s
per batch and a multi-hour rcv-services migration.
* agent: pass SMPServer explicitly to setRcvServiceAssocs
Avoid extracting host/port from the first queue inside setRcvServiceAssocs.
The caller already has SMPServer in scope (from tSess) and the call chain
is short, so threading it through is simpler than inspecting the list.
Removes the empty-list guard from setRcvServiceAssocs (it remains in
processRcvServiceAssocs).
---------
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com>
4579 lines
227 KiB
Haskell
4579 lines
227 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE InstanceSigs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE NumericUnderscores #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
|
|
module AgentTests.FunctionalAPITests
|
|
( functionalAPITests,
|
|
testServerMatrix2,
|
|
withAgentClientsCfg2,
|
|
withAgentClientsCfgServers2,
|
|
getSMPAgentClient',
|
|
withAgent,
|
|
withAgentClients2,
|
|
withAgentClients3,
|
|
makeConnection,
|
|
exchangeGreetings,
|
|
switchComplete,
|
|
createConnection,
|
|
joinConnection,
|
|
sendMessage,
|
|
runRight,
|
|
runRight_,
|
|
inAnyOrder,
|
|
get,
|
|
get',
|
|
rfGet,
|
|
sfGet,
|
|
nGet,
|
|
getInAnyOrder,
|
|
(##>),
|
|
(=##>),
|
|
pattern CON,
|
|
pattern CONF,
|
|
pattern INFO,
|
|
pattern REQ,
|
|
pattern Msg,
|
|
pattern Msg',
|
|
pattern SENT,
|
|
agentCfgVPrevPQ,
|
|
)
|
|
where
|
|
|
|
import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchetParams12)
|
|
import AgentTests.EqInstances ()
|
|
import Control.Concurrent (forkIO, killThread, threadDelay)
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.Reader
|
|
import Data.Bifunctor (first)
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Data.Either (isRight)
|
|
import Data.Int (Int64)
|
|
import Data.List (find, isPrefixOf, isSuffixOf, nub)
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import qualified Data.Map as M
|
|
import Data.Maybe (isJust, isNothing)
|
|
import qualified Data.Set as S
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (decodeLatin1)
|
|
import qualified Data.Text.IO as T
|
|
import Data.Time.Clock (diffUTCTime, getCurrentTime)
|
|
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
|
import Data.Type.Equality (testEquality, (:~:) (Refl))
|
|
import Data.Word (Word16)
|
|
import GHC.Stack (withFrozenCallStack)
|
|
import SMPAgentClient
|
|
import SMPClient
|
|
import Simplex.Messaging.Agent hiding (acceptContact, createConnection, deleteConnection, deleteConnections, getConnShortLink, joinConnection, sendMessage, setConnShortLink, subscribeConnection, suspendConnection)
|
|
import qualified Simplex.Messaging.Agent as A
|
|
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork)
|
|
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore)
|
|
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT)
|
|
import qualified Simplex.Messaging.Agent.Protocol as A
|
|
import Simplex.Messaging.Agent.Store (Connection' (..), SomeConn' (..), StoredRcvQueue (..))
|
|
import Simplex.Messaging.Agent.Store.AgentStore (getConn)
|
|
import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
|
|
import Simplex.Messaging.Agent.Store.Interface
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError (..))
|
|
import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
|
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
|
import Simplex.Messaging.Encoding
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF)
|
|
import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, NetworkError (..), ProtocolServer (..), SubscriptionMode (..), initialSMPClientVersion, srvHostnamesSMPClientVersion, supportedSMPClientVRange)
|
|
import qualified Simplex.Messaging.Protocol as SMP
|
|
import Simplex.Messaging.Protocol.Types
|
|
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
|
|
import Simplex.Messaging.Server.Expiration
|
|
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
|
|
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
|
import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..))
|
|
import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
|
|
import Simplex.Messaging.Transport.Server (TransportServerConfig (..))
|
|
import Simplex.Messaging.Util (bshow, diffToMicroseconds)
|
|
import Simplex.Messaging.Version (VersionRange (..))
|
|
import qualified Simplex.Messaging.Version as V
|
|
import Simplex.Messaging.Version.Internal (Version (..))
|
|
import System.Directory (copyFile, removeFile, renameFile)
|
|
import Test.Hspec hiding (fit, it)
|
|
import UnliftIO
|
|
import Util
|
|
import XFTPClient (testXFTPServer)
|
|
|
|
#if defined(dbPostgres)
|
|
import Fixtures
|
|
import Simplex.Messaging.Agent.Store (RcvQueue, RcvQueueSub (..), ServiceAssoc)
|
|
import Simplex.Messaging.Agent.Store.AgentStore (deleteClientService, getSubscriptionService, getUserServerRcvQueueSubs, removeRcvServiceAssocs, setRcvServiceAssocs)
|
|
#endif
|
|
#if defined(dbServerPostgres)
|
|
import qualified Database.PostgreSQL.Simple as PSQL
|
|
import qualified Simplex.Messaging.Agent.Store.Postgres as Postgres
|
|
import qualified Simplex.Messaging.Agent.Store.Postgres.Common as Postgres
|
|
import Simplex.Messaging.Server.MsgStore.Journal (JournalQueue)
|
|
import Simplex.Messaging.Server.MsgStore.Postgres (PostgresQueue)
|
|
import Simplex.Messaging.Server.MsgStore.Types (QSType (..))
|
|
import Simplex.Messaging.Server.QueueStore.Postgres
|
|
import Simplex.Messaging.Server.QueueStore.Postgres.Migrations
|
|
import Simplex.Messaging.Server.QueueStore.Types (QueueStoreClass (..))
|
|
#endif
|
|
|
|
type AEntityTransmission e = (ACorrId, ConnId, AEvent e)
|
|
|
|
-- deriving instance Eq (ValidFileDescription p)
|
|
|
|
shouldRespond :: (HasCallStack, MonadUnliftIO m, Eq a, Show a) => m a -> a -> m ()
|
|
a `shouldRespond` r = withFrozenCallStack $ withTimeout a (`shouldBe` r)
|
|
|
|
(##>) :: (HasCallStack, MonadUnliftIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m ()
|
|
a ##> t = a `shouldRespond` t
|
|
|
|
(=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Bool) -> m ()
|
|
a =##> p =
|
|
withTimeout a $ \r -> do
|
|
unless (p r) $ liftIO $ putStrLn $ "value failed predicate: " <> show r
|
|
r `shouldSatisfy` p
|
|
|
|
withTimeout :: (HasCallStack, MonadUnliftIO m) => m a -> (HasCallStack => a -> Expectation) -> m ()
|
|
withTimeout a test =
|
|
timeout 10_000000 a >>= \case
|
|
Nothing -> error "operation timed out"
|
|
Just t -> liftIO $ test t
|
|
|
|
get :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AEConn)
|
|
get c = withFrozenCallStack $ get' @'AEConn c
|
|
|
|
rfGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AERcvFile)
|
|
rfGet c = withFrozenCallStack $ get' @'AERcvFile c
|
|
|
|
sfGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AESndFile)
|
|
sfGet c = withFrozenCallStack $ get' @'AESndFile c
|
|
|
|
nGet :: (MonadIO m, HasCallStack) => AgentClient -> m (AEntityTransmission 'AENone)
|
|
nGet c = withFrozenCallStack $ get' @'AENone c
|
|
|
|
get' :: forall e m. (MonadIO m, AEntityI e, HasCallStack) => AgentClient -> m (AEntityTransmission e)
|
|
get' c = withFrozenCallStack $ do
|
|
(corrId, connId, AEvt e cmd) <- pGet c
|
|
case testEquality e (sAEntity @e) of
|
|
Just Refl -> pure (corrId, connId, cmd)
|
|
_ -> error $ "unexpected command " <> show cmd
|
|
|
|
pGet :: forall m. MonadIO m => AgentClient -> m ATransmission
|
|
pGet c = pGet' c True
|
|
|
|
pGet' :: forall m. MonadIO m => AgentClient -> Bool -> m ATransmission
|
|
pGet' c skipWarn = do
|
|
t@(_, _, AEvt _ cmd) <- atomically (readTBQueue $ subQ c)
|
|
case cmd of
|
|
CONNECT {} -> pGet c
|
|
DISCONNECT {} -> pGet c
|
|
ERR (BROKER _ (NETWORK _)) -> pGet c
|
|
MWARN {} | skipWarn -> pGet c
|
|
RFWARN {} | skipWarn -> pGet c
|
|
SFWARN {} | skipWarn -> pGet c
|
|
_ -> pure t
|
|
|
|
pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> AEvent e
|
|
pattern CONF conId srvs connInfo <- A.CONF conId PQSupportOn srvs connInfo
|
|
|
|
pattern INFO :: ConnInfo -> AEvent 'AEConn
|
|
pattern INFO connInfo = A.INFO PQSupportOn connInfo
|
|
|
|
pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> AEvent e
|
|
pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo
|
|
|
|
pattern CON :: AEvent 'AEConn
|
|
pattern CON = A.CON PQEncOn
|
|
|
|
pattern Msg :: MsgBody -> AEvent e
|
|
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk, pqEncryption = PQEncOn} _ msgBody
|
|
|
|
pattern Msg' :: AgentMsgId -> PQEncryption -> MsgBody -> AEvent e
|
|
pattern Msg' aMsgId pq msgBody <- MSG MsgMeta {integrity = MsgOk, recipient = (aMsgId, _), pqEncryption = pq} _ msgBody
|
|
|
|
pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> AEvent 'AEConn
|
|
pattern MsgErr msgId err msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err} _ msgBody
|
|
|
|
pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> AEvent 'AEConn
|
|
pattern MsgErr' msgId err pq msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err, pqEncryption = pq} _ msgBody
|
|
|
|
pattern SENT :: AgentMsgId -> AEvent 'AEConn
|
|
pattern SENT msgId = A.SENT msgId Nothing
|
|
|
|
pattern Rcvd :: AgentMsgId -> AEvent 'AEConn
|
|
pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
|
|
|
|
pattern Rcvd' :: AgentMsgId -> AgentMsgId -> AEvent 'AEConn
|
|
pattern Rcvd' aMsgId rcvdMsgId <- RCVD MsgMeta {integrity = MsgOk, recipient = (aMsgId, _)} [MsgReceipt {agentMsgId = rcvdMsgId, msgRcptStatus = MROk}]
|
|
|
|
smpCfgVPrev :: ProtocolClientConfig SMPVersion
|
|
smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
|
|
|
|
ntfCfgVPrev :: ProtocolClientConfig NTFVersion
|
|
ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)}
|
|
|
|
agentCfgVPrev :: AgentConfig
|
|
agentCfgVPrev = agentCfgVPrevPQ {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg}
|
|
|
|
agentCfgVPrevPQ :: AgentConfig
|
|
agentCfgVPrevPQ =
|
|
agentCfg
|
|
{ sndAuthAlg = C.AuthAlg C.SEd25519,
|
|
smpAgentVRange = prevRange $ smpAgentVRange agentCfg,
|
|
smpClientVRange = prevRange $ smpClientVRange agentCfg,
|
|
smpCfg = smpCfgVPrev,
|
|
ntfCfg = ntfCfgVPrev
|
|
}
|
|
|
|
agentCfgRatchetVPrev :: AgentConfig
|
|
agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg}
|
|
|
|
mkVersionRange :: Word16 -> Word16 -> VersionRange v
|
|
mkVersionRange v1 v2 = V.mkVersionRange (Version v1) (Version v2)
|
|
|
|
runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation
|
|
runRight_ action = withFrozenCallStack $ runExceptT action `shouldReturn` Right ()
|
|
|
|
runRight :: (Show e, HasCallStack) => ExceptT e IO a -> IO a
|
|
runRight action =
|
|
runExceptT action >>= \case
|
|
Right x -> pure x
|
|
Left e -> error $ "Unexpected error: " <> show e
|
|
|
|
runLeft :: (Show a, HasCallStack) => ExceptT e IO a -> IO e
|
|
runLeft action =
|
|
runExceptT action >>= \case
|
|
Right x -> error $ "unexpected result " <> show x
|
|
Left e -> pure e
|
|
|
|
getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission -> Bool] -> Expectation
|
|
getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts
|
|
|
|
inAnyOrder :: (Show a, MonadUnliftIO m, HasCallStack) => m a -> [a -> Bool] -> m ()
|
|
inAnyOrder _ [] = pure ()
|
|
inAnyOrder g rs = withFrozenCallStack $ do
|
|
r <- 5000000 `timeout` g >>= maybe (error "inAnyOrder timeout") pure
|
|
let rest = filter (not . expected r) rs
|
|
if length rest < length rs
|
|
then inAnyOrder g rest
|
|
else error $ "unexpected event: " <> show r
|
|
where
|
|
expected :: a -> (a -> Bool) -> Bool
|
|
expected r rp = rp r
|
|
|
|
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
|
|
createConnection c userId enableNtfs cMode clientData subMode = do
|
|
(connId, CCLink cReq _) <- A.createConnection c NRMInteractive userId enableNtfs True cMode Nothing clientData IKPQOn subMode
|
|
pure (connId, cReq)
|
|
|
|
joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
|
|
joinConnection c userId enableNtfs cReq connInfo subMode = do
|
|
connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
|
|
sndSecure <- A.joinConnection c NRMInteractive userId connId enableNtfs cReq connInfo PQSupportOn subMode
|
|
pure (connId, sndSecure)
|
|
|
|
acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE SndQueueSecured
|
|
acceptContact c = A.acceptContact c NRMInteractive
|
|
|
|
subscribeConnection :: AgentClient -> ConnId -> AE ()
|
|
subscribeConnection c = void . A.subscribeConnection c
|
|
|
|
sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId
|
|
sendMessage c connId msgFlags msgBody = do
|
|
(msgId, pqEnc) <- A.sendMessage c connId PQEncOn msgFlags msgBody
|
|
liftIO $ pqEnc `shouldBe` PQEncOn
|
|
pure msgId
|
|
|
|
deleteConnection :: AgentClient -> ConnId -> AE ()
|
|
deleteConnection c = A.deleteConnection c NRMInteractive
|
|
|
|
deleteConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ()))
|
|
deleteConnections c = A.deleteConnections c NRMInteractive
|
|
|
|
getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (FixedLinkData c, ConnLinkData c)
|
|
getConnShortLink c = A.getConnShortLink c NRMInteractive
|
|
|
|
setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AE (ConnShortLink c)
|
|
setConnShortLink c = A.setConnShortLink c NRMInteractive
|
|
|
|
suspendConnection :: AgentClient -> ConnId -> AE ()
|
|
suspendConnection c = A.suspendConnection c NRMInteractive
|
|
|
|
functionalAPITests :: (ASrvTransport, AStoreType) -> Spec
|
|
functionalAPITests ps = do
|
|
describe "Establishing duplex connection" $ do
|
|
testMatrix2 ps runAgentClientTest
|
|
it "should connect when server with multiple identities is stored" $
|
|
withSmpServer ps testServerMultipleIdentities
|
|
it "should connect with two peers" $
|
|
withSmpServer ps testAgentClient3
|
|
it "should establish connection without PQ encryption and enable it" $
|
|
withSmpServer ps testEnablePQEncryption
|
|
describe "Duplex connection - delivery stress test" $ do
|
|
describe "one way (50)" $ testMatrix2Stress ps $ runAgentClientStressTestOneWay 50
|
|
xdescribe "one way (1000)" $ testMatrix2Stress ps $ runAgentClientStressTestOneWay 1000
|
|
describe "two way concurrently (50)" $ testMatrix2Stress ps $ runAgentClientStressTestConc 50
|
|
xdescribe "two way concurrently (1000)" $ testMatrix2Stress ps $ runAgentClientStressTestConc 1000
|
|
describe "Establishing duplex connection, different PQ settings" $ do
|
|
testPQMatrix2 ps $ runAgentClientTestPQ False True
|
|
describe "Establishing duplex connection v2, different Ratchet versions" $
|
|
testRatchetMatrix2 ps runAgentClientTest
|
|
describe "Establish duplex connection via contact address" $
|
|
testMatrix2 ps runAgentClientContactTest
|
|
describe "Establish duplex connection via contact address, different PQ settings" $ do
|
|
testPQMatrix2NoInv ps $ runAgentClientContactTestPQ False True PQSupportOn
|
|
describe "Establish duplex connection via contact address v2, different Ratchet versions" $
|
|
testRatchetMatrix2 ps runAgentClientContactTest
|
|
describe "Establish duplex connection via contact address, different PQ settings" $ do
|
|
testPQMatrix3 ps $ runAgentClientContactTestPQ3 True
|
|
it "should support rejecting contact request" $
|
|
withSmpServer ps testRejectContactRequest
|
|
describe "Changing connection user id" $ do
|
|
it "should change user id for new connections" $ do
|
|
withSmpServer ps testUpdateConnectionUserId
|
|
describe "Establishing connection asynchronously" $ do
|
|
it "should connect with initiating client going offline" $
|
|
withSmpServer ps testAsyncInitiatingOffline
|
|
it "should connect with joining client going offline before its queue activation" $
|
|
withSmpServer ps testAsyncJoiningOfflineBeforeActivation
|
|
it "should connect with both clients going offline" $
|
|
withSmpServer ps testAsyncBothOffline
|
|
it "should connect on the second attempt if server was offline" $
|
|
testAsyncServerOffline ps
|
|
it "should restore confirmation after client restart" $
|
|
testAllowConnectionClientRestart ps
|
|
describe "Establishing connections with user retries" $ do
|
|
describe "Via invitation" $ do
|
|
it "should connect after errors" $ testInvitationErrors ps False
|
|
it "should connect after errors with client restarts" $ testInvitationErrors ps True
|
|
describe "Via contact" $ do
|
|
it "should connect after errors" $ testContactErrors ps False
|
|
it "should connect after errors with client restarts" $ testContactErrors ps True
|
|
describe "Short connection links" $ do
|
|
describe "should connect via 1-time short link" $ testProxyMatrix ps testInvitationShortLink
|
|
describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInvitationShortLinkAsync
|
|
describe "should connect via contact short link" $ testProxyMatrix ps testContactShortLink
|
|
describe "should add short link to existing contact and connect" $ testProxyMatrix ps testAddContactShortLink
|
|
xdescribe "try to create 1-time short link with prev versions" $ testProxyMatrixWithPrev ps testInvitationShortLinkPrev
|
|
describe "server restart" $ do
|
|
it "should get 1-time link data after restart" $ testInvitationShortLinkRestart ps
|
|
it "should connect via contact short link after restart" $ testContactShortLinkRestart ps
|
|
it "should connect via added contact short link after restart" $ testAddContactShortLinkRestart ps
|
|
it "should create and get short links with the old contact queues" $ testOldContactQueueShortLink ps
|
|
it "should connect via prepared connection link" $ testPrepareCreateConnectionLink ps
|
|
describe "Message delivery" $ do
|
|
describe "update connection agent version on received messages" $ do
|
|
it "should increase if compatible, shouldn'ps decrease" $
|
|
testIncreaseConnAgentVersion ps
|
|
it "should increase to max compatible version" $
|
|
testIncreaseConnAgentVersionMaxCompatible ps
|
|
it "should increase when connection was negotiated on different versions" $
|
|
testIncreaseConnAgentVersionStartDifferentVersion ps
|
|
-- TODO PQ tests for upgrading connection to PQ encryption
|
|
it "should deliver message after client restart" $
|
|
testDeliverClientRestart ps
|
|
it "should deliver messages to the user once, even if repeat delivery is made by the server (no ACK)" $
|
|
testDuplicateMessage ps
|
|
it "should report error via msg integrity on skipped messages" $
|
|
testSkippedMessages ps
|
|
it "should connect to the server when server goes up if it initially was down" $
|
|
testDeliveryAfterSubscriptionError ps
|
|
it "should deliver messages if one of connections has quota exceeded" $
|
|
testMsgDeliveryQuotaExceeded ps
|
|
describe "message expiration" $ do
|
|
it "should expire one message" $ testExpireMessage ps
|
|
it "should expire multiple messages" $ testExpireManyMessages ps
|
|
it "should expire one message if quota is exceeded" $ testExpireMessageQuota ps
|
|
it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota ps
|
|
it "should drop message after too many receive attempts" $ testDropMsgAfterRcvAttempts ps
|
|
#if !defined(dbPostgres)
|
|
-- TODO [postgres] restore from outdated db backup (we use copyFile/renameFile for sqlite)
|
|
describe "Ratchet synchronization" $ do
|
|
it "should report ratchet de-synchronization, synchronize ratchets" $
|
|
testRatchetSync ps
|
|
it "should synchronize ratchets after server being offline" $
|
|
testRatchetSyncServerOffline ps
|
|
it "should synchronize ratchets after client restart" $
|
|
testRatchetSyncClientRestart ps
|
|
it "should synchronize ratchets after suspend/foreground" $
|
|
testRatchetSyncSuspendForeground ps
|
|
it "should synchronize ratchets when clients start synchronization simultaneously" $
|
|
testRatchetSyncSimultaneous ps
|
|
#endif
|
|
describe "Subscription mode OnlyCreate" $ do
|
|
it "messages delivered only when polled (v8 - slow handshake)" $
|
|
withSmpServer ps testOnlyCreatePullSlowHandshake
|
|
it "messages delivered only when polled" $
|
|
withSmpServer ps testOnlyCreatePull
|
|
describe "Inactive client disconnection" $ do
|
|
it "should disconnect clients without subs if they were inactive longer than TTL" $
|
|
testInactiveNoSubs ps
|
|
it "should NOT disconnect inactive clients when they have subscriptions" $
|
|
testInactiveWithSubs ps
|
|
it "should NOT disconnect active clients" $
|
|
testActiveClientNotDisconnected ps
|
|
describe "Suspending agent" $ do
|
|
it "should update client when agent is suspended" $
|
|
withSmpServer ps testSuspendingAgent
|
|
it "should complete sending messages when agent is suspended" $
|
|
testSuspendingAgentCompleteSending ps
|
|
it "should suspend agent on timeout, even if pending messages not sent" $
|
|
testSuspendingAgentTimeout ps
|
|
describe "Batching SMP commands" $ do
|
|
-- disable this and enable the following test to run tests with coverage
|
|
it "should subscribe to multiple (200) subscriptions with batching" $
|
|
testBatchedSubscriptions 200 20 ps
|
|
skip "faster version of the previous test (200 subscriptions gets very slow with test coverage)" $
|
|
it "should subscribe to multiple (6) subscriptions with batching" $
|
|
testBatchedSubscriptions 6 3 ps
|
|
it "should subscribe to multiple connections with pending messages" $
|
|
withSmpServer ps $
|
|
testBatchedPendingMessages 10 5
|
|
describe "Batch send messages" $ do
|
|
it "should send multiple messages to the same connection" $ withSmpServer ps testSendMessagesB
|
|
it "should send messages to the 2 connections" $ withSmpServer ps testSendMessagesB2
|
|
describe "Async agent commands" $ do
|
|
describe "connect using async agent commands" $
|
|
testBasicMatrix2 ps testAsyncCommands
|
|
it "should add short link data using async agent command" $
|
|
testSetConnShortLinkAsync ps
|
|
it "should get short link data and join connection using async agent commands" $
|
|
testGetConnShortLinkAsync ps
|
|
it "should restore and complete async commands on restart" $
|
|
testAsyncCommandsRestore ps
|
|
describe "accept connection using async command" $
|
|
testBasicMatrix2 ps testAcceptContactAsync
|
|
it "should delete connections using async command when server connection fails" $
|
|
testDeleteConnectionAsync ps
|
|
it "join connection when reply queue creation fails (v8 - slow handshake)" $
|
|
testJoinConnectionAsyncReplyErrorV8 ps
|
|
it "join connection when reply queue creation fails" $
|
|
testJoinConnectionAsyncReplyError ps
|
|
describe "delete connection waiting for delivery" $ do
|
|
it "should delete connection immediately if there are no pending messages" $
|
|
testWaitDeliveryNoPending ps
|
|
it "should delete connection after waiting for delivery to complete" $
|
|
testWaitDelivery ps
|
|
it "should delete connection if message can'ps be delivered due to AUTH error" $
|
|
testWaitDeliveryAUTHErr ps
|
|
it "should delete connection by timeout even if message wasn't delivered" $
|
|
testWaitDeliveryTimeout ps
|
|
it "should delete connection by timeout, message in progress can be delivered" $
|
|
testWaitDeliveryTimeout2 ps
|
|
describe "Users" $ do
|
|
it "should create and delete user with connections" $
|
|
withSmpServer ps testUsers
|
|
it "should create and delete user without connections" $
|
|
withSmpServer ps testDeleteUserQuietly
|
|
it "should create and delete user with connections when server connection fails" $
|
|
testUsersNoServer ps
|
|
it "should connect two users and switch session mode" $
|
|
withSmpServer ps testTwoUsers
|
|
describe "Client service certificates" $ do
|
|
it "should connect, subscribe and reconnect as a service" $ testClientServiceConnection ps
|
|
it "should re-subscribe when service ID changed" $ testClientServiceIDChange ps
|
|
it "should clear pending service sub when service unavailable" $ testServiceUnavailableClearsPending ps
|
|
it "should recover when service ID changes on reconnect" $ testServiceIdChangeOnReconnect ps
|
|
it "should handle service unavailable on startup" $ testServiceUnavailableOnStartup ps
|
|
it "migrate connections to and from service" $ testMigrateConnectionsToService ps
|
|
describe "Connection switch" $ do
|
|
describe "should switch delivery to the new queue" $
|
|
testServerMatrix2 ps testSwitchConnection
|
|
describe "should switch to new queue asynchronously" $
|
|
testServerMatrix2 ps testSwitchAsync
|
|
describe "should delete connection during switch" $
|
|
testServerMatrix2 ps testSwitchDelete
|
|
describe "should abort switch in Started phase" $
|
|
testServerMatrix2 ps testAbortSwitchStarted
|
|
describe "should abort switch in Started phase, reinitiate immediately" $
|
|
testServerMatrix2 ps testAbortSwitchStartedReinitiate
|
|
describe "should prohibit to abort switch in Secured phase" $
|
|
testServerMatrix2 ps testCannotAbortSwitchSecured
|
|
describe "should switch two connections simultaneously" $
|
|
testServerMatrix2 ps testSwitch2Connections
|
|
describe "should switch two connections simultaneously, abort one" $
|
|
testServerMatrix2 ps testSwitch2ConnectionsAbort1
|
|
describe "SMP basic auth" $ do
|
|
forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do
|
|
let baseId = if v >= sndAuthKeySMPVersion then 1 else 3
|
|
sqSecured = if v >= sndAuthKeySMPVersion then True else False
|
|
describe ("v" <> show v <> ": with server auth") $ do
|
|
-- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail
|
|
it "success " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
|
|
it "disabled " $ testBasicAuth ps False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
|
|
it "NEW fail, no auth " $ testBasicAuth ps True (Just "abcd", v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
|
|
it "NEW fail, bad auth " $ testBasicAuth ps True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
|
|
it "JOIN fail, no auth " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 1
|
|
it "JOIN fail, bad auth " $ testBasicAuth ps True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) sqSecured baseId `shouldReturn` 1
|
|
describe ("v" <> show v <> ": no server auth") $ do
|
|
it "success " $ testBasicAuth ps True (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 2
|
|
it "srv disabled" $ testBasicAuth ps False (Nothing, v) (Nothing, v) (Nothing, v) sqSecured baseId `shouldReturn` 0
|
|
it "auth fst " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Nothing, v) sqSecured baseId `shouldReturn` 2
|
|
it "auth snd " $ testBasicAuth ps True (Nothing, v) (Nothing, v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
|
|
it "auth both " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
|
|
it "auth, disabled" $ testBasicAuth ps False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
|
|
describe "SMP server test via agent API" $ do
|
|
it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
|
|
let srv1 = testSMPServer2 {keyHash = "1234"}
|
|
it "should fail with incorrect fingerprint" $ do
|
|
testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
|
describe "server with password" $ do
|
|
let auth = Just "abcd"
|
|
srv = ProtoServerWithAuth testSMPServer2
|
|
authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH)
|
|
it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Nothing
|
|
it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` authErr
|
|
it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` authErr
|
|
describe "getRatchetAdHash" $
|
|
it "should return the same data for both peers" $
|
|
withSmpServer ps testRatchetAdHash
|
|
describe "Delivery receipts" $ do
|
|
it "should send and receive delivery receipt" $ withSmpServer ps testDeliveryReceipts
|
|
it "should send delivery receipt only in connection v3+" $ testDeliveryReceiptsVersion ps
|
|
it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent ps
|
|
describe "user network info" $ do
|
|
it "should wait for user network" testWaitForUserNetwork
|
|
it "should not reset online to offline if happens too quickly" testDoNotResetOnlineToOffline
|
|
it "should resume multiple threads" testResumeMultipleThreads
|
|
describe "SMP queue info" $ do
|
|
it "server should respond with queue and subscription information" $
|
|
withSmpServer ps testServerQueueInfo
|
|
#if !defined(dbServerPostgres)
|
|
describe "Client notices" $ do
|
|
it "should create client notice" $ testClientNotice ps
|
|
#endif
|
|
|
|
testBasicAuth :: (ASrvTransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
|
|
testBasicAuth (t, msType) allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do
|
|
let testCfg = updateCfg (cfgMS msType) $ \cfg' -> cfg' {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion}
|
|
canCreate1 = canCreateQueue allowNewQueues srv clnt1
|
|
canCreate2 = canCreateQueue allowNewQueues srv clnt2
|
|
expected
|
|
| canCreate1 && canCreate2 = 2
|
|
| canCreate1 = 1
|
|
| otherwise = 0
|
|
created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId
|
|
created `shouldBe` expected
|
|
pure created
|
|
|
|
canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> Bool
|
|
canCreateQueue allowNew (srvAuth, _) (clntAuth, _) =
|
|
allowNew && (isNothing srvAuth || srvAuth == clntAuth)
|
|
|
|
testMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
|
testMatrix2 ps runTest = do
|
|
it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
|
|
it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True
|
|
it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False
|
|
it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfgVPrev 1 $ runTest PQSupportOff False False
|
|
it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 1 $ runTest PQSupportOff False False
|
|
it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 1 $ runTest PQSupportOff False False
|
|
|
|
testMatrix2Stress :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
|
testMatrix2Stress ps runTest = do
|
|
it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
|
|
it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 initAgentServersProxy 1 $ runTest PQSupportOn False True
|
|
it "current" $ withSmpServer ps $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn True False
|
|
it "prev" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfgVPrev 1 $ runTest PQSupportOff False False
|
|
it "prev to current" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfg 1 $ runTest PQSupportOff False False
|
|
it "current to prev" $ withSmpServer ps $ runTestCfg2 aCfg aCfgVPrev 1 $ runTest PQSupportOff False False
|
|
where
|
|
aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval}
|
|
aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval}
|
|
aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval}
|
|
|
|
testBasicMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
|
testBasicMatrix2 ps runTest = do
|
|
it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest True
|
|
it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 1 $ runTest False
|
|
it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 1 $ runTest False
|
|
it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 1 $ runTest False
|
|
|
|
testRatchetMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
|
testRatchetMatrix2 ps runTest = do
|
|
it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
|
|
it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True
|
|
it "ratchet current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False
|
|
it "ratchet prev" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False
|
|
it "ratchets prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False
|
|
it "ratchets current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False
|
|
|
|
testServerMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec
|
|
testServerMatrix2 ps runTest = do
|
|
it "1 server" $ withSmpServer ps $ runTest initAgentServers
|
|
it "2 servers" $ withSmpServers2 ps $ runTest initAgentServers2
|
|
|
|
testProxyMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
|
|
testProxyMatrix ps runTest = do
|
|
it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False
|
|
it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True
|
|
|
|
testProxyMatrixWithPrev :: HasCallStack => (ASrvTransport, AStoreType) -> (Bool -> Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
|
|
testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do
|
|
it "2 servers, directly, curr clients, prev servers" $ withSmpServers2Prev $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False True
|
|
it "2 servers, via proxy, curr clients, prev servers" $ withSmpServersProxy2Prev $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True True
|
|
it "2 servers, directly, prev clients, curr servers" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServers) (agentCfgVPrevPQ, initAgentServers2) $ runTest False False
|
|
it "2 servers, via proxy, prev clients, curr servers" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServersProxy) (agentCfgVPrevPQ, initAgentServersProxy2) $ runTest True False
|
|
where
|
|
prev cfg' = updateCfg cfg' $ \cfg_ -> cfg_ {smpServerVRange = prevRange supportedServerSMPRelayVRange}
|
|
withSmpServers2Prev a = withServers2 (prev $ cfgMS msType) (prev $ cfgJ2QS qs) a
|
|
withSmpServersProxy2Prev a = withServers2 (prev $ proxyCfgMS msType) (prev $ proxyCfgJ2QS qs) a
|
|
withServers2 cfg1 cfg2 a =
|
|
withSmpServerConfigOn t cfg1 testPort $ \_ -> withSmpServerConfigOn t cfg2 testPort2 $ \_ -> a
|
|
|
|
testPQMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
|
|
testPQMatrix2 = pqMatrix2_ True
|
|
|
|
testPQMatrix2NoInv :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
|
|
testPQMatrix2NoInv = pqMatrix2_ False
|
|
|
|
pqMatrix2_ :: HasCallStack => Bool -> (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
|
|
pqMatrix2_ pqInv ps test = do
|
|
it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
|
|
it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
|
|
it "pq/dh handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff)
|
|
it "pq/pq handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn)
|
|
when pqInv $ do
|
|
it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff)
|
|
it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn)
|
|
where
|
|
runTest = withSmpServerProxy ps . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3
|
|
|
|
testPQMatrix3 ::
|
|
HasCallStack =>
|
|
(ASrvTransport, AStoreType) ->
|
|
(HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) ->
|
|
Spec
|
|
testPQMatrix3 ps test = do
|
|
it "dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff)
|
|
it "dh/dh/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn)
|
|
it "dh/pq/dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff)
|
|
it "dh/pq/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn)
|
|
it "pq/dh/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff)
|
|
it "pq/dh/pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn)
|
|
it "pq/pq/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff)
|
|
it "pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn)
|
|
where
|
|
runTest test' =
|
|
withSmpServerProxy ps $
|
|
runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 servers 3 $ \a b baseMsgId ->
|
|
withAgent 3 agentProxyCfgV8 servers testDB3 $ \c -> test' a b c baseMsgId
|
|
servers = initAgentServersProxy
|
|
|
|
runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
|
|
runTestCfg2 aCfg bCfg = runTestCfgServers2 aCfg bCfg initAgentServers
|
|
{-# INLINE runTestCfg2 #-}
|
|
|
|
runTestCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
|
|
runTestCfgServers2 aCfg bCfg servers baseMsgId runTest =
|
|
withAgentClientsCfgServers2 aCfg bCfg servers $ \a b -> runTest a b baseMsgId
|
|
{-# INLINE runTestCfgServers2 #-}
|
|
|
|
withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
|
|
withAgentClientsCfgServers2 aCfg bCfg servers runTest =
|
|
withAgent 1 aCfg servers testDB $ \a ->
|
|
withAgent 2 bCfg servers testDB2 $ \b ->
|
|
runTest a b
|
|
|
|
withAgentClientsServers2 :: HasCallStack => (AgentConfig, InitialAgentServers) -> (AgentConfig, InitialAgentServers) -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
|
|
withAgentClientsServers2 (aCfg, aServers) (bCfg, bServers) runTest =
|
|
withAgent 1 aCfg aServers testDB $ \a ->
|
|
withAgent 2 bCfg bServers testDB2 $ \b ->
|
|
runTest a b
|
|
|
|
withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
|
|
withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers
|
|
{-# INLINE withAgentClientsCfg2 #-}
|
|
|
|
withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
|
|
withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg
|
|
{-# INLINE withAgentClients2 #-}
|
|
|
|
withAgentClients3 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> AgentClient -> IO ()) -> IO ()
|
|
withAgentClients3 runTest =
|
|
withAgentClients2 $ \a b ->
|
|
withAgent 3 agentCfg initAgentServers testDB3 $ \c ->
|
|
runTest a b c
|
|
|
|
runAgentClientTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
|
runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId =
|
|
runAgentClientTestPQ sqSecured viaProxy (alice, IKLinkPQ pqSupport) (bob, pqSupport) baseId
|
|
|
|
runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
|
runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
|
|
runRight_ $ do
|
|
(bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing aPQ SMSubscribe
|
|
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
|
sqSecured' <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
|
liftIO $ sqSecured' `shouldBe` sqSecured
|
|
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
|
liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ
|
|
get alice ##> ("", bobId, A.CON pqEnc)
|
|
get bob ##> ("", aliceId, A.INFO bPQ "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 proxySrv = if viaProxy then Just testSMPServer else Nothing
|
|
1 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, A.SENT (baseId + 1) proxySrv)
|
|
2 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "how are you?"
|
|
get alice ##> ("", bobId, A.SENT (baseId + 2) proxySrv)
|
|
get bob =##> \case ("", c, Msg' _ pq "hello") -> c == aliceId && pq == pqEnc; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
get bob =##> \case ("", c, Msg' _ pq "how are you?") -> c == aliceId && pq == pqEnc; _ -> False
|
|
ackMessage bob aliceId (baseId + 2) Nothing
|
|
3 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, A.SENT (baseId + 3) proxySrv)
|
|
4 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 1"
|
|
get bob ##> ("", aliceId, A.SENT (baseId + 4) proxySrv)
|
|
get alice =##> \case ("", c, Msg' _ pq "hello too") -> c == bobId && pq == pqEnc; _ -> False
|
|
ackMessage alice bobId (baseId + 3) Nothing
|
|
get alice =##> \case ("", c, Msg' _ pq "message 1") -> c == bobId && pq == pqEnc; _ -> False
|
|
ackMessage alice bobId (baseId + 4) Nothing
|
|
suspendConnection alice bobId
|
|
5 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 2"
|
|
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False
|
|
deleteConnection alice bobId
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
where
|
|
msgId = subtract baseId . fst
|
|
|
|
pqConnectionMode :: InitialKeys -> PQSupport -> Bool
|
|
pqConnectionMode pqMode1 pqMode2 = supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2
|
|
|
|
runAgentClientStressTestOneWay :: HasCallStack => Int64 -> PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
|
runAgentClientStressTestOneWay n pqSupport sqSecured viaProxy alice bob baseId = runRight_ $ do
|
|
let pqEnc = PQEncryption $ supportPQ pqSupport
|
|
(aliceId, bobId) <- makeConnection_ pqSupport sqSecured alice bob
|
|
let proxySrv = if viaProxy then Just testSMPServer else Nothing
|
|
message i = "message " <> bshow i
|
|
concurrently_
|
|
( forM_ ([1 .. n] :: [Int64]) $ \i -> do
|
|
mId <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags (message i)
|
|
liftIO $ do
|
|
mId >= i `shouldBe` True
|
|
let getEvent =
|
|
get alice >>= \case
|
|
("", c, A.SENT mId' srv) -> c == bobId && mId' >= baseId + i && srv == proxySrv `shouldBe` True
|
|
("", c, QCONT) -> do
|
|
c == bobId `shouldBe` True
|
|
getEvent
|
|
r -> expectationFailure $ "wrong message: " <> show r
|
|
getEvent
|
|
)
|
|
( forM_ ([1 .. n] :: [Int64]) $ \i -> do
|
|
get bob >>= \case
|
|
("", c, Msg' mId pq msg) -> do
|
|
liftIO $ c == aliceId && mId >= baseId + i && pq == pqEnc && msg == message i `shouldBe` True
|
|
ackMessage bob aliceId mId Nothing
|
|
r -> liftIO $ expectationFailure $ "wrong message: " <> show r
|
|
)
|
|
liftIO $ noMessagesIngoreQCONT alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessagesIngoreQCONT bob "nothing else should be delivered to bob"
|
|
where
|
|
msgId = subtract baseId . fst
|
|
|
|
runAgentClientStressTestConc :: HasCallStack => Int64 -> PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
|
runAgentClientStressTestConc n pqSupport sqSecured viaProxy alice bob _baseId = runRight_ $ do
|
|
(aliceId, bobId) <- makeConnection_ pqSupport sqSecured alice bob
|
|
amId <- newTVarIO 0
|
|
bmId <- newTVarIO 0
|
|
let n2 = n `div` 2
|
|
mapConcurrently_ id
|
|
( [ send alice bobId [1 .. n2],
|
|
send alice bobId [n2 + 1 .. n],
|
|
send bob aliceId [1 .. n2],
|
|
send bob aliceId [n2 + 1 .. n],
|
|
receive alice bobId amId (n, n, n, 2 * n),
|
|
receive bob aliceId bmId (n, n, n, 2 * n)
|
|
] :: [ExceptT AgentErrorType IO ()]
|
|
)
|
|
liftIO $ noMessagesIngoreQCONT alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessagesIngoreQCONT bob "nothing else should be delivered to bob"
|
|
where
|
|
pqEnc = PQEncryption $ supportPQ pqSupport
|
|
proxySrv = if viaProxy then Just testSMPServer else Nothing
|
|
message i = "message " <> bshow i
|
|
send :: AgentClient -> ConnId -> [Int64] -> ExceptT AgentErrorType IO ()
|
|
send a bId = mapM_ $ \i -> void $ A.sendMessage a bId pqEnc SMP.noMsgFlags (message i)
|
|
receive :: AgentClient -> ConnId -> TVar AgentMsgId -> (Int64, Int64, Int64, Int64) -> ExceptT AgentErrorType IO ()
|
|
receive a bId mIdVar acc' = loop acc' >> liftIO drain
|
|
where
|
|
drain =
|
|
timeout 100000 (get a)
|
|
>>= mapM_ (\case ("", _, QCONT) -> drain; r -> expectationFailure $ "unexpected: " <> show r)
|
|
loop (0, 0, 0, 0) = pure ()
|
|
loop acc@(s, !m, !r, !o) =
|
|
timeout 3000000 (get a) >>= \case
|
|
Nothing -> error $ "timeout " <> show acc
|
|
Just evt -> case evt of
|
|
("", c, A.SENT _mId srv) -> do
|
|
liftIO $ c == bId && srv == proxySrv `shouldBe` True
|
|
unless (s > 0) $ error "unexpected SENT"
|
|
loop (s - 1, m, r, o)
|
|
("", c, QCONT) -> do
|
|
liftIO $ c == bId `shouldBe` True
|
|
loop (s, m, r, o)
|
|
("", c, Msg' mId pq msg) -> do
|
|
-- tests that mId increases
|
|
liftIO $ (mId >) <$> atomically (swapTVar mIdVar mId) `shouldReturn` True
|
|
liftIO $ c == bId && pq == pqEnc && ("message " `B.isPrefixOf` msg) `shouldBe` True
|
|
ackMessageAsync a "123" bId mId (Just "")
|
|
unless (m > 0) $ error "unexpected MSG"
|
|
loop (s, m - 1, r, o)
|
|
("", c, Rcvd' mId _rcvdMsgId) -> do
|
|
liftIO $ (mId >) <$> atomically (swapTVar mIdVar mId) `shouldReturn` True
|
|
liftIO $ c == bId `shouldBe` True
|
|
ackMessageAsync a "123" bId mId Nothing
|
|
unless (r > 0) $ error "unexpected RCVD"
|
|
loop (s, m, r - 1, o)
|
|
("123", c, OK) -> do
|
|
liftIO $ c == bId `shouldBe` True
|
|
unless (o > 0) $ error "unexpected OK"
|
|
loop (s, m, r, o - 1)
|
|
_ -> liftIO $ expectationFailure $ "unexpected: " <> show r
|
|
|
|
testEnablePQEncryption :: HasCallStack => IO ()
|
|
testEnablePQEncryption =
|
|
withAgentClients2 $ \ca cb -> runRight_ $ do
|
|
g <- liftIO C.newRandom
|
|
(aId, bId) <- makeConnection_ PQSupportOff True ca cb
|
|
let a = (ca, aId)
|
|
b = (cb, bId)
|
|
(a, 2, "msg 1") \#>\ b
|
|
(b, 3, "msg 2") \#>\ a
|
|
-- 45 bytes is used by agent message envelope inside double ratchet message envelope
|
|
let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g'
|
|
lrg <- largeMsg g PQSupportOff
|
|
(a, 4, lrg) \#>\ b
|
|
(b, 5, lrg) \#>\ a
|
|
-- switched to smaller envelopes (before reporting PQ encryption enabled)
|
|
sml <- largeMsg g PQSupportOn
|
|
-- fail because of message size
|
|
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
|
|
(7, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml
|
|
get ca =##> \case ("", connId, SENT 7) -> connId == bId; _ -> False
|
|
get cb =##> \case ("", connId, MsgErr' 6 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False
|
|
ackMessage cb aId 6 Nothing
|
|
-- -- fail in reply to sync IDss
|
|
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
|
|
(8, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml
|
|
get cb =##> \case ("", connId, SENT 8) -> connId == aId; _ -> False
|
|
get ca =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False
|
|
ackMessage ca bId 8 Nothing
|
|
(a, 9, sml) \#>! b
|
|
-- PQ encryption now enabled
|
|
(b, 10, sml) !#>! a
|
|
(a, 11, sml) !#>! b
|
|
(b, 12, sml) !#>! a
|
|
-- disabling PQ encryption
|
|
(a, 13, sml) !#>\ b
|
|
(b, 14, sml) !#>\ a
|
|
(a, 15, sml) \#>\ b
|
|
(b, 16, sml) \#>\ a
|
|
-- enabling PQ encryption again
|
|
(a, 17, sml) \#>! b
|
|
(b, 18, sml) \#>! a
|
|
(a, 19, sml) \#>! b
|
|
(b, 20, sml) !#>! a
|
|
(a, 21, sml) !#>! b
|
|
-- disabling PQ encryption again
|
|
(b, 22, sml) !#>\ a
|
|
(a, 23, sml) !#>\ b
|
|
(b, 24, sml) \#>\ a
|
|
(a, 25, sml) \#>\ b
|
|
-- PQ encryption is now disabled, but support remained enabled, so we still cannot send larger messages
|
|
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456")
|
|
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456")
|
|
pure ()
|
|
where
|
|
(\#>\) = PQEncOff `sndRcv` PQEncOff
|
|
(\#>!) = PQEncOff `sndRcv` PQEncOn
|
|
(!#>!) = PQEncOn `sndRcv` PQEncOn
|
|
(!#>\) = PQEncOn `sndRcv` PQEncOff
|
|
|
|
sndRcv :: PQEncryption -> PQEncryption -> ((AgentClient, ConnId), AgentMsgId, MsgBody) -> (AgentClient, ConnId) -> ExceptT AgentErrorType IO ()
|
|
sndRcv pqEnc pqEnc' ((c1, id1), mId, msg) (c2, id2) = do
|
|
r <- A.sendMessage c1 id2 pqEnc' SMP.noMsgFlags msg
|
|
liftIO $ r `shouldBe` (mId, pqEnc)
|
|
get c1 =##> \case ("", connId, SENT mId') -> connId == id2 && mId' == mId; _ -> False
|
|
get c2 =##> \case ("", connId, Msg' mId' pq msg') -> connId == id1 && mId' == mId && msg' == msg && pq == pqEnc; _ -> False
|
|
ackMessage c2 id1 mId Nothing
|
|
|
|
testAgentClient3 :: HasCallStack => IO ()
|
|
testAgentClient3 =
|
|
withAgentClients3 $ \a b c -> runRight_ $ do
|
|
(aIdForB, bId) <- makeConnection a b
|
|
(aIdForC, cId) <- makeConnection a c
|
|
|
|
2 <- sendMessage a bId SMP.noMsgFlags "b4"
|
|
2 <- sendMessage a cId SMP.noMsgFlags "c4"
|
|
3 <- sendMessage a bId SMP.noMsgFlags "b5"
|
|
3 <- sendMessage a cId SMP.noMsgFlags "c5"
|
|
get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False
|
|
get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False
|
|
get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False
|
|
get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False
|
|
get b =##> \case ("", connId, Msg "b4") -> connId == aIdForB; _ -> False
|
|
ackMessage b aIdForB 2 Nothing
|
|
get b =##> \case ("", connId, Msg "b5") -> connId == aIdForB; _ -> False
|
|
ackMessage b aIdForB 3 Nothing
|
|
get c =##> \case ("", connId, Msg "c4") -> connId == aIdForC; _ -> False
|
|
ackMessage c aIdForC 2 Nothing
|
|
get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False
|
|
ackMessage c aIdForC 3 Nothing
|
|
|
|
runAgentClientContactTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
|
runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
|
|
runAgentClientContactTestPQ sqSecured viaProxy pqSupport (alice, IKLinkPQ pqSupport) (bob, pqSupport) baseId
|
|
|
|
runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
|
runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
|
|
runRight_ $ do
|
|
(_, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ SMSubscribe
|
|
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
|
sqSecuredJoin <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
|
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
|
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
|
|
liftIO $ pqSup' `shouldBe` reqPQSupport
|
|
bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
|
|
sqSecured' <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
|
|
liftIO $ sqSecured' `shouldBe` sqSecured
|
|
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
|
|
liftIO $ pqSup'' `shouldBe` bPQ
|
|
allowConnection bob aliceId confId "bob's connInfo"
|
|
let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ
|
|
get alice ##> ("", bobId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo")
|
|
get alice ##> ("", bobId, A.CON pqEnc)
|
|
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 proxySrv = if viaProxy then Just testSMPServer else Nothing
|
|
1 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, A.SENT (baseId + 1) proxySrv)
|
|
2 <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags "how are you?"
|
|
get alice ##> ("", bobId, A.SENT (baseId + 2) proxySrv)
|
|
get bob =##> \case ("", c, Msg' _ pq "hello") -> c == aliceId && pq == pqEnc; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
get bob =##> \case ("", c, Msg' _ pq "how are you?") -> c == aliceId && pq == pqEnc; _ -> False
|
|
ackMessage bob aliceId (baseId + 2) Nothing
|
|
3 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, A.SENT (baseId + 3) proxySrv)
|
|
4 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 1"
|
|
get bob ##> ("", aliceId, A.SENT (baseId + 4) proxySrv)
|
|
get alice =##> \case ("", c, Msg' _ pq "hello too") -> c == bobId && pq == pqEnc; _ -> False
|
|
ackMessage alice bobId (baseId + 3) Nothing
|
|
get alice =##> \case ("", c, Msg' _ pq "message 1") -> c == bobId && pq == pqEnc; _ -> False
|
|
ackMessage alice bobId (baseId + 4) Nothing
|
|
suspendConnection alice bobId
|
|
5 <- msgId <$> A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "message 2"
|
|
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False
|
|
deleteConnection alice bobId
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
where
|
|
msgId = subtract baseId . fst
|
|
|
|
runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
|
runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
|
|
(_, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ SMSubscribe
|
|
(bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
|
|
sentMessages abPQEnc alice bobId bob bAliceId
|
|
(tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
|
|
sentMessages atPQEnc alice tomId tom tAliceId
|
|
where
|
|
msgId = subtract baseId . fst
|
|
connectViaContact b pq qInfo = do
|
|
aId <- A.prepareConnectionToJoin b 1 True qInfo pq
|
|
sqSecuredJoin <- A.joinConnection b NRMInteractive 1 aId True qInfo "bob's connInfo" pq SMSubscribe
|
|
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
|
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
|
|
liftIO $ pqSup' `shouldBe` PQSupportOn
|
|
bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
|
|
sqSecuredAccept <- acceptContact alice 1 bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
|
|
liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8
|
|
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
|
|
liftIO $ pqSup'' `shouldBe` pq
|
|
allowConnection b aId confId "bob's connInfo"
|
|
let pqEnc = PQEncryption $ pqConnectionMode aPQ pq
|
|
get alice ##> ("", bId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo")
|
|
get alice ##> ("", bId, A.CON pqEnc)
|
|
get b ##> ("", aId, A.CON pqEnc)
|
|
pure (aId, bId, pqEnc)
|
|
sentMessages pqEnc a bId b aId = do
|
|
let proxySrv = if viaProxy then Just testSMPServer else Nothing
|
|
1 <- msgId <$> A.sendMessage a bId pqEnc SMP.noMsgFlags "hello"
|
|
get a ##> ("", bId, A.SENT (baseId + 1) proxySrv)
|
|
get b =##> \case ("", c, Msg' _ pq "hello") -> c == aId && pq == pqEnc; _ -> False
|
|
ackMessage b aId (baseId + 1) Nothing
|
|
2 <- msgId <$> A.sendMessage b aId pqEnc SMP.noMsgFlags "hello too"
|
|
get b ##> ("", aId, A.SENT (baseId + 2) proxySrv)
|
|
get a =##> \case ("", c, Msg' _ pq "hello too") -> c == bId && pq == pqEnc; _ -> False
|
|
ackMessage a bId (baseId + 2) Nothing
|
|
|
|
noMessages :: HasCallStack => AgentClient -> String -> Expectation
|
|
noMessages = noMessages_ False
|
|
|
|
noMessagesIngoreQCONT :: AgentClient -> String -> Expectation
|
|
noMessagesIngoreQCONT = noMessages_ True
|
|
|
|
noMessages_ :: Bool -> HasCallStack => AgentClient -> String -> Expectation
|
|
noMessages_ ingoreQCONT c err = tryGet `shouldReturn` ()
|
|
where
|
|
tryGet =
|
|
50000 `timeout` get c >>= \case
|
|
Just (_, _, QCONT) | ingoreQCONT -> noMessages_ ingoreQCONT c err
|
|
Just msg -> error $ err <> ": " <> show msg
|
|
Nothing -> return ()
|
|
|
|
testRejectContactRequest :: HasCallStack => IO ()
|
|
testRejectContactRequest =
|
|
withAgentClients2 $ \alice bob -> runRight_ $ do
|
|
(_addrConnId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
|
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
|
sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
|
|
("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
|
|
rejectContact alice invId
|
|
liftIO $ noMessages bob "nothing delivered to bob"
|
|
|
|
testUpdateConnectionUserId :: HasCallStack => IO ()
|
|
testUpdateConnectionUserId =
|
|
withAgentClients2 $ \alice bob -> runRight_ $ do
|
|
(connId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
newUserId <- createUser alice False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
|
|
_ <- changeConnectionUser alice 1 connId newUserId
|
|
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
|
sqSecured' <- 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 connId confId "alice's connInfo"
|
|
let pqEnc = CR.pqSupportToEnc PQSupportOn
|
|
get alice ##> ("", connId, A.CON pqEnc)
|
|
get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo")
|
|
get bob ##> ("", aliceId, A.CON pqEnc)
|
|
|
|
testAsyncInitiatingOffline :: HasCallStack => IO ()
|
|
testAsyncInitiatingOffline =
|
|
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do
|
|
alice <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
(bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
liftIO $ disposeAgentClient alice
|
|
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` True
|
|
|
|
-- send messages
|
|
msgId1 <- A.sendMessage bob aliceId PQEncOn SMP.noMsgFlags "can send 1"
|
|
liftIO $ msgId1 `shouldBe` (2, PQEncOff)
|
|
get bob ##> ("", aliceId, SENT 2)
|
|
msgId2 <- A.sendMessage bob aliceId PQEncOn SMP.noMsgFlags "can send 2"
|
|
liftIO $ msgId2 `shouldBe` (3, PQEncOff)
|
|
get bob ##> ("", aliceId, SENT 3)
|
|
|
|
alice' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB
|
|
subscribeConnection alice' bobId
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice'
|
|
-- receive messages
|
|
get alice' =##> \case ("", c, Msg' mId pq "can send 1") -> c == bobId && mId == 1 && pq == PQEncOff; _ -> False
|
|
ackMessage alice' bobId 1 Nothing
|
|
get alice' =##> \case ("", c, Msg' mId pq "can send 2") -> c == bobId && mId == 2 && pq == PQEncOff; _ -> False
|
|
ackMessage alice' bobId 2 Nothing
|
|
-- for alice msg id 3 is sent confirmation, then they're matched with bob at msg id 4
|
|
|
|
-- allow connection
|
|
allowConnection alice' bobId confId "alice's connInfo"
|
|
get alice' ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob ##> ("", aliceId, CON)
|
|
exchangeGreetingsMsgId 4 alice' bobId bob aliceId
|
|
liftIO $ disposeAgentClient alice'
|
|
|
|
testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO ()
|
|
testAsyncJoiningOfflineBeforeActivation =
|
|
withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight_ $ do
|
|
bob <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` True
|
|
liftIO $ disposeAgentClient bob
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
bob' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
|
subscribeConnection bob' aliceId
|
|
get alice ##> ("", bobId, CON)
|
|
get bob' ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob' ##> ("", aliceId, CON)
|
|
exchangeGreetings alice bobId bob' aliceId
|
|
liftIO $ disposeAgentClient bob'
|
|
|
|
testAsyncBothOffline :: HasCallStack => IO ()
|
|
testAsyncBothOffline = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
runRight_ $ do
|
|
(bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
liftIO $ disposeAgentClient alice
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` True
|
|
liftIO $ disposeAgentClient bob
|
|
alice' <- liftIO $ getSMPAgentClient' 3 agentCfg initAgentServers testDB
|
|
subscribeConnection alice' bobId
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice'
|
|
allowConnection alice' bobId confId "alice's connInfo"
|
|
bob' <- liftIO $ getSMPAgentClient' 4 agentCfg initAgentServers testDB2
|
|
subscribeConnection bob' aliceId
|
|
get alice' ##> ("", bobId, CON)
|
|
get bob' ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob' ##> ("", aliceId, CON)
|
|
exchangeGreetings alice' bobId bob' aliceId
|
|
liftIO $ disposeAgentClient alice'
|
|
liftIO $ disposeAgentClient bob'
|
|
|
|
testAsyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
|
|
-- create connection and shutdown the server
|
|
(bobId, cReq) <- withSmpServerStoreLogOn ps testPort $ \_ ->
|
|
runRight $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
-- connection fails
|
|
Left (BROKER _ (NETWORK _)) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
|
|
("", "", DOWN srv conns) <- nGet alice
|
|
srv `shouldBe` testSMPServer
|
|
conns `shouldBe` [bobId]
|
|
-- connection succeeds after server start
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
("", "", UP srv1 conns1) <- nGet alice
|
|
liftIO $ do
|
|
srv1 `shouldBe` testSMPServer
|
|
conns1 `shouldBe` [bobId]
|
|
liftIO $ threadDelay 250000
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` True
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
get alice ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob ##> ("", aliceId, CON)
|
|
exchangeGreetings alice bobId bob aliceId
|
|
|
|
testAllowConnectionClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testAllowConnectionClientRestart ps@(t, ASType qsType _) = do
|
|
let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServersSrv2 testDB2
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
(aliceId, bobId, confId) <-
|
|
withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do
|
|
runRight $ do
|
|
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` True
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice
|
|
pure (aliceId, bobId, confId)
|
|
|
|
("", "", DOWN _ _) <- nGet bob
|
|
|
|
runRight_ $ do
|
|
allowConnectionAsync alice "1" bobId confId "alice's connInfo"
|
|
get alice ##> ("1", bobId, OK)
|
|
pure ()
|
|
|
|
threadDelay 100000 -- give time to enqueue confirmation (enqueueConfirmation)
|
|
disposeAgentClient alice
|
|
threadDelay 250000
|
|
|
|
alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
|
|
runRight_ $ subscribeConnection alice2 bobId
|
|
threadDelay 500000
|
|
withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do
|
|
runRight $ do
|
|
("", "", UP _ _) <- nGet bob
|
|
get alice2 ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob ##> ("", aliceId, CON)
|
|
exchangeGreetings alice2 bobId bob aliceId
|
|
disposeAgentClient alice2
|
|
disposeAgentClient bob
|
|
|
|
testInvitationErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO ()
|
|
testInvitationErrors ps restart = do
|
|
a <- getAgentA
|
|
b <- getAgentB
|
|
(bId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMInvitation Nothing SMSubscribe
|
|
("", "", DOWN _ [_]) <- nGet a
|
|
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
|
-- fails to secure the queue on testPort
|
|
BROKER srv (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
|
(testPort `isSuffixOf` srv) `shouldBe` True
|
|
withServer1 ps $ do
|
|
("", "", UP _ [_]) <- nGet a
|
|
let loopSecure = do
|
|
-- secures the queue on testPort, but fails to create reply queue on testPort2
|
|
BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
|
unless (testPort2 `isSuffixOf` srv2) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure
|
|
loopSecure
|
|
("", "", DOWN _ [_]) <- nGet a
|
|
b' <- withServer2 ps $ do
|
|
threadDelay 200000
|
|
let loopCreate = do
|
|
-- creates the reply queue on testPort2, but fails to send it to testPort
|
|
BROKER srv' (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
|
unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate
|
|
loopCreate
|
|
restartAgentB restart b [aId]
|
|
("", "", DOWN _ [_]) <- nGet b'
|
|
n <- withServer1 ps $ do
|
|
("", "", UP _ [_]) <- nGet a
|
|
threadDelay 200000
|
|
let loopConfirm n =
|
|
runExceptT (A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
|
|
Right True -> pure n
|
|
Right r -> error $ "unexpected result " <> show r
|
|
Left _ -> putStrLn "retrying confirm" >> threadDelay 200000 >> loopConfirm (n + 1)
|
|
n <- loopConfirm 1
|
|
runRight $ do
|
|
("", _, CONF confId _ "bob's connInfo") <- get a
|
|
allowConnectionAsync a "1" bId confId "alice's connInfo"
|
|
get a ##> ("1", bId, OK)
|
|
pure n
|
|
("", "", DOWN _ [_]) <- nGet a
|
|
withServer2 ps $ do
|
|
get a ##> ("", bId, CON) -- note that server 1 is down, CON event is sent when HELLO is sent to server 2
|
|
("", "", UP _ [_]) <- nGet b'
|
|
get b' ##> ("", aId, INFO "alice's connInfo")
|
|
get b' ##> ("", aId, CON)
|
|
withServer1 ps $ do
|
|
("", "", UP _ [_]) <- nGet a
|
|
runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn 2 (2 + n) a bId b' aId
|
|
disposeAgentClient a
|
|
disposeAgentClient b'
|
|
|
|
restartAgentA :: Bool -> AgentClient -> [ConnId] -> IO AgentClient
|
|
restartAgentA = restartAgent_ getAgentA
|
|
|
|
restartAgentB :: Bool -> AgentClient -> [ConnId] -> IO AgentClient
|
|
restartAgentB = restartAgent_ getAgentB
|
|
|
|
restartAgent_ :: IO AgentClient -> Bool -> AgentClient -> [ConnId] -> IO AgentClient
|
|
restartAgent_ getAgent restart c cIds
|
|
| restart = do
|
|
disposeAgentClient c
|
|
threadDelay 200000
|
|
c' <- getAgent
|
|
rs <- runRight $ subscribeConnections c' cIds
|
|
all isRight rs `shouldBe` True
|
|
pure c'
|
|
| otherwise = pure c
|
|
|
|
testContactErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO ()
|
|
testContactErrors ps restart = do
|
|
a <- getAgentA
|
|
b <- getAgentB
|
|
(contactId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMContact Nothing SMSubscribe
|
|
("", "", DOWN _ [_]) <- nGet a
|
|
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
|
-- fails to create queue on testPort2
|
|
BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
|
(testPort2 `isSuffixOf` srv2) `shouldBe` True
|
|
b' <- restartAgentB restart b [aId]
|
|
let loopCreate2 = do
|
|
-- creates the reply queue on testPort2, but fails to send invitation to testPort
|
|
BROKER srv' (NETWORK _) <- runLeft $ A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
|
unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create 2" >> threadDelay 200000 >> loopCreate2
|
|
b'' <- withServer2 ps $ do
|
|
loopCreate2
|
|
restartAgentB restart b' [aId]
|
|
("", "", DOWN _ [_]) <- nGet b''
|
|
invId <- withServer1 ps $ do
|
|
("", "", UP _ [_]) <- nGet a
|
|
let loopSend = do
|
|
-- sends the invitation to testPort
|
|
runExceptT (A.joinConnection b'' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case
|
|
Right False -> pure ()
|
|
Right r -> error $ "unexpected result " <> show r
|
|
Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend
|
|
loopSend
|
|
("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get a
|
|
pure invId
|
|
("", "", DOWN _ [_]) <- nGet a
|
|
bId <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
|
withServer2 ps $ do
|
|
("", "", UP _ [_]) <- nGet b''
|
|
let loopSecure = do
|
|
-- secures the queue on testPort2, but fails to create reply queue on testPort
|
|
BROKER srv (NETWORK _) <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
unless (testPort `isSuffixOf` srv) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure
|
|
loopSecure
|
|
("", "", DOWN _ [_]) <- nGet b''
|
|
a' <- withServer1 ps $ do
|
|
("", "", UP _ [_]) <- nGet a
|
|
let loopCreate = do
|
|
-- creates the reply queue on testPort, but fails to send confirmation to testPort2
|
|
BROKER srv2' (NETWORK _) <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
unless (testPort2 `isSuffixOf` srv2') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate
|
|
loopCreate
|
|
restartAgentA restart a [contactId, bId]
|
|
("", "", DOWN _ [_, _]) <- nGet a' -- the second connection is from accept
|
|
(n, confId) <- withServer2 ps $ do
|
|
("", "", UP _ [_]) <- nGet b''
|
|
let loopConfirm n =
|
|
runExceptT (acceptContact a' 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe) >>= \case
|
|
Right True -> pure n
|
|
Right r -> error $ "unexpected result " <> show r
|
|
Left _ -> putStrLn "retrying accept confirm" >> threadDelay 200000 >> loopConfirm (n + 1)
|
|
n <- loopConfirm 1
|
|
("", _, A.CONF confId PQSupportOn _ "alice's connInfo") <- get b''
|
|
pure (n, confId)
|
|
("", "", DOWN _ [_]) <- nGet b''
|
|
runRight_ $ allowConnection b'' aId confId "bob's connInfo"
|
|
withServer1 ps $ do
|
|
("", "", UP _ [_, _]) <- nGet a'
|
|
get a' ##> ("", bId, A.INFO PQSupportOn "bob's connInfo")
|
|
get a' ##> ("", bId, A.CON PQEncOn)
|
|
get b'' ##> ("", aId, A.CON PQEncOn) -- note that server 2 is down, this event is delivered when HELLO is sent to server 1
|
|
a'' <- restartAgentA restart a' [contactId, bId]
|
|
withServer2 ps $ do
|
|
("", "", UP _ [_]) <- nGet b''
|
|
runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn (2 + n) 2 a'' bId b'' aId
|
|
disposeAgentClient a''
|
|
disposeAgentClient b''
|
|
|
|
getAgentA :: IO AgentClient
|
|
getAgentA = getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
|
|
getAgentB :: IO AgentClient
|
|
getAgentB = getSMPAgentClient' 2 agentCfg (initAgentServers {smp = userServers [testSMPServer2]}) testDB2
|
|
|
|
withServer1 :: (ASrvTransport, AStoreType) -> IO a -> IO a
|
|
withServer1 ps = withSmpServerStoreLogOn ps testPort . const
|
|
|
|
withServer2 :: (ASrvTransport, AStoreType) -> IO a -> IO a
|
|
withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 . const
|
|
|
|
testInvitationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
|
|
testInvitationShortLink viaProxy a b =
|
|
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
|
|
let userData = UserLinkData "some user data"
|
|
newLinkData = UserInvLinkData userData
|
|
(bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKUsePQ SMSubscribe
|
|
(FixedLinkData {linkConnReq = connReq'}, connData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
connReq' `shouldBe` connReq
|
|
linkUserData connData' `shouldBe` userData
|
|
-- same user can get invitation link again
|
|
(FixedLinkData {linkConnReq = connReq2}, connData2) <- runRight $ getConnShortLink b 1 shortLink
|
|
connReq2 `shouldBe` connReq
|
|
linkUserData connData2 `shouldBe` userData
|
|
-- another user cannot get the same invitation link
|
|
runExceptT (getConnShortLink c 1 shortLink) >>= \case
|
|
Left (SMP _ AUTH) -> pure ()
|
|
r -> liftIO $ expectationFailure ("unexpected result " <> show r)
|
|
runRight $ testJoinConn_ viaProxy True a bId b connReq
|
|
-- invitation link data is removed after the connection is established
|
|
runExceptT (getConnShortLink b 1 shortLink) >>= \case
|
|
Left (SMP _ AUTH) -> pure ()
|
|
r -> liftIO $ expectationFailure ("unexpected result " <> show r)
|
|
|
|
testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO ()
|
|
testJoinConn_ viaProxy sndSecure a bId b connReq = do
|
|
aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
|
|
sndSecure' <- A.joinConnection b NRMInteractive 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ sndSecure' `shouldBe` sndSecure
|
|
("", _, CONF confId _ "bob's connInfo") <- get a
|
|
allowConnection a bId confId "alice's connInfo"
|
|
get a ##> ("", bId, CON)
|
|
get b ##> ("", aId, INFO "alice's connInfo")
|
|
get b ##> ("", aId, CON)
|
|
exchangeGreetingsViaProxy viaProxy a bId b aId
|
|
|
|
testInvitationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> AgentClient -> IO ()
|
|
testInvitationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do
|
|
let userData = UserLinkData "some user data"
|
|
newLinkData = UserInvLinkData userData
|
|
-- can't create short link with previous version
|
|
(bId, CCLink connReq Nothing) <- A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKPQOn SMSubscribe
|
|
testJoinConn_ viaProxy sndSecure a bId b connReq
|
|
|
|
testInvitationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
|
|
testInvitationShortLinkAsync viaProxy a b = do
|
|
let userData = UserLinkData "some user data"
|
|
newLinkData = UserInvLinkData userData
|
|
(bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKUsePQ SMSubscribe
|
|
(FixedLinkData {linkConnReq = connReq'}, connData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
connReq' `shouldBe` connReq
|
|
linkUserData connData' `shouldBe` userData
|
|
runRight $ do
|
|
aId <- A.joinConnectionAsync b 1 "123" Nothing True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
|
get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False
|
|
("", _, CONF confId _ "bob's connInfo") <- get a
|
|
allowConnection a bId confId "alice's connInfo"
|
|
get a ##> ("", bId, CON)
|
|
get b ##> ("", aId, INFO "alice's connInfo")
|
|
get b ##> ("", aId, CON)
|
|
exchangeGreetingsViaProxy viaProxy a bId b aId
|
|
|
|
relayLink1 :: ConnShortLink 'CMContact
|
|
relayLink1 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM?p=7001&c=LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI"
|
|
|
|
relayLink2 :: ConnShortLink 'CMContact
|
|
relayLink2 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM"
|
|
|
|
testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
|
|
testContactShortLink viaProxy a b =
|
|
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
|
|
let userData = UserLinkData "some user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
newLinkData = UserContactLinkData userCtData
|
|
(contactId, CCLink connReq0 (Just shortLink)) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMContact (Just newLinkData) Nothing CR.IKPQOn SMSubscribe
|
|
Right connReq <- pure $ smpDecode (smpEncode connReq0)
|
|
(FixedLinkData {linkConnReq = connReq'}, ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
connReq' `shouldBe` connReq
|
|
userCtData' `shouldBe` userCtData
|
|
-- same user can get contact link again
|
|
(FixedLinkData {linkConnReq = connReq2}, ContactLinkData _ userCtData2) <- runRight $ getConnShortLink b 1 shortLink
|
|
connReq2 `shouldBe` connReq
|
|
userCtData2 `shouldBe` userCtData
|
|
-- another user can get the same contact link
|
|
(FixedLinkData {linkConnReq = connReq3}, ContactLinkData _ userCtData3) <- runRight $ getConnShortLink c 1 shortLink
|
|
connReq3 `shouldBe` connReq
|
|
userCtData3 `shouldBe` userCtData
|
|
runRight $ do
|
|
(aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
|
|
liftIO $ sndSecure `shouldBe` False
|
|
("", _, REQ invId _ "bob's connInfo") <- get a
|
|
bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
|
sndSecure' <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ sndSecure' `shouldBe` True
|
|
("", _, CONF confId _ "alice's connInfo") <- get b
|
|
allowConnection b aId confId "bob's connInfo"
|
|
get a ##> ("", bId, INFO "bob's connInfo")
|
|
get a ##> ("", bId, CON)
|
|
get b ##> ("", aId, CON)
|
|
exchangeGreetingsViaProxy viaProxy a bId b aId
|
|
-- update user data
|
|
let updatedData = UserLinkData "updated user data"
|
|
updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
|
|
userLinkData' = UserContactLinkData updatedCtData
|
|
shortLink' <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
|
|
shortLink' `shouldBe` shortLink
|
|
(FixedLinkData {linkConnReq = connReq4}, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink c 1 shortLink
|
|
connReq4 `shouldBe` connReq
|
|
updatedCtData' `shouldBe` updatedCtData
|
|
-- one more time
|
|
shortLink2 <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
|
|
shortLink2 `shouldBe` shortLink
|
|
-- delete short link
|
|
runRight_ $ deleteConnShortLink a NRMInteractive contactId SCMContact
|
|
Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink
|
|
pure ()
|
|
|
|
testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO ()
|
|
testAddContactShortLink viaProxy a b =
|
|
withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do
|
|
(contactId, CCLink connReq0 Nothing) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe
|
|
Right connReq <- pure $ smpDecode (smpEncode connReq0) --
|
|
let userData = UserLinkData "some user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
newLinkData = UserContactLinkData userCtData
|
|
shortLink <- runRight $ setConnShortLink a contactId SCMContact newLinkData Nothing
|
|
(FixedLinkData {linkConnReq = connReq'}, ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
connReq' `shouldBe` connReq
|
|
userCtData' `shouldBe` userCtData
|
|
-- same user can get contact link again
|
|
(FixedLinkData {linkConnReq = connReq2}, ContactLinkData _ userCtData2) <- runRight $ getConnShortLink b 1 shortLink
|
|
connReq2 `shouldBe` connReq
|
|
userCtData2 `shouldBe` userCtData
|
|
-- another user can get the same contact link
|
|
(FixedLinkData {linkConnReq = connReq3}, ContactLinkData _ userCtData3) <- runRight $ getConnShortLink c 1 shortLink
|
|
connReq3 `shouldBe` connReq
|
|
userCtData3 `shouldBe` userCtData
|
|
runRight $ do
|
|
(aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
|
|
liftIO $ sndSecure `shouldBe` False
|
|
("", _, REQ invId _ "bob's connInfo") <- get a
|
|
bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
|
sndSecure' <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ sndSecure' `shouldBe` True
|
|
("", _, CONF confId _ "alice's connInfo") <- get b
|
|
allowConnection b aId confId "bob's connInfo"
|
|
get a ##> ("", bId, INFO "bob's connInfo")
|
|
get a ##> ("", bId, CON)
|
|
get b ##> ("", aId, CON)
|
|
exchangeGreetingsViaProxy viaProxy a bId b aId
|
|
-- update user data
|
|
let updatedData = UserLinkData "updated user data"
|
|
updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
|
|
userLinkData' = UserContactLinkData updatedCtData
|
|
shortLink' <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
|
|
shortLink' `shouldBe` shortLink
|
|
(FixedLinkData {linkConnReq = connReq4}, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink c 1 shortLink
|
|
connReq4 `shouldBe` connReq
|
|
updatedCtData' `shouldBe` updatedCtData
|
|
|
|
testInvitationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testInvitationShortLinkRestart ps = withAgentClients2 $ \a b -> do
|
|
let userData = UserLinkData "some user data"
|
|
newLinkData = UserInvLinkData userData
|
|
(bId, CCLink connReq (Just shortLink)) <- withSmpServer ps $
|
|
runRight $ A.createConnection a NRMInteractive 1 True True SCMInvitation (Just newLinkData) Nothing CR.IKUsePQ SMOnlyCreate
|
|
withSmpServer ps $ do
|
|
runRight_ $ subscribeConnection a bId
|
|
(FixedLinkData {linkConnReq = connReq'}, connData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
connReq' `shouldBe` connReq
|
|
linkUserData connData' `shouldBe` userData
|
|
|
|
testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
|
|
let userData = UserLinkData "some user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
newLinkData = UserContactLinkData userCtData
|
|
(contactId, CCLink connReq0 (Just shortLink)) <- withSmpServer ps $
|
|
runRight $ A.createConnection a NRMInteractive 1 True True SCMContact (Just newLinkData) Nothing CR.IKPQOn SMOnlyCreate
|
|
Right connReq <- pure $ smpDecode (smpEncode connReq0)
|
|
let updatedData = UserLinkData "updated user data"
|
|
updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
|
|
updatedLinkData = UserContactLinkData updatedCtData
|
|
withSmpServer ps $ do
|
|
(fd', ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
linkConnReq fd' `shouldBe` connReq
|
|
userCtData' `shouldBe` userCtData
|
|
-- update user data
|
|
shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedLinkData Nothing
|
|
shortLink' `shouldBe` shortLink
|
|
withSmpServer ps $ do
|
|
(fd4, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
linkConnReq fd4 `shouldBe` connReq
|
|
updatedCtData' `shouldBe` updatedCtData
|
|
|
|
testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
|
|
let userData = UserLinkData "some user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
newLinkData = UserContactLinkData userCtData
|
|
((contactId, CCLink connReq0 Nothing), shortLink) <- withSmpServer ps $ runRight $ do
|
|
r@(contactId, _) <- A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
|
|
(r,) <$> setConnShortLink a contactId SCMContact newLinkData Nothing
|
|
Right connReq <- pure $ smpDecode (smpEncode connReq0)
|
|
let updatedData = UserLinkData "updated user data"
|
|
updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
|
|
updatedLinkData = UserContactLinkData updatedCtData
|
|
withSmpServer ps $ do
|
|
(fd', ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
linkConnReq fd' `shouldBe` connReq
|
|
userCtData' `shouldBe` userCtData
|
|
-- update user data
|
|
shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedLinkData Nothing
|
|
shortLink' `shouldBe` shortLink
|
|
withSmpServer ps $ do
|
|
(fd4, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
linkConnReq fd4 `shouldBe` connReq
|
|
updatedCtData' `shouldBe` updatedCtData
|
|
|
|
testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do
|
|
(contactId, CCLink connReq Nothing) <- withSmpServer ps $ runRight $
|
|
A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate
|
|
-- make it an "old" queue
|
|
let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" ""
|
|
#if defined(dbServerPostgres)
|
|
updateDbStore :: PostgresQueueStore s -> IO ()
|
|
updateDbStore st = do
|
|
let AgentClient {agentEnv = Env {store}} = a
|
|
Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction store (`getConn` contactId)
|
|
Right 1 <- runExceptT $ withDB' "test" st $ \db -> PSQL.execute db "UPDATE msg_queues SET queue_mode = ? WHERE recipient_id = ?" (Nothing :: Maybe QueueMode, rcvId)
|
|
pure ()
|
|
#endif
|
|
() <- case testServerStoreConfig msType of
|
|
ASSCfg _ _ (SSCMemory sp_) -> mapM_ (\StorePaths {storeLogFile} -> updateStoreLog storeLogFile) sp_
|
|
ASSCfg _ _ SSCMemoryJournal {storeLogFile} -> updateStoreLog storeLogFile
|
|
#if defined(dbServerPostgres)
|
|
ASSCfg _ _ SSCDatabaseJournal {storeCfg} -> do
|
|
st :: PostgresQueueStore (JournalQueue 'QSPostgres) <- newQueueStore @(JournalQueue 'QSPostgres) (storeCfg, True)
|
|
updateDbStore st
|
|
closeQueueStore @(JournalQueue 'QSPostgres) st
|
|
ASSCfg _ _ (SSCDatabase storeCfg) -> do
|
|
st :: PostgresQueueStore PostgresQueue <- newQueueStore @PostgresQueue (storeCfg, False)
|
|
updateDbStore st
|
|
closeQueueStore @PostgresQueue st
|
|
#else
|
|
ASSCfg _ _ SSCDatabaseJournal {} -> error "no dbServerPostgres flag"
|
|
#endif
|
|
|
|
withSmpServer ps $ do
|
|
let userData = UserLinkData "some user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
userLinkData = UserContactLinkData userCtData
|
|
shortLink <- runRight $ setConnShortLink a contactId SCMContact userLinkData Nothing
|
|
(FixedLinkData {linkConnReq = connReq'}, ContactLinkData _ userCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
connReq' `shouldBe` connReq
|
|
userCtData' `shouldBe` userCtData
|
|
-- update user data
|
|
let updatedData = UserLinkData "updated user data"
|
|
updatedCtData = UserContactData {direct = False, owners = [], relays = [relayLink1, relayLink2], userData = updatedData}
|
|
userLinkData' = UserContactLinkData updatedCtData
|
|
shortLink' <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing
|
|
shortLink' `shouldBe` shortLink
|
|
-- check updated
|
|
(FixedLinkData {linkConnReq = connReq''}, ContactLinkData _ updatedCtData') <- runRight $ getConnShortLink b 1 shortLink
|
|
connReq'' `shouldBe` connReq
|
|
updatedCtData' `shouldBe` updatedCtData
|
|
|
|
replaceSubstringInFile :: FilePath -> T.Text -> T.Text -> IO ()
|
|
replaceSubstringInFile filePath oldText newText = do
|
|
content <- T.readFile filePath
|
|
let newContent = T.replace oldText newText content
|
|
T.writeFile filePath newContent
|
|
|
|
testPrepareCreateConnectionLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testPrepareCreateConnectionLink ps = withSmpServer ps $ withAgentClients2 $ \a b -> do
|
|
let userData = UserLinkData "test user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
userLinkData = UserContactLinkData userCtData
|
|
g <- C.newRandom
|
|
rootKey <- atomically $ C.generateKeyPair g
|
|
linkEntId <- atomically $ C.randomBytes 32 g
|
|
runRight $ do
|
|
(ccLink@(CCLink connReq (Just shortLink)), preparedParams) <-
|
|
A.prepareConnectionLink a 1 rootKey linkEntId True Nothing
|
|
liftIO $ strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
|
_ <- A.createConnectionForLink a NRMInteractive 1 True ccLink preparedParams userLinkData CR.IKPQOn SMSubscribe
|
|
(FixedLinkData {linkConnReq = connReq', linkEntityId}, ContactLinkData _ userCtData') <- getConnShortLink b 1 shortLink
|
|
liftIO $ Just linkEntId `shouldBe` linkEntityId
|
|
Right connReqDecoded <- pure $ smpDecode (smpEncode connReq)
|
|
liftIO $ connReq' `shouldBe` connReqDecoded
|
|
liftIO $ userCtData' `shouldBe` userCtData
|
|
(bId, sndSecure) <- joinConnection b 1 True connReq' "bob's connInfo" SMSubscribe
|
|
liftIO $ sndSecure `shouldBe` False
|
|
("", _, REQ invId _ "bob's connInfo") <- get a
|
|
aId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
|
sndSecure' <- acceptContact a 1 aId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ sndSecure' `shouldBe` True
|
|
("", _, CONF confId _ "alice's connInfo") <- get b
|
|
allowConnection b bId confId "bob's connInfo"
|
|
get a ##> ("", aId, INFO "bob's connInfo")
|
|
get a ##> ("", aId, CON)
|
|
get b ##> ("", bId, CON)
|
|
exchangeGreetings a aId b bId
|
|
|
|
testIncreaseConnAgentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testIncreaseConnAgentVersion ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
(aliceId, bobId) <- runRight $ do
|
|
(aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob
|
|
exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId
|
|
checkVersion alice bobId 2
|
|
checkVersion bob aliceId 2
|
|
pure (aliceId, bobId)
|
|
|
|
-- version doesn't increase if incompatible
|
|
|
|
disposeAgentClient alice
|
|
threadDelay 250000
|
|
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
|
|
|
|
runRight_ $ do
|
|
subscribeConnection alice2 bobId
|
|
exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId
|
|
checkVersion alice2 bobId 2
|
|
checkVersion bob aliceId 2
|
|
|
|
-- version increases if compatible
|
|
|
|
disposeAgentClient bob
|
|
threadDelay 250000
|
|
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
|
|
|
|
runRight_ $ do
|
|
subscribeConnection bob2 aliceId
|
|
exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob2 aliceId
|
|
checkVersion alice2 bobId 3
|
|
checkVersion bob2 aliceId 3
|
|
|
|
-- version doesn't decrease, even if incompatible
|
|
|
|
disposeAgentClient alice2
|
|
threadDelay 250000
|
|
alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB
|
|
|
|
runRight_ $ do
|
|
subscribeConnection alice3 bobId
|
|
exchangeGreetingsMsgId_ PQEncOff 8 alice3 bobId bob2 aliceId
|
|
checkVersion alice3 bobId 3
|
|
checkVersion bob2 aliceId 3
|
|
|
|
disposeAgentClient bob2
|
|
threadDelay 250000
|
|
bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2
|
|
|
|
runRight_ $ do
|
|
subscribeConnection bob3 aliceId
|
|
exchangeGreetingsMsgId_ PQEncOff 10 alice3 bobId bob3 aliceId
|
|
checkVersion alice3 bobId 3
|
|
checkVersion bob3 aliceId 3
|
|
disposeAgentClient alice3
|
|
disposeAgentClient bob3
|
|
|
|
checkVersion :: AgentClient -> ConnId -> Word16 -> ExceptT AgentErrorType IO ()
|
|
checkVersion c connId v = do
|
|
ConnectionStats {connAgentVersion} <- getConnectionServers c connId
|
|
liftIO $ connAgentVersion `shouldBe` VersionSMPA v
|
|
|
|
testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testIncreaseConnAgentVersionMaxCompatible ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
(aliceId, bobId) <- runRight $ do
|
|
(aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob
|
|
exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId
|
|
checkVersion alice bobId 2
|
|
checkVersion bob aliceId 2
|
|
pure (aliceId, bobId)
|
|
|
|
-- version increases to max compatible
|
|
|
|
disposeAgentClient alice
|
|
threadDelay 250000
|
|
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
|
|
disposeAgentClient bob
|
|
threadDelay 250000
|
|
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB2
|
|
|
|
runRight_ $ do
|
|
subscribeConnection alice2 bobId
|
|
subscribeConnection bob2 aliceId
|
|
exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob2 aliceId
|
|
checkVersion alice2 bobId 3
|
|
checkVersion bob2 aliceId 3
|
|
disposeAgentClient alice2
|
|
disposeAgentClient bob2
|
|
|
|
testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testIncreaseConnAgentVersionStartDifferentVersion ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
(aliceId, bobId) <- runRight $ do
|
|
(aliceId, bobId) <- makeConnection_ PQSupportOff False alice bob
|
|
exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId
|
|
checkVersion alice bobId 2
|
|
checkVersion bob aliceId 2
|
|
pure (aliceId, bobId)
|
|
|
|
-- version increases to max compatible
|
|
|
|
disposeAgentClient alice
|
|
threadDelay 250000
|
|
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
|
|
|
|
runRight_ $ do
|
|
subscribeConnection alice2 bobId
|
|
exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId
|
|
checkVersion alice2 bobId 3
|
|
checkVersion bob aliceId 3
|
|
disposeAgentClient alice2
|
|
disposeAgentClient bob
|
|
|
|
testDeliverClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testDeliverClientRestart ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
|
|
(aliceId, bobId) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
runRight $ do
|
|
(aliceId, bobId) <- makeConnection alice bob
|
|
exchangeGreetings alice bobId bob aliceId
|
|
pure (aliceId, bobId)
|
|
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob
|
|
|
|
4 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello"
|
|
|
|
disposeAgentClient bob
|
|
|
|
bob2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
|
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
runRight_ $ do
|
|
("", "", UP _ _) <- nGet alice
|
|
|
|
subscribeConnection bob2 aliceId
|
|
|
|
get bob2 ##> ("", aliceId, SENT 4)
|
|
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
|
|
disposeAgentClient alice
|
|
disposeAgentClient bob2
|
|
|
|
testDuplicateMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testDuplicateMessage ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
(aliceId, bobId) <- runRight $ makeConnection alice bob
|
|
runRight_ $ do
|
|
2 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT 2)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
disposeAgentClient bob
|
|
threadDelay 250000
|
|
|
|
-- if the agent user did not send ACK, the message will be delivered again
|
|
bob1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
|
runRight_ $ do
|
|
subscribeConnection bob1 aliceId
|
|
get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob1 aliceId 2 Nothing
|
|
3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2"
|
|
get alice ##> ("", bobId, SENT 3)
|
|
get bob1 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
|
|
|
|
pure (aliceId, bobId, bob1)
|
|
|
|
nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
|
|
nGet bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False
|
|
-- commenting two lines below and uncommenting further two lines would also runRight_,
|
|
-- it is the scenario tested above, when the message was not acknowledged by the user
|
|
threadDelay 200000
|
|
Left (BROKER _ (NETWORK _)) <- runExceptT $ ackMessage bob1 aliceId 3 Nothing
|
|
|
|
disposeAgentClient alice
|
|
disposeAgentClient bob1
|
|
threadDelay 250000
|
|
|
|
alice2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB
|
|
bob2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB2
|
|
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
runRight_ $ do
|
|
subscribeConnection bob2 aliceId
|
|
subscribeConnection alice2 bobId
|
|
-- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False
|
|
-- ackMessage bob2 aliceId 5 Nothing
|
|
-- message 2 is not delivered again, even though it was delivered to the agent
|
|
4 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3"
|
|
get alice2 ##> ("", bobId, SENT 4)
|
|
get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
|
|
disposeAgentClient alice2
|
|
disposeAgentClient bob2
|
|
|
|
testSkippedMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testSkippedMessages (t, msType) = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(aliceId, bobId) <- withSmpServerConfigOn t cfg' testPort $ \_ -> do
|
|
(aliceId, bobId) <- runRight $ makeConnection alice bob
|
|
runRight_ $ do
|
|
2 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT 2)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId 2 Nothing
|
|
|
|
disposeAgentClient bob
|
|
|
|
runRight_ $ do
|
|
3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2"
|
|
get alice ##> ("", bobId, SENT 3)
|
|
4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
|
|
get alice ##> ("", bobId, SENT 4)
|
|
5 <- sendMessage alice bobId SMP.noMsgFlags "hello 4"
|
|
get alice ##> ("", bobId, SENT 5)
|
|
|
|
pure (aliceId, bobId)
|
|
|
|
nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False
|
|
threadDelay 200000
|
|
|
|
disposeAgentClient alice
|
|
|
|
alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
|
|
bob2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
|
|
|
|
withSmpServerConfigOn t cfg' testPort $ \_ -> do
|
|
runRight_ $ do
|
|
subscribeConnection bob2 aliceId
|
|
subscribeConnection alice2 bobId
|
|
|
|
6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5"
|
|
get alice2 ##> ("", bobId, SENT 6)
|
|
get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 3, toMsgId = 5}}} _ "hello 5") -> c == aliceId; _ -> False
|
|
ackMessage bob2 aliceId 3 Nothing
|
|
|
|
7 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6"
|
|
get alice2 ##> ("", bobId, SENT 7)
|
|
get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False
|
|
ackMessage bob2 aliceId 4 Nothing
|
|
disposeAgentClient alice2
|
|
disposeAgentClient bob2
|
|
where
|
|
cfg' = withServerCfg (cfgMS msType) $ \cfg_ -> ASrvCfg SQSMemory SMSMemory cfg_ {serverStoreCfg = SSCMemory $ Just $ StorePaths testStoreLogFile Nothing}
|
|
|
|
testDeliveryAfterSubscriptionError :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testDeliveryAfterSubscriptionError ps = do
|
|
(aId, bId) <- withAgentClients2 $ \a b -> do
|
|
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
|
nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
|
|
2 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello"
|
|
liftIO $ noMessages b "not delivered"
|
|
pure (aId, bId)
|
|
|
|
withAgentClients2 $ \a b -> do
|
|
Left (BROKER _ (NETWORK _)) <- runExceptT $ subscribeConnection a bId
|
|
Left (BROKER _ (NETWORK _)) <- runExceptT $ subscribeConnection b aId
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
withUP a bId $ \case ("", c, SENT 2) -> c == bId; _ -> False
|
|
withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False
|
|
ackMessage b aId 2 Nothing
|
|
|
|
testMsgDeliveryQuotaExceeded :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testMsgDeliveryQuotaExceeded ps =
|
|
withAgentClients2 $ \a b -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
(aId', bId') <- makeConnection a b
|
|
forM_ ([1 .. 4] :: [Int]) $ \i -> do
|
|
mId <- sendMessage a bId SMP.noMsgFlags $ "message " <> bshow i
|
|
get a =##> \case ("", c, SENT mId') -> bId == c && mId == mId'; _ -> False
|
|
6 <- sendMessage a bId SMP.noMsgFlags "over quota"
|
|
pGet' a False =##> \case ("", c, AEvt _ (MWARN 6 (SMP _ QUOTA))) -> bId == c; _ -> False
|
|
2 <- sendMessage a bId' SMP.noMsgFlags "hello"
|
|
get a =##> \case ("", c, SENT 2) -> bId' == c; _ -> False
|
|
get b =##> \case ("", c, Msg "message 1") -> aId == c; _ -> False
|
|
get b =##> \case ("", c, Msg "hello") -> aId' == c; _ -> False
|
|
ackMessage b aId' 2 Nothing
|
|
ackMessage b aId 2 Nothing
|
|
get b =##> \case ("", c, Msg "message 2") -> aId == c; _ -> False
|
|
ackMessage b aId 3 Nothing
|
|
get b =##> \case ("", c, Msg "message 3") -> aId == c; _ -> False
|
|
ackMessage b aId 4 Nothing
|
|
get b =##> \case ("", c, Msg "message 4") -> aId == c; _ -> False
|
|
ackMessage b aId 5 Nothing
|
|
get a =##> \case ("", c, QCONT) -> bId == c; _ -> False
|
|
get b =##> \case ("", c, Msg "over quota") -> aId == c; _ -> False
|
|
ackMessage b aId 7 Nothing -- msg 8 was QCONT
|
|
get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False
|
|
liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events")
|
|
|
|
testExpireMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testExpireMessage ps =
|
|
withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
|
|
withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do
|
|
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
|
nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
|
|
2 <- runRight $ sendMessage a bId SMP.noMsgFlags "1"
|
|
threadDelay 1500000
|
|
3 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire
|
|
get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && networkOrTimeoutError e; _ -> False
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
withUP a bId $ \case ("", _, SENT 3) -> True; _ -> False
|
|
withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False
|
|
ackMessage b aId 2 Nothing
|
|
|
|
testExpireManyMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testExpireManyMessages ps =
|
|
withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
|
|
withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do
|
|
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b
|
|
runRight_ $ do
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
|
nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
|
|
2 <- sendMessage a bId SMP.noMsgFlags "1"
|
|
3 <- sendMessage a bId SMP.noMsgFlags "2"
|
|
4 <- sendMessage a bId SMP.noMsgFlags "3"
|
|
liftIO $ threadDelay 2000000
|
|
5 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire
|
|
get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && networkOrTimeoutError e; _ -> False
|
|
let expected c e = bId == c && networkOrTimeoutError e
|
|
get a >>= \case
|
|
("", c, MERR 3 (BROKER _ e)) -> do
|
|
liftIO $ expected c e `shouldBe` True
|
|
get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [4] (BROKER _ e')) -> expected c' e'; _ -> False
|
|
("", c, MERRS [3] (BROKER _ e)) -> do
|
|
liftIO $ expected c e `shouldBe` True
|
|
get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; _ -> False
|
|
("", c, MERRS [3, 4] (BROKER _ e)) ->
|
|
liftIO $ expected c e `shouldBe` True
|
|
r -> error $ show r
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False
|
|
withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 4) "4") -> True; _ -> False
|
|
ackMessage b aId 2 Nothing
|
|
|
|
withUP :: HasCallStack => AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO ()
|
|
withUP a bId p =
|
|
liftIO $
|
|
getInAnyOrder
|
|
a
|
|
[ \case ("", "", AEvt SAENone (UP _ [c])) -> c == bId; _ -> False,
|
|
\case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
|
|
]
|
|
|
|
testExpireMessageQuota :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testExpireMessageQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do
|
|
a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
|
|
b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(aId, bId) <- runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
liftIO $ threadDelay 500000 >> disposeAgentClient b
|
|
2 <- sendMessage a bId SMP.noMsgFlags "1"
|
|
get a ##> ("", bId, SENT 2)
|
|
3 <- sendMessage a bId SMP.noMsgFlags "2"
|
|
liftIO $ threadDelay 1000000
|
|
4 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire
|
|
get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False
|
|
pure (aId, bId)
|
|
withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do
|
|
subscribeConnection b' aId
|
|
get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
|
|
ackMessage b' aId 2 Nothing
|
|
liftIO . getInAnyOrder a $
|
|
[ \case ("", c, AEvt SAEConn (SENT 4)) -> c == bId; _ -> False,
|
|
\case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False
|
|
]
|
|
get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 3) "3") -> c == aId; _ -> False
|
|
ackMessage b' aId 4 Nothing
|
|
disposeAgentClient a
|
|
where
|
|
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2}
|
|
|
|
testExpireManyMessagesQuota :: (ASrvTransport, AStoreType) -> IO ()
|
|
testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do
|
|
a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
|
|
b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(aId, bId) <- runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
liftIO $ threadDelay 500000 >> disposeAgentClient b
|
|
2 <- sendMessage a bId SMP.noMsgFlags "1"
|
|
get a ##> ("", bId, SENT 2)
|
|
3 <- sendMessage a bId SMP.noMsgFlags "2"
|
|
4 <- sendMessage a bId SMP.noMsgFlags "3"
|
|
5 <- sendMessage a bId SMP.noMsgFlags "4"
|
|
liftIO $ threadDelay 2000000
|
|
6 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire
|
|
get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False
|
|
get a >>= \case
|
|
("", c, MERR 4 (SMP _ QUOTA)) -> do
|
|
liftIO $ bId `shouldBe` c
|
|
get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; ("", c', MERRS [5] (SMP _ QUOTA)) -> bId == c'; _ -> False
|
|
("", c, MERRS [4] (SMP _ QUOTA)) -> do
|
|
liftIO $ bId `shouldBe` c
|
|
get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; _ -> False
|
|
("", c, MERRS [4, 5] (SMP _ QUOTA)) -> liftIO $ bId `shouldBe` c
|
|
r -> error $ show r
|
|
pure (aId, bId)
|
|
withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do
|
|
subscribeConnection b' aId
|
|
get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
|
|
ackMessage b' aId 2 Nothing
|
|
liftIO . getInAnyOrder a $
|
|
[ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False,
|
|
\case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False
|
|
]
|
|
get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 5) "5") -> c == aId; _ -> False
|
|
ackMessage b' aId 4 Nothing
|
|
disposeAgentClient a
|
|
where
|
|
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2}
|
|
|
|
testDropMsgAfterRcvAttempts :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testDropMsgAfterRcvAttempts ps =
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
let rcvCfg = agentCfg {rcvExpireCount = 2, rcvExpireInterval = 1}
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 rcvCfg initAgentServers testDB2
|
|
(aliceId, bobId) <- runRight $ makeConnection alice bob
|
|
-- alice sends, bob receives but does NOT ack
|
|
runRight_ $ do
|
|
2 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT 2)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
-- bob disconnects without acking
|
|
disposeAgentClient bob
|
|
threadDelay 500000
|
|
-- bob reconnects, agent sees duplicate, counter=1
|
|
bob2 <- getSMPAgentClient' 3 rcvCfg initAgentServers testDB2
|
|
runRight_ $ do
|
|
subscribeConnection bob2 aliceId
|
|
get bob2 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
-- bob disconnects again without acking
|
|
disposeAgentClient bob2
|
|
-- wait for rcvExpireInterval (1 second)
|
|
threadDelay 500000
|
|
-- bob reconnects, agent sees duplicate, counter=2, interval exceeded -> drops
|
|
bob3 <- getSMPAgentClient' 4 rcvCfg initAgentServers testDB2
|
|
runRight_ $ do
|
|
subscribeConnection bob3 aliceId
|
|
get bob3 =##> \case ("", c, ERR (AGENT (A_DUPLICATE (Just DroppedMsg {})))) -> c == aliceId; _ -> False
|
|
disposeAgentClient bob3
|
|
disposeAgentClient alice
|
|
|
|
testRatchetSync :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testRatchetSync ps = withAgentClients2 $ \alice bob ->
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
(aliceId, bobId, bob2) <- setupDesynchronizedRatchet alice bob
|
|
runRight $ do
|
|
ConnectionStats {ratchetSyncState} <- synchronizeRatchet bob2 aliceId PQSupportOn False
|
|
liftIO $ ratchetSyncState `shouldBe` RSStarted
|
|
get alice =##> ratchetSyncP bobId RSAgreed
|
|
get bob2 =##> ratchetSyncP aliceId RSAgreed
|
|
get alice =##> ratchetSyncP bobId RSOk
|
|
get bob2 =##> ratchetSyncP aliceId RSOk
|
|
exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7
|
|
disposeAgentClient bob2
|
|
|
|
setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient)
|
|
setupDesynchronizedRatchet alice bob = do
|
|
(aliceId, bobId) <- runRight $ makeConnection alice bob
|
|
runRight_ $ do
|
|
2 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT 2)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId 2 Nothing
|
|
|
|
3 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2"
|
|
get bob ##> ("", aliceId, SENT 3)
|
|
get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False
|
|
ackMessage alice bobId 3 Nothing
|
|
|
|
liftIO $ copyFile testDB2 (testDB2 <> ".bak")
|
|
|
|
4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3"
|
|
get alice ##> ("", bobId, SENT 4)
|
|
get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId 4 Nothing
|
|
|
|
5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4"
|
|
get bob ##> ("", aliceId, SENT 5)
|
|
get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False
|
|
ackMessage alice bobId 5 Nothing
|
|
|
|
disposeAgentClient bob
|
|
threadDelay 250000
|
|
|
|
-- importing database backup after progressing ratchet de-synchronizes ratchet
|
|
liftIO $ renameFile (testDB2 <> ".bak") testDB2
|
|
|
|
bob2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
|
|
|
runRight_ $ do
|
|
subscribeConnection bob2 aliceId
|
|
|
|
Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ synchronizeRatchet bob2 aliceId PQSupportOn False
|
|
|
|
6 <- sendMessage alice bobId SMP.noMsgFlags "hello 5"
|
|
get alice ##> ("", bobId, SENT 6)
|
|
get bob2 =##> ratchetSyncP aliceId RSRequired
|
|
|
|
Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ sendMessage bob2 aliceId SMP.noMsgFlags "hello 6"
|
|
pure ()
|
|
|
|
pure (aliceId, bobId, bob2)
|
|
|
|
ratchetSyncP :: ConnId -> RatchetSyncState -> AEntityTransmission 'AEConn -> Bool
|
|
ratchetSyncP cId rss = \case
|
|
(_, cId', RSYNC rss' _ ConnectionStats {ratchetSyncState}) ->
|
|
cId' == cId && rss' == rss && ratchetSyncState == rss
|
|
_ -> False
|
|
|
|
ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission -> Bool
|
|
ratchetSyncP' cId rss = \case
|
|
(_, cId', AEvt SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) ->
|
|
cId' == cId && rss' == rss && ratchetSyncState == rss
|
|
_ -> False
|
|
|
|
testRatchetSyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testRatchetSyncServerOffline ps = withAgentClients2 $ \alice bob -> do
|
|
(aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ ->
|
|
setupDesynchronizedRatchet alice bob
|
|
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob2
|
|
|
|
ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False
|
|
liftIO $ ratchetSyncState `shouldBe` RSStarted
|
|
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
concurrently_
|
|
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
|
|
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
|
|
runRight_ $ do
|
|
get alice =##> ratchetSyncP bobId RSOk
|
|
get bob2 =##> ratchetSyncP aliceId RSOk
|
|
exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7
|
|
disposeAgentClient bob2
|
|
|
|
serverUpP :: ATransmission -> Bool
|
|
serverUpP = \case
|
|
("", "", AEvt SAENone (UP _ _)) -> True
|
|
_ -> False
|
|
|
|
testRatchetSyncClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testRatchetSyncClientRestart ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ ->
|
|
setupDesynchronizedRatchet alice bob
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob2
|
|
ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False
|
|
ratchetSyncState `shouldBe` RSStarted
|
|
disposeAgentClient bob2
|
|
bob3 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
runRight_ $ do
|
|
("", "", UP _ _) <- nGet alice
|
|
subscribeConnection bob3 aliceId
|
|
get alice =##> ratchetSyncP bobId RSAgreed
|
|
get bob3 =##> ratchetSyncP aliceId RSAgreed
|
|
get alice =##> ratchetSyncP bobId RSOk
|
|
get bob3 =##> ratchetSyncP aliceId RSOk
|
|
exchangeGreetingsMsgIds alice bobId 10 bob3 aliceId 7
|
|
disposeAgentClient alice
|
|
disposeAgentClient bob
|
|
disposeAgentClient bob3
|
|
|
|
testRatchetSyncSuspendForeground :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testRatchetSyncSuspendForeground ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ ->
|
|
setupDesynchronizedRatchet alice bob
|
|
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob2
|
|
|
|
ConnectionStats {ratchetSyncState} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False
|
|
liftIO $ ratchetSyncState `shouldBe` RSStarted
|
|
|
|
suspendAgent bob2 0
|
|
threadDelay 100000
|
|
foregroundAgent bob2
|
|
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
concurrently_
|
|
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
|
|
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
|
|
runRight_ $ do
|
|
get alice =##> ratchetSyncP bobId RSOk
|
|
get bob2 =##> ratchetSyncP aliceId RSOk
|
|
exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7
|
|
disposeAgentClient alice
|
|
disposeAgentClient bob
|
|
disposeAgentClient bob2
|
|
|
|
testRatchetSyncSimultaneous :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testRatchetSyncSimultaneous ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
|
|
(aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ ->
|
|
setupDesynchronizedRatchet alice bob
|
|
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob2
|
|
|
|
ConnectionStats {ratchetSyncState = bRSS} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn False
|
|
liftIO $ bRSS `shouldBe` RSStarted
|
|
|
|
ConnectionStats {ratchetSyncState = aRSS} <- runRight $ synchronizeRatchet alice bobId PQSupportOn True
|
|
liftIO $ aRSS `shouldBe` RSStarted
|
|
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
concurrently_
|
|
(getInAnyOrder alice [ratchetSyncP' bobId RSAgreed, serverUpP])
|
|
(getInAnyOrder bob2 [ratchetSyncP' aliceId RSAgreed, serverUpP])
|
|
runRight_ $ do
|
|
get alice =##> ratchetSyncP bobId RSOk
|
|
get bob2 =##> ratchetSyncP aliceId RSOk
|
|
exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7
|
|
disposeAgentClient alice
|
|
disposeAgentClient bob
|
|
disposeAgentClient bob2
|
|
|
|
testOnlyCreatePullSlowHandshake :: IO ()
|
|
testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProxyCfgV8 $ \alice bob -> runRight_ $ do
|
|
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
|
|
liftIO $ sqSecured `shouldBe` False
|
|
Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
|
|
getMSGNTF alice bobId
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
liftIO $ threadDelay 1_000000
|
|
getMsg bob aliceId $
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
getMSGNTF bob aliceId
|
|
liftIO $ threadDelay 1_000000
|
|
getMsg alice bobId $ pure ()
|
|
inAnyOrder
|
|
(get alice)
|
|
[ \case ("", c, CON) -> c == bobId; _ -> False,
|
|
\case ("", c, MSGNTF {}) -> c == bobId; _ -> False
|
|
]
|
|
getMsg bob aliceId $
|
|
get bob ##> ("", aliceId, CON)
|
|
getMSGNTF bob aliceId
|
|
-- exchange messages
|
|
4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT 4)
|
|
getMsg bob aliceId $
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId 4 Nothing
|
|
getMSGNTF bob aliceId
|
|
5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT 5)
|
|
getMsg alice bobId $
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId 5 Nothing
|
|
getMSGNTF alice bobId
|
|
|
|
getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a
|
|
getMsg c cId action = do
|
|
liftIO $ noMessages c "nothing should be delivered before GET"
|
|
[Right (Just _)] <- lift $ getConnectionMessages c [ConnMsgReq cId 1 Nothing]
|
|
action
|
|
|
|
getMSGNTF :: AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
|
getMSGNTF c cId =
|
|
get c =##> \case ("", c', MSGNTF {}) -> c' == cId; _ -> False
|
|
|
|
testOnlyCreatePull :: IO ()
|
|
testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do
|
|
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate
|
|
liftIO $ sqSecured `shouldBe` True
|
|
Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice
|
|
getMSGNTF alice bobId
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
liftIO $ threadDelay 1_000000
|
|
getMsg bob aliceId $ do
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob ##> ("", aliceId, CON)
|
|
getMSGNTF bob aliceId
|
|
liftIO $ threadDelay 1_000000
|
|
get alice ##> ("", bobId, CON) -- sent to initiating party after sending confirmation
|
|
-- exchange messages
|
|
2 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT 2)
|
|
getMsg bob aliceId $
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId 2 Nothing
|
|
getMSGNTF bob aliceId
|
|
3 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT 3)
|
|
getMsg alice bobId $
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId 3 Nothing
|
|
getMSGNTF alice bobId
|
|
|
|
makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
|
makeConnection = makeConnection_ PQSupportOn True
|
|
|
|
makeConnection_ :: PQSupport -> SndQueueSecured -> AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
|
makeConnection_ pqEnc sqSecured alice bob = makeConnectionForUsers_ pqEnc sqSecured alice 1 bob 1
|
|
|
|
makeConnectionForUsers :: HasCallStack => AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
|
makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
|
|
|
|
makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
|
makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
|
|
(bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive aliceUserId True True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe
|
|
aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
|
|
sqSecured' <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
|
|
liftIO $ sqSecured' `shouldBe` sqSecured
|
|
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
|
liftIO $ pqSup' `shouldBe` pqSupport
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
let pqEnc = CR.pqSupportToEnc pqSupport
|
|
get alice ##> ("", bobId, A.CON pqEnc)
|
|
get bob ##> ("", aliceId, A.INFO pqSupport "alice's connInfo")
|
|
get bob ##> ("", aliceId, A.CON pqEnc)
|
|
pure (aliceId, bobId)
|
|
|
|
testInactiveNoSubs :: (ASrvTransport, AStoreType) -> IO ()
|
|
testInactiveNoSubs (t, msType) = do
|
|
let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
|
|
withSmpServerConfigOn t cfg' testPort $ \_ ->
|
|
withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
|
|
runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check
|
|
Just (_, _, AEvt SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice)
|
|
Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
|
|
pure ()
|
|
|
|
testInactiveWithSubs :: (ASrvTransport, AStoreType) -> IO ()
|
|
testInactiveWithSubs (t, msType) = do
|
|
let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
|
|
withSmpServerConfigOn t cfg' testPort $ \_ ->
|
|
withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
|
|
runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
Nothing <- 800000 `timeout` get alice
|
|
liftIO $ threadDelay 1200000
|
|
-- and after 2 sec of inactivity no DOWN is sent as we have a live subscription
|
|
liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing
|
|
|
|
testActiveClientNotDisconnected :: (ASrvTransport, AStoreType) -> IO ()
|
|
testActiveClientNotDisconnected (t, msType) = do
|
|
let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
|
|
withSmpServerConfigOn t cfg' testPort $ \_ ->
|
|
withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
|
|
ts <- getSystemTime
|
|
runRight_ $ do
|
|
(connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
keepSubscribing alice connId ts
|
|
where
|
|
keepSubscribing :: AgentClient -> ConnId -> SystemTime -> ExceptT AgentErrorType IO ()
|
|
keepSubscribing alice connId ts = do
|
|
ts' <- liftIO getSystemTime
|
|
if milliseconds ts' - milliseconds ts < 2200
|
|
then do
|
|
-- keep sending SUB for 2.2 seconds
|
|
liftIO $ threadDelay 200000
|
|
subscribeConnection alice connId
|
|
keepSubscribing alice connId ts
|
|
else do
|
|
-- check that nothing is sent from agent
|
|
Nothing <- 800000 `timeout` get alice
|
|
liftIO $ threadDelay 1200000
|
|
-- and after 2 sec of inactivity no DOWN is sent as we have a live subscription
|
|
liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing
|
|
milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000)
|
|
|
|
testSuspendingAgent :: IO ()
|
|
testSuspendingAgent =
|
|
withAgentClients2 $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
2 <- sendMessage a bId SMP.noMsgFlags "hello"
|
|
get a ##> ("", bId, SENT 2)
|
|
get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
|
|
ackMessage b aId 2 Nothing
|
|
liftIO $ suspendAgent b 1000000
|
|
get' b ##> ("", "", SUSPENDED)
|
|
3 <- sendMessage a bId SMP.noMsgFlags "hello 2"
|
|
get a ##> ("", bId, SENT 3)
|
|
Nothing <- 100000 `timeout` get b
|
|
liftIO $ foregroundAgent b
|
|
get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
|
|
|
|
testSuspendingAgentCompleteSending :: (ASrvTransport, AStoreType) -> IO ()
|
|
testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do
|
|
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
2 <- sendMessage a bId SMP.noMsgFlags "hello"
|
|
get a ##> ("", bId, SENT 2)
|
|
get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
|
|
ackMessage b aId 2 Nothing
|
|
pure (aId, bId)
|
|
runRight_ $ do
|
|
("", "", DOWN {}) <- nGet a
|
|
("", "", DOWN {}) <- nGet b
|
|
3 <- sendMessage b aId SMP.noMsgFlags "hello too"
|
|
4 <- sendMessage b aId SMP.noMsgFlags "how are you?"
|
|
liftIO $ threadDelay 100000
|
|
liftIO $ suspendAgent b 5000000
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ @AgentErrorType $ do
|
|
-- there will be no UP event for b, because re-subscriptions are suspended until the agent is in foreground
|
|
get b =##> \case ("", c, SENT 3) -> c == aId; _ -> False
|
|
get b =##> \case ("", c, SENT 4) -> c == aId; _ -> False
|
|
nGet b ##> ("", "", SUSPENDED)
|
|
liftIO $
|
|
getInAnyOrder
|
|
a
|
|
[ \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; _ -> False,
|
|
\case ("", "", AEvt _ UP {}) -> True; _ -> False
|
|
]
|
|
ackMessage a bId 3 Nothing
|
|
get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
|
|
ackMessage a bId 4 Nothing
|
|
|
|
testSuspendingAgentTimeout :: (ASrvTransport, AStoreType) -> IO ()
|
|
testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do
|
|
(aId, _) <- withSmpServer ps . runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
2 <- sendMessage a bId SMP.noMsgFlags "hello"
|
|
get a ##> ("", bId, SENT 2)
|
|
get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
|
|
ackMessage b aId 2 Nothing
|
|
pure (aId, bId)
|
|
|
|
runRight_ $ do
|
|
("", "", DOWN {}) <- nGet a
|
|
("", "", DOWN {}) <- nGet b
|
|
3 <- sendMessage b aId SMP.noMsgFlags "hello too"
|
|
4 <- sendMessage b aId SMP.noMsgFlags "how are you?"
|
|
liftIO $ suspendAgent b 100000
|
|
("", "", SUSPENDED) <- nGet b
|
|
pure ()
|
|
|
|
testBatchedSubscriptions :: Int -> Int -> (ASrvTransport, AStoreType) -> IO ()
|
|
testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = do
|
|
(conns, conns') <- withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
|
|
conns <- runServers $ do
|
|
conns <- replicateM nCreate $ makeConnection_ PQSupportOff True a b
|
|
forM_ conns $ \(aId, bId) -> exchangeGreetings_ PQEncOff a bId b aId
|
|
let (aIds', bIds') = unzip $ take nDel conns
|
|
delete a bIds'
|
|
delete b aIds'
|
|
liftIO $ threadDelay 1000000
|
|
pure conns
|
|
let conns' = drop nDel conns
|
|
(aIds', bIds') = unzip conns'
|
|
down a bIds'
|
|
down b aIds'
|
|
runServers $ do
|
|
up a bIds'
|
|
up b aIds'
|
|
down a bIds'
|
|
down b aIds'
|
|
pure (conns, conns')
|
|
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
|
|
runServers $ do
|
|
liftIO $ threadDelay 1000000
|
|
let (aIds, bIds) = unzip conns
|
|
(aIds', bIds') = unzip conns'
|
|
subscribe a bIds'
|
|
subscribe b aIds'
|
|
forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 4 a bId b aId
|
|
void $ resubscribeConnections a bIds
|
|
void $ resubscribeConnections b aIds
|
|
forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId
|
|
delete a bIds'
|
|
delete b aIds'
|
|
deleteFail a bIds'
|
|
deleteFail b aIds'
|
|
where
|
|
down c cs = do
|
|
("", "", DOWN _ cs1) <- nGet c
|
|
("", "", DOWN _ cs2) <- nGet c
|
|
liftIO $ S.fromList (cs1 ++ cs2) `shouldBe` S.fromList cs
|
|
up c cs = do
|
|
("", "", UP _ cs1) <- nGet c
|
|
("", "", UP _ cs2) <- nGet c
|
|
liftIO $ S.fromList (cs1 ++ cs2) `shouldBe` S.fromList cs
|
|
subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
|
|
subscribe c cs = do
|
|
subscribeAllConnections c False Nothing
|
|
liftIO $ up c cs
|
|
delete :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
|
|
delete c cs = do
|
|
r <- deleteConnections c cs
|
|
liftIO $ do
|
|
all isRight r `shouldBe` True
|
|
M.keys r `shouldMatchList` cs
|
|
deleteFail :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
|
|
deleteFail c cs = do
|
|
r <- deleteConnections c cs
|
|
liftIO $ do
|
|
all (== Left (CONN NOT_FOUND "")) r `shouldBe` True
|
|
M.keys r `shouldMatchList` cs
|
|
runServers :: ExceptT AgentErrorType IO a -> IO a
|
|
runServers a = do
|
|
withSmpServerStoreLogOn ps testPort $ \t1 -> do
|
|
res <- withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \t2 ->
|
|
runRight a `finally` killThread t2
|
|
killThread t1
|
|
pure res
|
|
|
|
testBatchedPendingMessages :: Int -> Int -> IO ()
|
|
testBatchedPendingMessages nCreate nMsgs =
|
|
withA $ \a -> do
|
|
conns <- withB $ \b -> runRight $ do
|
|
replicateM nCreate $ makeConnection a b
|
|
let msgConns = take nMsgs conns
|
|
runRight_ $ forM_ msgConns $ \(_, bId) -> sendMessage a bId SMP.noMsgFlags "hello"
|
|
replicateM_ nMsgs $ get a =##> \case ("", cId, SENT _) -> isJust $ find ((cId ==) . snd) msgConns; _ -> False
|
|
withB $ \b -> runRight_ $ do
|
|
let aIds = map fst conns
|
|
subscribeAllConnections b False Nothing
|
|
("", "", UP _ aIds') <- nGet b
|
|
liftIO $ S.fromList aIds' `shouldBe` S.fromList aIds
|
|
replicateM_ nMsgs $ do
|
|
("", cId, Msg' msgId _ "hello") <- get b
|
|
liftIO $ isJust (find ((cId ==) . fst) msgConns) `shouldBe` True
|
|
ackMessage b cId msgId Nothing
|
|
where
|
|
withA = withAgent 1 agentCfg initAgentServers testDB
|
|
withB = withAgent 2 agentCfg initAgentServers testDB2
|
|
|
|
testSendMessagesB :: IO ()
|
|
testSendMessagesB = withAgentClients2 $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
let msg cId body = Right (cId, PQEncOn, SMP.noMsgFlags, vrValue body)
|
|
[SentB 2, SentB 3, SentB 4] <- sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3"] :: [Either AgentErrorType MsgReq])
|
|
get a ##> ("", bId, SENT 2)
|
|
get a ##> ("", bId, SENT 3)
|
|
get a ##> ("", bId, SENT 4)
|
|
receiveMsg b aId 2 "msg 1"
|
|
receiveMsg b aId 3 "msg 2"
|
|
receiveMsg b aId 4 "msg 3"
|
|
|
|
testSendMessagesB2 :: IO ()
|
|
testSendMessagesB2 = withAgentClients3 $ \a b c -> runRight_ $ do
|
|
(abId, bId) <- makeConnection a b
|
|
(acId, cId) <- makeConnection a c
|
|
let msg connId body = msgVR connId $ vrValue body
|
|
[SentB 2, SentB 3, SentB 4, SentB 2, SentB 3] <-
|
|
sendMessagesB a ([msg bId "msg 1", msg "" "msg 2", msg "" "msg 3", msg cId "msg 4", msg "" "msg 5"] :: [Either AgentErrorType MsgReq])
|
|
liftIO $
|
|
getInAnyOrder
|
|
a
|
|
[ \case ("", cId', AEvt SAEConn (SENT 2)) -> cId' == bId; _ -> False,
|
|
\case ("", cId', AEvt SAEConn (SENT 3)) -> cId' == bId; _ -> False,
|
|
\case ("", cId', AEvt SAEConn (SENT 4)) -> cId' == bId; _ -> False,
|
|
\case ("", cId', AEvt SAEConn (SENT 2)) -> cId' == cId; _ -> False,
|
|
\case ("", cId', AEvt SAEConn (SENT 3)) -> cId' == cId; _ -> False
|
|
]
|
|
receiveMsg b abId 2 "msg 1"
|
|
receiveMsg b abId 3 "msg 2"
|
|
receiveMsg b abId 4 "msg 3"
|
|
receiveMsg c acId 2 "msg 4"
|
|
receiveMsg c acId 3 "msg 5"
|
|
let msg' connId i body = msgVR connId $ VRValue (Just i) body
|
|
[SentB 5, SentB 6, SentB 4, SentB 5] <-
|
|
sendMessagesB a ([msg' bId 0 "msg 5", msg' "" 1 "msg 6", msgVR cId (VRRef 0), msgVR "" (VRRef 1)] :: [Either AgentErrorType MsgReq])
|
|
liftIO $
|
|
getInAnyOrder
|
|
a
|
|
[ \case ("", cId', AEvt SAEConn (SENT 5)) -> cId' == bId; _ -> False,
|
|
\case ("", cId', AEvt SAEConn (SENT 6)) -> cId' == bId; _ -> False,
|
|
\case ("", cId', AEvt SAEConn (SENT 4)) -> cId' == cId; _ -> False,
|
|
\case ("", cId', AEvt SAEConn (SENT 5)) -> cId' == cId; _ -> False
|
|
]
|
|
receiveMsg b abId 5 "msg 5"
|
|
receiveMsg b abId 6 "msg 6"
|
|
receiveMsg c acId 4 "msg 5"
|
|
receiveMsg c acId 5 "msg 6"
|
|
where
|
|
msgVR connId mbr = Right (connId, PQEncOn, SMP.noMsgFlags, mbr)
|
|
|
|
pattern SentB :: AgentMsgId -> Either AgentErrorType (AgentMsgId, PQEncryption)
|
|
pattern SentB msgId <- Right (msgId, PQEncOn)
|
|
|
|
receiveMsg :: AgentClient -> ConnId -> AgentMsgId -> MsgBody -> ExceptT AgentErrorType IO ()
|
|
receiveMsg c cId msgId msg = do
|
|
get c =##> \case ("", cId', Msg' mId' PQEncOn msg') -> cId' == cId && mId' == msgId && msg' == msg; _ -> False
|
|
ackMessage c cId msgId Nothing
|
|
|
|
testAsyncCommands :: SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
|
testAsyncCommands sqSecured alice bob baseId =
|
|
runRight_ $ do
|
|
bobId <- createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
|
("1", bobId', INV (ACR _ qInfo)) <- get alice
|
|
liftIO $ bobId' `shouldBe` bobId
|
|
aliceId <- joinConnectionAsync bob 1 "2" Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
|
("2", aliceId', JOINED sqSecured') <- get bob
|
|
liftIO $ do
|
|
aliceId' `shouldBe` aliceId
|
|
sqSecured' `shouldBe` sqSecured
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice
|
|
allowConnectionAsync alice "3" bobId confId "alice's connInfo"
|
|
get alice =##> \case ("3", _, OK) -> True; _ -> False
|
|
get alice ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob ##> ("", aliceId, CON)
|
|
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
|
|
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT $ baseId + 1)
|
|
2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
|
get alice ##> ("", bobId, SENT $ baseId + 2)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessageAsync bob "4" aliceId (baseId + 1) Nothing
|
|
inAnyOrder
|
|
(get bob)
|
|
[ \case ("4", _, OK) -> True; _ -> False,
|
|
\case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
|
|
]
|
|
ackMessageAsync bob "5" aliceId (baseId + 2) Nothing
|
|
get bob =##> \case ("5", _, OK) -> True; _ -> False
|
|
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 3)
|
|
4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 4)
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessageAsync alice "6" bobId (baseId + 3) Nothing
|
|
inAnyOrder
|
|
(get alice)
|
|
[ \case ("6", _, OK) -> True; _ -> False,
|
|
\case ("", c, Msg "message 1") -> c == bobId; _ -> False
|
|
]
|
|
ackMessageAsync alice "7" bobId (baseId + 4) Nothing
|
|
get alice =##> \case ("7", _, OK) -> True; _ -> False
|
|
deleteConnectionAsync alice False bobId
|
|
get alice =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing)]) -> c == bobId; _ -> False
|
|
get alice =##> \case ("", "", DEL_CONNS [c]) -> c == bobId; _ -> False
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
where
|
|
msgId = subtract baseId
|
|
|
|
testSetConnShortLinkAsync :: (ASrvTransport, AStoreType) -> IO ()
|
|
testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
let userData = UserLinkData "test user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
newLinkData = UserContactLinkData userCtData
|
|
(cId, CCLink qInfo (Just shortLink)) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just newLinkData) Nothing IKPQOn SMSubscribe
|
|
-- verify initial link data
|
|
(_, ContactLinkData _ userCtData') <- getConnShortLink bob 1 shortLink
|
|
liftIO $ userCtData' `shouldBe` userCtData
|
|
-- update link data async
|
|
let updatedData = UserLinkData "updated user data"
|
|
updatedCtData = UserContactData {direct = False, owners = [], relays = [], userData = updatedData}
|
|
setConnShortLinkAsync alice "1" cId (UserContactLinkData updatedCtData) Nothing
|
|
("1", cId', LINK shortLink' (UserContactLinkData updatedCtData')) <- get alice
|
|
liftIO $ cId' `shouldBe` cId
|
|
liftIO $ shortLink' `shouldBe` shortLink
|
|
liftIO $ updatedCtData' `shouldBe` updatedCtData
|
|
-- verify updated link data
|
|
(_, ContactLinkData _ updatedCtData'') <- getConnShortLink bob 1 shortLink'
|
|
liftIO $ updatedCtData'' `shouldBe` updatedCtData
|
|
-- complete connection via contact address
|
|
(aliceId, _) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
|
("", _, REQ invId _ "bob's connInfo") <- get alice
|
|
bobId <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
|
|
_ <- acceptContact alice 1 bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
("", _, CONF confId _ "alice's connInfo") <- get bob
|
|
allowConnection bob aliceId confId "bob's connInfo"
|
|
get alice ##> ("", bobId, INFO "bob's connInfo")
|
|
get alice ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, CON)
|
|
|
|
testGetConnShortLinkAsync :: (ASrvTransport, AStoreType) -> IO ()
|
|
testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
let userData = UserLinkData "test user data"
|
|
userCtData = UserContactData {direct = True, owners = [], relays = [], userData}
|
|
newLinkData = UserContactLinkData userCtData
|
|
(_, CCLink qInfo (Just shortLink)) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just newLinkData) Nothing IKPQOn SMSubscribe
|
|
-- get link data async - creates new connection for bob
|
|
newId <- getConnShortLinkAsync bob 1 "1" Nothing shortLink
|
|
("1", newId', LDATA FixedLinkData {linkConnReq = qInfo'} (ContactLinkData _ userCtData')) <- get bob
|
|
liftIO $ newId' `shouldBe` newId
|
|
liftIO $ qInfo' `shouldBe` qInfo
|
|
liftIO $ userCtData' `shouldBe` userCtData
|
|
-- join connection async using connId from getConnShortLinkAsync
|
|
aliceId <- joinConnectionAsync bob 1 "2" (Just newId) True qInfo' "bob's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ aliceId `shouldBe` newId
|
|
("2", aliceId', JOINED False) <- get bob
|
|
liftIO $ aliceId' `shouldBe` aliceId
|
|
-- complete connection
|
|
("", _, REQ invId _ "bob's connInfo") <- get alice
|
|
bobId <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
|
|
_ <- acceptContact alice 1 bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
("", _, CONF confId _ "alice's connInfo") <- get bob
|
|
allowConnection bob aliceId confId "bob's connInfo"
|
|
get alice ##> ("", bobId, INFO "bob's connInfo")
|
|
get alice ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, CON)
|
|
|
|
testAsyncCommandsRestore :: (ASrvTransport, AStoreType) -> IO ()
|
|
testAsyncCommandsRestore ps = do
|
|
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
|
bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
|
liftIO $ noMessages alice "alice doesn't receive INV because server is down"
|
|
disposeAgentClient alice
|
|
withAgent 2 agentCfg initAgentServers testDB $ \alice' ->
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
subscribeConnection alice' bobId
|
|
get alice' =##> \case ("1", _, INV _) -> True; _ -> False
|
|
pure ()
|
|
|
|
testAcceptContactAsync :: SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
|
testAcceptContactAsync sqSecured alice bob baseId =
|
|
runRight_ $ do
|
|
(_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe
|
|
(aliceId, sqSecuredJoin) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
|
("", _, REQ invId _ "bob's connInfo") <- get alice
|
|
bobId <- acceptContactAsync alice 1 "1" True invId "alice's connInfo" PQSupportOn SMSubscribe
|
|
get alice =##> \case ("1", c, JOINED sqSecured') -> c == bobId && sqSecured' == sqSecured; _ -> False
|
|
("", _, CONF confId _ "alice's connInfo") <- get bob
|
|
allowConnection bob aliceId confId "bob's connInfo"
|
|
get alice ##> ("", bobId, INFO "bob's connInfo")
|
|
get alice ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, CON)
|
|
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
|
|
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT $ baseId + 1)
|
|
2 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
|
get alice ##> ("", bobId, SENT $ baseId + 2)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 2) Nothing
|
|
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 3)
|
|
4 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 1"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 4)
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId (baseId + 3) Nothing
|
|
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
|
|
ackMessage alice bobId (baseId + 4) Nothing
|
|
suspendConnection alice bobId
|
|
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
|
|
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 5); _ -> False
|
|
deleteConnection alice bobId
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
where
|
|
msgId = subtract baseId
|
|
|
|
testDeleteConnectionAsync :: (ASrvTransport, AStoreType) -> IO ()
|
|
testDeleteConnectionAsync ps =
|
|
withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do
|
|
connIds <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
(bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe
|
|
(bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe
|
|
(bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe
|
|
pure ([bId1, bId2, bId3] :: [ConnId])
|
|
runRight_ $ do
|
|
deleteConnectionsAsync a False connIds
|
|
nGet a =##> \case ("", "", DOWN {}) -> True; _ -> False
|
|
let delOk = \case (c, _, _, Just (BROKER _ e)) -> c `elem` connIds && networkOrTimeoutError e; _ -> False
|
|
get a =##> \case ("", "", DEL_RCVQS rs) -> length rs == 3 && all delOk rs; _ -> False
|
|
get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False
|
|
liftIO $ noMessages a "nothing else should be delivered to alice"
|
|
|
|
testWaitDeliveryNoPending :: (ASrvTransport, AStoreType) -> IO ()
|
|
testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob ->
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
(aliceId, bobId) <- makeConnection alice bob
|
|
|
|
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT $ baseId + 1)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
|
|
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId (baseId + 2) Nothing
|
|
|
|
deleteConnectionsAsync alice True [bobId]
|
|
get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Nothing)]) -> cId == bobId; _ -> False
|
|
get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
|
|
|
|
3 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
|
|
get bob =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == aliceId && mId == (baseId + 3); _ -> False
|
|
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
where
|
|
baseId = 1
|
|
msgId = subtract baseId
|
|
|
|
testWaitDelivery :: (ASrvTransport, AStoreType) -> IO ()
|
|
testWaitDelivery ps =
|
|
withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
|
|
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
|
|
(aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
(aliceId, bobId) <- makeConnection alice bob
|
|
|
|
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT $ baseId + 1)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
|
|
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId (baseId + 2) Nothing
|
|
|
|
pure (aliceId, bobId)
|
|
|
|
runRight_ $ do
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob
|
|
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
|
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
|
deleteConnectionsAsync alice True [bobId]
|
|
get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
get alice ##> ("", bobId, SENT $ baseId + 3)
|
|
get alice ##> ("", bobId, SENT $ baseId + 4)
|
|
get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
|
|
|
|
liftIO $
|
|
getInAnyOrder
|
|
bob
|
|
[ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
|
\case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
|
]
|
|
ackMessage bob aliceId (baseId + 3) Nothing
|
|
get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 4) Nothing
|
|
|
|
-- queue wasn't deleted (DEL never reached server, see DEL_RCVQ with error), so bob can send message
|
|
5 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "message 2"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 5)
|
|
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
where
|
|
baseId = 1
|
|
msgId = subtract baseId
|
|
|
|
testWaitDeliveryAUTHErr :: (ASrvTransport, AStoreType) -> IO ()
|
|
testWaitDeliveryAUTHErr ps =
|
|
withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
|
|
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
|
|
(_aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
(aliceId, bobId) <- makeConnection alice bob
|
|
|
|
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT $ baseId + 1)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
|
|
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId (baseId + 2) Nothing
|
|
|
|
deleteConnectionsAsync bob False [aliceId]
|
|
get bob =##> \case ("", "", DEL_RCVQS [(cId, _, _, Nothing)]) -> cId == aliceId; _ -> False
|
|
get bob =##> \case ("", "", DEL_CONNS [cId]) -> cId == aliceId; _ -> False
|
|
|
|
pure (aliceId, bobId)
|
|
|
|
runRight_ $ do
|
|
("", "", DOWN _ _) <- nGet alice
|
|
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
|
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
|
deleteConnectionsAsync alice True [bobId]
|
|
get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 3); _ -> False
|
|
get alice =##> \case ("", cId, MERR mId (SMP _ AUTH)) -> cId == bobId && mId == (baseId + 4); _ -> False
|
|
get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
|
|
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
where
|
|
baseId = 1
|
|
msgId = subtract baseId
|
|
|
|
testWaitDeliveryTimeout :: (ASrvTransport, AStoreType) -> IO ()
|
|
testWaitDeliveryTimeout ps =
|
|
withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
|
|
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
|
|
(aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
(aliceId, bobId) <- makeConnection alice bob
|
|
|
|
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT $ baseId + 1)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
|
|
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId (baseId + 2) Nothing
|
|
|
|
pure (aliceId, bobId)
|
|
|
|
runRight_ $ do
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob
|
|
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
|
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
|
deleteConnectionsAsync alice True [bobId]
|
|
get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
|
|
get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
|
|
liftIO $ threadDelay 100000
|
|
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
nGet bob =##> \case ("", "", UP _ [cId]) -> cId == aliceId; _ -> False
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
where
|
|
baseId = 1
|
|
msgId = subtract baseId
|
|
|
|
testWaitDeliveryTimeout2 :: (ASrvTransport, AStoreType) -> IO ()
|
|
testWaitDeliveryTimeout2 ps =
|
|
withAgent 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
|
|
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
|
|
(aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
(aliceId, bobId) <- makeConnection alice bob
|
|
|
|
1 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
get alice ##> ("", bobId, SENT $ baseId + 1)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId (baseId + 1) Nothing
|
|
|
|
2 <- msgId <$> sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
get bob ##> ("", aliceId, SENT $ baseId + 2)
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId (baseId + 2) Nothing
|
|
|
|
pure (aliceId, bobId)
|
|
|
|
runRight_ $ do
|
|
("", "", DOWN _ _) <- nGet alice
|
|
("", "", DOWN _ _) <- nGet bob
|
|
3 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "how are you?"
|
|
4 <- msgId <$> sendMessage alice bobId SMP.noMsgFlags "message 1"
|
|
deleteConnectionsAsync alice True [bobId]
|
|
get alice =##> \case ("", "", DEL_RCVQS [(cId, _, _, Just (BROKER _ e))]) -> cId == bobId && networkOrTimeoutError e; _ -> False
|
|
get alice =##> \case ("", "", DEL_CONNS [cId]) -> cId == bobId; _ -> False
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
get alice ##> ("", bobId, SENT $ baseId + 3)
|
|
-- "message 1" not delivered
|
|
|
|
liftIO $
|
|
getInAnyOrder
|
|
bob
|
|
[ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
|
\case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
|
]
|
|
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
|
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
|
where
|
|
baseId = 1
|
|
msgId = subtract baseId
|
|
|
|
networkOrTimeoutError :: BrokerErrorType -> Bool
|
|
networkOrTimeoutError = \case
|
|
TIMEOUT -> True
|
|
NETWORK _ -> True
|
|
_ -> False
|
|
|
|
testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do
|
|
let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
|
|
withAgent 1 cfg' initAgentServers testDB $ \a ->
|
|
withAgent 2 cfg' initAgentServersSrv2 testDB2 $ \b -> do
|
|
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
bId <- createConnectionAsync a 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
|
("1", bId', INV (ACR _ qInfo)) <- get a
|
|
liftIO $ bId' `shouldBe` bId
|
|
aId <- joinConnectionAsync b 1 "2" Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ threadDelay 500000
|
|
ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
|
|
pure (aId, bId)
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
|
withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do
|
|
get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && not sqSecured; _ -> False
|
|
confId <- withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
pGet a >>= \case
|
|
("", "", AEvt _ (UP _ [_])) -> do
|
|
("", _, CONF confId _ "bob's connInfo") <- get a
|
|
pure confId
|
|
("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do
|
|
("", "", UP _ [_]) <- nGet a
|
|
pure confId
|
|
r -> error $ "unexpected response " <> show r
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
|
runRight_ $ do
|
|
allowConnectionAsync a "3" bId confId "alice's connInfo"
|
|
get a ##> ("3", bId, OK)
|
|
liftIO $ threadDelay 500000
|
|
ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
|
|
pure ()
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
|
|
get a ##> ("", bId, CON)
|
|
get b ##> ("", aId, INFO "alice's connInfo")
|
|
get b ##> ("", aId, CON)
|
|
exchangeGreetingsMsgId 4 a bId b aId
|
|
where
|
|
cfg' =
|
|
agentCfgVPrevPQ
|
|
{ smpClientVRange = V.mkVersionRange initialSMPClientVersion srvHostnamesSMPClientVersion, -- before SKEY
|
|
smpCfg = smpCfgVPrev {serverVRange = V.mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} -- before SKEY
|
|
}
|
|
|
|
testJoinConnectionAsyncReplyError :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do
|
|
let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
|
|
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
|
withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do
|
|
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
bId <- createConnectionAsync a 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
|
("1", bId', INV (ACR _ qInfo)) <- get a
|
|
liftIO $ bId' `shouldBe` bId
|
|
aId <- joinConnectionAsync b 1 "2" Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
|
liftIO $ threadDelay 500000
|
|
ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
|
|
pure (aId, bId)
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
|
withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> do
|
|
confId <- withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
-- both servers need to be online for connection to progress because of SKEY
|
|
get b =##> \case ("2", c, JOINED sqSecured) -> c == aId && sqSecured; _ -> False
|
|
pGet a >>= \case
|
|
("", "", AEvt _ (UP _ [_])) -> do
|
|
("", _, CONF confId _ "bob's connInfo") <- get a
|
|
pure confId
|
|
("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do
|
|
("", "", UP _ [_]) <- nGet a
|
|
pure confId
|
|
r -> error $ "unexpected response " <> show r
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
|
runRight_ $ do
|
|
allowConnectionAsync a "3" bId confId "alice's connInfo"
|
|
get a ##> ("3", bId, OK)
|
|
get a ##> ("", bId, CON)
|
|
liftIO $ threadDelay 500000
|
|
ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
|
|
pure ()
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
|
|
get b ##> ("", aId, INFO "alice's connInfo")
|
|
get b ##> ("", aId, CON)
|
|
exchangeGreetings a bId b aId
|
|
|
|
testUsers :: IO ()
|
|
testUsers =
|
|
withAgentClients2 $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
auId <- createUser a False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
|
|
(aId', bId') <- makeConnectionForUsers a auId b 1
|
|
exchangeGreetings a bId' b aId'
|
|
deleteUser a auId True
|
|
get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing)]) -> c == bId'; _ -> False
|
|
get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False
|
|
nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
|
|
exchangeGreetingsMsgId 4 a bId b aId
|
|
liftIO $ noMessages a "nothing else should be delivered to alice"
|
|
|
|
testDeleteUserQuietly :: IO ()
|
|
testDeleteUserQuietly =
|
|
withAgentClients2 $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
auId <- createUser a False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
|
|
(aId', bId') <- makeConnectionForUsers a auId b 1
|
|
exchangeGreetings a bId' b aId'
|
|
deleteUser a auId False
|
|
exchangeGreetingsMsgId 4 a bId b aId
|
|
liftIO $ noMessages a "nothing else should be delivered to alice"
|
|
|
|
testUsersNoServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do
|
|
(aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
auId <- createUser a False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
|
|
(aId', bId') <- makeConnectionForUsers a auId b 1
|
|
exchangeGreetings a bId' b aId'
|
|
pure (aId, bId, auId, aId', bId')
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
|
|
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
|
|
nGet b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
|
|
runRight_ $ do
|
|
deleteUser a auId True
|
|
get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Just (BROKER _ e))]) -> c == bId' && networkOrTimeoutError e;; _ -> False
|
|
get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId'; _ -> False
|
|
nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
|
|
liftIO $ noMessages a "nothing else should be delivered to alice"
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
|
|
nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False
|
|
exchangeGreetingsMsgId 4 a bId b aId
|
|
where
|
|
aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3}
|
|
|
|
testSwitchConnection :: InitialAgentServers -> IO ()
|
|
testSwitchConnection servers =
|
|
withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
testFullSwitch a bId b aId 8
|
|
testFullSwitch a bId b aId 14
|
|
|
|
testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO ()
|
|
testFullSwitch a bId b aId msgId = do
|
|
stats <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
|
switchComplete a bId b aId
|
|
exchangeGreetingsMsgId msgId a bId b aId
|
|
|
|
switchComplete :: AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()
|
|
switchComplete a bId b aId = do
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
|
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
|
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
|
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
|
phaseSnd b aId SPCompleted [Nothing]
|
|
phaseRcv a bId SPCompleted [Nothing]
|
|
|
|
phaseRcv :: AgentClient -> ByteString -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ExceptT AgentErrorType IO ()
|
|
phaseRcv c connId p swchStatuses = phase c connId QDRcv p (\stats -> rcvSwchStatuses' stats `shouldMatchList` swchStatuses)
|
|
|
|
rcvSwchStatuses' :: ConnectionStats -> [Maybe RcvSwitchStatus]
|
|
rcvSwchStatuses' ConnectionStats {rcvQueuesInfo} = map (\RcvQueueInfo {rcvSwitchStatus} -> rcvSwitchStatus) rcvQueuesInfo
|
|
|
|
phaseSnd :: AgentClient -> ByteString -> SwitchPhase -> [Maybe SndSwitchStatus] -> ExceptT AgentErrorType IO ()
|
|
phaseSnd c connId p swchStatuses = phase c connId QDSnd p (\stats -> sndSwchStatuses' stats `shouldMatchList` swchStatuses)
|
|
|
|
sndSwchStatuses' :: ConnectionStats -> [Maybe SndSwitchStatus]
|
|
sndSwchStatuses' ConnectionStats {sndQueuesInfo} = map (\SndQueueInfo {sndSwitchStatus} -> sndSwitchStatus) sndQueuesInfo
|
|
|
|
phase :: AgentClient -> ByteString -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Expectation) -> ExceptT AgentErrorType IO ()
|
|
phase c connId d p statsExpectation =
|
|
get c >>= \(_, connId', msg) -> do
|
|
liftIO $ connId `shouldBe` connId'
|
|
case msg of
|
|
SWITCH d' p' stats -> liftIO $ do
|
|
d `shouldBe` d'
|
|
p `shouldBe` p'
|
|
statsExpectation stats
|
|
ERR (AGENT A_DUPLICATE {}) -> phase c connId d p statsExpectation
|
|
r -> do
|
|
liftIO . putStrLn $ "expected: " <> show p <> ", received: " <> show r
|
|
SWITCH {} <- pure r
|
|
pure ()
|
|
|
|
testSwitchAsync :: HasCallStack => InitialAgentServers -> IO ()
|
|
testSwitchAsync servers = do
|
|
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
pure (aId, bId)
|
|
let withA' = sessionSubscribe withA [bId]
|
|
withB' = sessionSubscribe withB [aId]
|
|
withA' $ \a -> do
|
|
stats <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
withB' $ \b -> do
|
|
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
|
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
withA' $ \a -> do
|
|
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
|
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
|
withB' $ \b -> do
|
|
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
|
phaseSnd b aId SPCompleted [Nothing]
|
|
withA' $ \a -> phaseRcv a bId SPCompleted [Nothing]
|
|
withA $ \a -> withB $ \b -> runRight_ $ do
|
|
subscribeConnection a bId
|
|
subscribeConnection b aId
|
|
exchangeGreetingsMsgId 8 a bId b aId
|
|
testFullSwitch a bId b aId 14
|
|
where
|
|
withA :: (AgentClient -> IO a) -> IO a
|
|
withA = withAgent 1 agentCfg servers testDB
|
|
withB :: (AgentClient -> IO a) -> IO a
|
|
withB = withAgent 2 agentCfg servers testDB2
|
|
|
|
withAgent :: HasCallStack => Int -> AgentConfig -> InitialAgentServers -> String -> (HasCallStack => AgentClient -> IO a) -> IO a
|
|
withAgent clientId cfg' servers dbPath = bracket (getSMPAgentClient' clientId cfg' servers dbPath) (\a -> disposeAgentClient a >> threadDelay 100000)
|
|
|
|
sessionSubscribe :: (forall a. (AgentClient -> IO a) -> IO a) -> [ConnId] -> (AgentClient -> ExceptT AgentErrorType IO ()) -> IO ()
|
|
sessionSubscribe withC connIds a =
|
|
withC $ \c -> runRight_ $ do
|
|
void $ subscribeConnections c connIds
|
|
r <- a c
|
|
liftIO $ threadDelay 500000
|
|
liftIO $ noMessages c "nothing else should be delivered"
|
|
pure r
|
|
|
|
testSwitchDelete :: InitialAgentServers -> IO ()
|
|
testSwitchDelete servers =
|
|
withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
liftIO $ disposeAgentClient b
|
|
stats <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
deleteConnectionAsync a False bId
|
|
get a =##> \case ("", "", DEL_RCVQS [(c, _, _, Nothing), (c', _, _, Nothing)]) -> c == bId && c' == bId; _ -> False
|
|
get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId; _ -> False
|
|
liftIO $ noMessages a "nothing else should be delivered to alice"
|
|
|
|
testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO ()
|
|
testAbortSwitchStarted servers = do
|
|
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
pure (aId, bId)
|
|
let withA' = sessionSubscribe withA [bId]
|
|
withB' = sessionSubscribe withB [aId]
|
|
withA' $ \a -> do
|
|
stats <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
-- repeat switch is prohibited
|
|
Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ switchConnectionAsync a "" bId
|
|
-- abort current switch
|
|
stats' <- abortConnectionSwitch a bId
|
|
liftIO $ rcvSwchStatuses' stats' `shouldMatchList` [Nothing]
|
|
withB' $ \b -> do
|
|
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
|
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
withA' $ \a -> do
|
|
get a ##> ("", bId, ERR (AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}}))
|
|
-- repeat switch
|
|
stats <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
withA $ \a -> withB $ \b -> runRight_ $ do
|
|
subscribeConnection a bId
|
|
subscribeConnection b aId
|
|
|
|
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
|
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
|
|
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
|
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
|
|
|
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
|
phaseSnd b aId SPCompleted [Nothing]
|
|
|
|
phaseRcv a bId SPCompleted [Nothing]
|
|
|
|
exchangeGreetingsMsgId 10 a bId b aId
|
|
|
|
testFullSwitch a bId b aId 16
|
|
where
|
|
withA :: (AgentClient -> IO a) -> IO a
|
|
withA = withAgent 1 agentCfg servers testDB
|
|
withB :: (AgentClient -> IO a) -> IO a
|
|
withB = withAgent 2 agentCfg servers testDB2
|
|
|
|
testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO ()
|
|
testAbortSwitchStartedReinitiate servers = do
|
|
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
pure (aId, bId)
|
|
let withA' = sessionSubscribe withA [bId]
|
|
withB' = sessionSubscribe withB [aId]
|
|
withA' $ \a -> do
|
|
stats <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
-- abort current switch
|
|
stats' <- abortConnectionSwitch a bId
|
|
liftIO $ rcvSwchStatuses' stats' `shouldMatchList` [Nothing]
|
|
-- repeat switch
|
|
stats'' <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats'' `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
withB' $ \b -> do
|
|
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
|
liftIO . getInAnyOrder b $
|
|
[ switchPhaseSndP aId SPStarted [Just SSSendingQKEY, Nothing],
|
|
switchPhaseSndP aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
]
|
|
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
withA $ \a -> withB $ \b -> runRight_ $ do
|
|
subscribeConnection a bId
|
|
subscribeConnection b aId
|
|
|
|
liftIO . getInAnyOrder a $
|
|
[ errQueueNotFoundP bId,
|
|
switchPhaseRcvP bId SPConfirmed [Just RSSendingQADD, Nothing]
|
|
]
|
|
|
|
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
|
|
|
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
|
phaseSnd b aId SPCompleted [Nothing]
|
|
|
|
phaseRcv a bId SPCompleted [Nothing]
|
|
|
|
exchangeGreetingsMsgId 10 a bId b aId
|
|
|
|
testFullSwitch a bId b aId 16
|
|
where
|
|
withA :: (AgentClient -> IO a) -> IO a
|
|
withA = withAgent 1 agentCfg servers testDB
|
|
withB :: (AgentClient -> IO a) -> IO a
|
|
withB = withAgent 2 agentCfg servers testDB2
|
|
|
|
switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission -> Bool
|
|
switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses)
|
|
|
|
switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission -> Bool
|
|
switchPhaseSndP cId sphase swchStatuses = switchPhaseP cId QDSnd sphase (\stats -> sndSwchStatuses' stats == swchStatuses)
|
|
|
|
switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission -> Bool
|
|
switchPhaseP cId qd sphase statsP = \case
|
|
(_, cId', AEvt SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
|
|
_ -> False
|
|
|
|
errQueueNotFoundP :: ConnId -> ATransmission -> Bool
|
|
errQueueNotFoundP cId = \case
|
|
(_, cId', AEvt SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId
|
|
_ -> False
|
|
|
|
testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
|
|
testCannotAbortSwitchSecured servers = do
|
|
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
|
(aId, bId) <- makeConnection a b
|
|
exchangeGreetings a bId b aId
|
|
pure (aId, bId)
|
|
let withA' = sessionSubscribe withA [bId]
|
|
withB' = sessionSubscribe withB [aId]
|
|
withA' $ \a -> do
|
|
stats <- switchConnectionAsync a "" bId
|
|
liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId SPStarted [Just RSSendingQADD, Nothing]
|
|
withB' $ \b -> do
|
|
phaseSnd b aId SPStarted [Just SSSendingQKEY, Nothing]
|
|
phaseSnd b aId SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
withA' $ \a -> do
|
|
phaseRcv a bId SPConfirmed [Just RSSendingQADD, Nothing]
|
|
phaseRcv a bId SPSecured [Just RSSendingQUSE, Nothing]
|
|
Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ abortConnectionSwitch a bId
|
|
pure ()
|
|
withA $ \a -> withB $ \b -> runRight_ $ do
|
|
subscribeConnection a bId
|
|
subscribeConnection b aId
|
|
|
|
phaseSnd b aId SPSecured [Just SSSendingQTEST, Nothing]
|
|
phaseSnd b aId SPCompleted [Nothing]
|
|
|
|
phaseRcv a bId SPCompleted [Nothing]
|
|
|
|
exchangeGreetingsMsgId 8 a bId b aId
|
|
|
|
testFullSwitch a bId b aId 14
|
|
where
|
|
withA :: (AgentClient -> IO a) -> IO a
|
|
withA = withAgent 1 agentCfg servers testDB
|
|
withB :: (AgentClient -> IO a) -> IO a
|
|
withB = withAgent 2 agentCfg servers testDB2
|
|
|
|
testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO ()
|
|
testSwitch2Connections servers = do
|
|
(aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do
|
|
(aId1, bId1) <- makeConnection a b
|
|
exchangeGreetings a bId1 b aId1
|
|
(aId2, bId2) <- makeConnection a b
|
|
exchangeGreetings a bId2 b aId2
|
|
pure (aId1, bId1, aId2, bId2)
|
|
let withA' = sessionSubscribe withA [bId1, bId2]
|
|
withB' = sessionSubscribe withB [aId1, aId2]
|
|
withA' $ \a -> do
|
|
stats1 <- switchConnectionAsync a "" bId1
|
|
liftIO $ rcvSwchStatuses' stats1 `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
|
|
stats2 <- switchConnectionAsync a "" bId2
|
|
liftIO $ rcvSwchStatuses' stats2 `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
|
|
withB' $ \b -> do
|
|
liftIO . getInAnyOrder b $
|
|
[ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],
|
|
switchPhaseSndP aId1 SPConfirmed [Just SSSendingQKEY, Nothing],
|
|
switchPhaseSndP aId2 SPStarted [Just SSSendingQKEY, Nothing],
|
|
switchPhaseSndP aId2 SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
]
|
|
withA' $ \a -> do
|
|
liftIO . getInAnyOrder a $
|
|
[ switchPhaseRcvP bId1 SPConfirmed [Just RSSendingQADD, Nothing],
|
|
switchPhaseRcvP bId1 SPSecured [Just RSSendingQUSE, Nothing],
|
|
switchPhaseRcvP bId2 SPConfirmed [Just RSSendingQADD, Nothing],
|
|
switchPhaseRcvP bId2 SPSecured [Just RSSendingQUSE, Nothing]
|
|
]
|
|
withB' $ \b -> do
|
|
liftIO . getInAnyOrder b $
|
|
[ switchPhaseSndP aId1 SPSecured [Just SSSendingQTEST, Nothing],
|
|
switchPhaseSndP aId1 SPCompleted [Nothing],
|
|
switchPhaseSndP aId2 SPSecured [Just SSSendingQTEST, Nothing],
|
|
switchPhaseSndP aId2 SPCompleted [Nothing]
|
|
]
|
|
withA' $ \a -> do
|
|
liftIO . getInAnyOrder a $
|
|
[ switchPhaseRcvP bId1 SPCompleted [Nothing],
|
|
switchPhaseRcvP bId2 SPCompleted [Nothing]
|
|
]
|
|
withA $ \a -> withB $ \b -> runRight_ $ do
|
|
void $ subscribeConnections a [bId1, bId2]
|
|
void $ subscribeConnections b [aId1, aId2]
|
|
|
|
exchangeGreetingsMsgId 8 a bId1 b aId1
|
|
exchangeGreetingsMsgId 8 a bId2 b aId2
|
|
|
|
testFullSwitch a bId1 b aId1 14
|
|
testFullSwitch a bId2 b aId2 14
|
|
where
|
|
withA :: (AgentClient -> IO a) -> IO a
|
|
withA = withAgent 1 agentCfg servers testDB
|
|
withB :: (AgentClient -> IO a) -> IO a
|
|
withB = withAgent 2 agentCfg servers testDB2
|
|
|
|
testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO ()
|
|
testSwitch2ConnectionsAbort1 servers = do
|
|
(aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do
|
|
(aId1, bId1) <- makeConnection a b
|
|
exchangeGreetings a bId1 b aId1
|
|
(aId2, bId2) <- makeConnection a b
|
|
exchangeGreetings a bId2 b aId2
|
|
pure (aId1, bId1, aId2, bId2)
|
|
let withA' = sessionSubscribe withA [bId1, bId2]
|
|
withB' = sessionSubscribe withB [aId1, aId2]
|
|
withA' $ \a -> do
|
|
stats1 <- switchConnectionAsync a "" bId1
|
|
liftIO $ rcvSwchStatuses' stats1 `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId1 SPStarted [Just RSSendingQADD, Nothing]
|
|
stats2 <- switchConnectionAsync a "" bId2
|
|
liftIO $ rcvSwchStatuses' stats2 `shouldMatchList` [Just RSSwitchStarted]
|
|
phaseRcv a bId2 SPStarted [Just RSSendingQADD, Nothing]
|
|
-- abort switch of second connection
|
|
stats2' <- abortConnectionSwitch a bId2
|
|
liftIO $ rcvSwchStatuses' stats2' `shouldMatchList` [Nothing]
|
|
withB' $ \b -> do
|
|
liftIO . getInAnyOrder b $
|
|
[ switchPhaseSndP aId1 SPStarted [Just SSSendingQKEY, Nothing],
|
|
switchPhaseSndP aId1 SPConfirmed [Just SSSendingQKEY, Nothing],
|
|
switchPhaseSndP aId2 SPStarted [Just SSSendingQKEY, Nothing],
|
|
switchPhaseSndP aId2 SPConfirmed [Just SSSendingQKEY, Nothing]
|
|
]
|
|
withA' $ \a -> do
|
|
liftIO . getInAnyOrder a $
|
|
[ switchPhaseRcvP bId1 SPConfirmed [Just RSSendingQADD, Nothing],
|
|
switchPhaseRcvP bId1 SPSecured [Just RSSendingQUSE, Nothing],
|
|
errQueueNotFoundP bId2
|
|
]
|
|
withA $ \a -> withB $ \b -> runRight_ $ do
|
|
void $ subscribeConnections a [bId1, bId2]
|
|
void $ subscribeConnections b [aId1, aId2]
|
|
|
|
phaseSnd b aId1 SPSecured [Just SSSendingQTEST, Nothing]
|
|
phaseSnd b aId1 SPCompleted [Nothing]
|
|
|
|
phaseRcv a bId1 SPCompleted [Nothing]
|
|
|
|
exchangeGreetingsMsgId 8 a bId1 b aId1
|
|
exchangeGreetingsMsgId 6 a bId2 b aId2
|
|
|
|
testFullSwitch a bId1 b aId1 14
|
|
testFullSwitch a bId2 b aId2 12
|
|
where
|
|
withA :: (AgentClient -> IO a) -> IO a
|
|
withA = withAgent 1 agentCfg servers testDB
|
|
withB :: (AgentClient -> IO a) -> IO a
|
|
withB = withAgent 2 agentCfg servers testDB2
|
|
|
|
testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
|
|
testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
|
|
a <- getClient 1 clnt1 testDB
|
|
b <- getClient 2 clnt2 testDB2
|
|
r <- runRight $ do
|
|
tryError (createConnection a 1 True SCMInvitation Nothing SMSubscribe) >>= \case
|
|
Left (SMP _ AUTH) -> pure 0
|
|
Left e -> throwError e
|
|
Right (bId, qInfo) ->
|
|
tryError (joinConnection b 1 True qInfo "bob's connInfo" SMSubscribe) >>= \case
|
|
Left (SMP _ AUTH) -> pure 1
|
|
Left e -> throwError e
|
|
Right (aId, sqSecured') -> do
|
|
liftIO $ sqSecured' `shouldBe` sqSecured
|
|
("", _, CONF confId _ "bob's connInfo") <- get a
|
|
allowConnection a bId confId "alice's connInfo"
|
|
get a ##> ("", bId, CON)
|
|
get b ##> ("", aId, INFO "alice's connInfo")
|
|
get b ##> ("", aId, CON)
|
|
exchangeGreetingsMsgId (baseId + 1) a bId b aId
|
|
pure 2
|
|
disposeAgentClient a
|
|
disposeAgentClient b
|
|
pure r
|
|
where
|
|
getClient clientId (clntAuth, clntVersion) db =
|
|
let servers = initAgentServers {smp = userServers' [ProtoServerWithAuth testSMPServer clntAuth]}
|
|
alpn_ = if clntVersion >= authCmdsSMPVersion then Just alpnSupportedSMPHandshakes else Nothing
|
|
smpCfg = defaultClientConfig alpn_ False $ V.mkVersionRange minClientSMPRelayVersion clntVersion
|
|
sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
|
|
in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
|
|
|
|
testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
|
testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv =
|
|
withSmpServerConfigOn t cfg' testPort2 $ \_ -> do
|
|
-- initially passed server is not running
|
|
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
|
testProtocolServer a NRMInteractive 1 srv
|
|
where
|
|
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth}
|
|
|
|
testRatchetAdHash :: HasCallStack => IO ()
|
|
testRatchetAdHash =
|
|
withAgentClients2 $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
ad1 <- getConnectionRatchetAdHash a bId
|
|
ad2 <- getConnectionRatchetAdHash b aId
|
|
liftIO $ ad1 `shouldBe` ad2
|
|
|
|
testDeliveryReceipts :: HasCallStack => IO ()
|
|
testDeliveryReceipts =
|
|
withAgentClients2 $ \a b -> runRight_ $ do
|
|
(aId, bId) <- makeConnection a b
|
|
-- a sends, b receives and sends delivery receipt
|
|
2 <- sendMessage a bId SMP.noMsgFlags "hello"
|
|
get a ##> ("", bId, SENT 2)
|
|
get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False
|
|
ackMessage b aId 2 $ Just ""
|
|
get a =##> \case ("", c, Rcvd 2) -> c == bId; _ -> False
|
|
ackMessage a bId 3 Nothing
|
|
-- b sends, a receives and sends delivery receipt
|
|
4 <- sendMessage b aId SMP.noMsgFlags "hello too"
|
|
get b ##> ("", aId, SENT 4)
|
|
get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
|
|
ackMessage a bId 4 $ Just ""
|
|
get b =##> \case ("", c, Rcvd 4) -> c == aId; _ -> False
|
|
ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e)
|
|
ackMessage b aId 5 Nothing
|
|
|
|
testDeliveryReceiptsVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testDeliveryReceiptsVersion ps = do
|
|
a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
|
|
b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
|
|
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
|
|
(aId, bId) <- runRight $ do
|
|
(aId, bId) <- makeConnection_ PQSupportOff False a b
|
|
checkVersion a bId 3
|
|
checkVersion b aId 3
|
|
(2, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello"
|
|
get a ##> ("", bId, SENT 2)
|
|
get b =##> \case ("", c, Msg' 2 PQEncOff "hello") -> c == aId; _ -> False
|
|
ackMessage b aId 2 $ Just ""
|
|
liftIO $ noMessages a "no delivery receipt (unsupported version)"
|
|
(3, _) <- A.sendMessage b aId PQEncOff SMP.noMsgFlags "hello too"
|
|
get b ##> ("", aId, SENT 3)
|
|
get a =##> \case ("", c, Msg' 3 PQEncOff "hello too") -> c == bId; _ -> False
|
|
ackMessage a bId 3 $ Just ""
|
|
liftIO $ noMessages b "no delivery receipt (unsupported version)"
|
|
pure (aId, bId)
|
|
|
|
disposeAgentClient a
|
|
disposeAgentClient b
|
|
a' <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB
|
|
b' <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB2
|
|
|
|
runRight_ $ do
|
|
subscribeConnection a' bId
|
|
subscribeConnection b' aId
|
|
exchangeGreetingsMsgId_ PQEncOff 4 a' bId b' aId
|
|
checkVersion a' bId 7
|
|
checkVersion b' aId 7
|
|
(6, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello"
|
|
get a' ##> ("", bId, SENT 6)
|
|
get b' =##> \case ("", c, Msg' 6 PQEncOff "hello") -> c == aId; _ -> False
|
|
ackMessage b' aId 6 $ Just ""
|
|
get a' =##> \case ("", c, Rcvd 6) -> c == bId; _ -> False
|
|
ackMessage a' bId 7 Nothing
|
|
(8, PQEncOff) <- A.sendMessage b' aId PQEncOn SMP.noMsgFlags "hello too"
|
|
get b' ##> ("", aId, SENT 8)
|
|
get a' =##> \case ("", c, Msg' 8 PQEncOff "hello too") -> c == bId; _ -> False
|
|
ackMessage a' bId 8 $ Just ""
|
|
get b' =##> \case ("", c, Rcvd 8) -> c == aId; _ -> False
|
|
ackMessage b' aId 9 Nothing
|
|
(10, _) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello 2"
|
|
get a' ##> ("", bId, SENT 10)
|
|
get b' =##> \case ("", c, Msg' 10 PQEncOff "hello 2") -> c == aId; _ -> False
|
|
ackMessage b' aId 10 $ Just ""
|
|
get a' =##> \case ("", c, Rcvd 10) -> c == bId; _ -> False
|
|
ackMessage a' bId 11 Nothing
|
|
disposeAgentClient a'
|
|
disposeAgentClient b'
|
|
|
|
testDeliveryReceiptsConcurrent :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testDeliveryReceiptsConcurrent (t, msType) =
|
|
withSmpServerConfigOn t cfg' testPort $ \_ -> do
|
|
withAgentClients2 $ \a b -> do
|
|
(aId, bId) <- runRight $ makeConnection a b
|
|
t1 <- liftIO getCurrentTime
|
|
concurrently_ (runClient "a" a bId) (runClient "b" b aId)
|
|
t2 <- liftIO getCurrentTime
|
|
diffUTCTime t2 t1 `shouldSatisfy` (< 60)
|
|
liftIO $ noMessages a "nothing else should be delivered to alice"
|
|
liftIO $ noMessages b "nothing else should be delivered to bob"
|
|
where
|
|
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 256, maxJournalMsgCount = 512}
|
|
runClient :: String -> AgentClient -> ConnId -> IO ()
|
|
runClient _cName client connId = do
|
|
concurrently_ send receive
|
|
where
|
|
numMsgs = 100
|
|
send = runRight_ $
|
|
replicateM_ numMsgs $ do
|
|
void $ sendMessage client connId SMP.noMsgFlags "hello"
|
|
receive =
|
|
runRight_ $
|
|
-- for each sent message: 1 SENT, 1 RCVD, 1 OK for acknowledging RCVD
|
|
-- for each received message: 1 MSG, 1 OK for acknowledging MSG
|
|
receiveLoop (numMsgs * 5)
|
|
receiveLoop :: Int -> ExceptT AgentErrorType IO ()
|
|
receiveLoop 0 = pure ()
|
|
receiveLoop n = do
|
|
r <- getWithTimeout
|
|
case r of
|
|
(_, _, SENT _) -> do
|
|
-- liftIO $ print $ cName <> ": SENT"
|
|
pure ()
|
|
(_, _, MSG MsgMeta {recipient = (msgId, _), integrity = MsgOk} _ _) -> do
|
|
-- liftIO $ print $ cName <> ": MSG " <> show msgId
|
|
ackMessageAsync client (B.pack . show $ n) connId msgId (Just "")
|
|
(_, _, RCVD MsgMeta {recipient = (msgId, _), integrity = MsgOk} _) -> do
|
|
-- liftIO $ print $ cName <> ": RCVD " <> show msgId
|
|
ackMessageAsync client (B.pack . show $ n) connId msgId Nothing
|
|
(_, _, OK) -> do
|
|
-- liftIO $ print $ cName <> ": OK"
|
|
pure ()
|
|
r' -> error $ "unexpected event: " <> show r'
|
|
receiveLoop (n - 1)
|
|
getWithTimeout :: ExceptT AgentErrorType IO (AEntityTransmission 'AEConn)
|
|
getWithTimeout = do
|
|
3000000 `timeout` get client >>= \case
|
|
Just r -> pure r
|
|
_ -> error "timeout"
|
|
|
|
testTwoUsers :: HasCallStack => IO ()
|
|
testTwoUsers = withAgentClients2 $ \a b -> do
|
|
let nc = netCfg initAgentServers
|
|
sessionMode nc `shouldBe` TSMSession
|
|
runRight_ $ do
|
|
(aId1, bId1) <- makeConnectionForUsers a 1 b 1
|
|
exchangeGreetings a bId1 b aId1
|
|
(aId1', bId1') <- makeConnectionForUsers a 1 b 1
|
|
exchangeGreetings a bId1' b aId1'
|
|
a `hasClients` 1
|
|
b `hasClients` 1
|
|
setNetworkConfig a nc {sessionMode = TSMEntity}
|
|
liftIO $ threadDelay 250000
|
|
("", "", DOWN _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
a `hasClients` 2
|
|
|
|
exchangeGreetingsMsgId 4 a bId1 b aId1
|
|
exchangeGreetingsMsgId 4 a bId1' b aId1'
|
|
liftIO $ threadDelay 250000
|
|
setNetworkConfig a nc {sessionMode = TSMUser}
|
|
liftIO $ threadDelay 250000
|
|
("", "", DOWN _ _) <- nGet a
|
|
("", "", DOWN _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
a `hasClients` 1
|
|
|
|
aUserId2 <- createUser a False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
|
|
(aId2, bId2) <- makeConnectionForUsers a aUserId2 b 1
|
|
exchangeGreetings a bId2 b aId2
|
|
(aId2', bId2') <- makeConnectionForUsers a aUserId2 b 1
|
|
exchangeGreetings a bId2' b aId2'
|
|
a `hasClients` 2
|
|
b `hasClients` 1
|
|
setNetworkConfig a nc {sessionMode = TSMEntity}
|
|
liftIO $ threadDelay 250000
|
|
("", "", DOWN _ _) <- nGet a
|
|
("", "", DOWN _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
a `hasClients` 4
|
|
exchangeGreetingsMsgId 6 a bId1 b aId1
|
|
exchangeGreetingsMsgId 6 a bId1' b aId1'
|
|
exchangeGreetingsMsgId 4 a bId2 b aId2
|
|
exchangeGreetingsMsgId 4 a bId2' b aId2'
|
|
liftIO $ threadDelay 250000
|
|
setNetworkConfig a nc {sessionMode = TSMUser}
|
|
liftIO $ threadDelay 250000
|
|
("", "", DOWN _ _) <- nGet a
|
|
("", "", DOWN _ _) <- nGet a
|
|
("", "", DOWN _ _) <- nGet a
|
|
-- to avoice race condition
|
|
nGet a =##> \case ("", "", DOWN _ _) -> True; ("", "", UP _ _) -> True; _ -> False
|
|
nGet a =##> \case ("", "", UP _ _) -> True; ("", "", DOWN _ _) -> True; _ -> False
|
|
("", "", UP _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
("", "", UP _ _) <- nGet a
|
|
a `hasClients` 2
|
|
exchangeGreetingsMsgId 8 a bId1 b aId1
|
|
exchangeGreetingsMsgId 8 a bId1' b aId1'
|
|
exchangeGreetingsMsgId 6 a bId2 b aId2
|
|
exchangeGreetingsMsgId 6 a bId2' b aId2'
|
|
where
|
|
hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
|
|
hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
|
|
|
|
testClientServiceConnection :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testClientServiceConnection ps = do
|
|
((sId, uId), qIdHash) <- withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
conns@(sId, uId) <- withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> runRight $ do
|
|
conns@(sId, uId) <- makeConnection service user
|
|
exchangeGreetings service uId user sId
|
|
pure conns
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> runRight $ do
|
|
liftIO $ threadDelay 250000
|
|
[(_, Right (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 1 qIdHash)))] <- M.toList <$> subscribeClientServices service 1
|
|
("", "", SERVICE_ALL _) <- nGet service
|
|
subscribeConnection user sId
|
|
exchangeGreetingsMsgId 4 service uId user sId
|
|
pure (conns, qIdHash)
|
|
(uId', sId') <- withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
liftIO $ threadDelay 250000
|
|
subscribeAllConnections service False Nothing
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 1 qIdHash')))) -> qIdHash' == qIdHash; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
subscribeConnection user sId
|
|
exchangeGreetingsMsgId 6 service uId user sId
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 1 qIdHash')) <- nGet service
|
|
qIdHash' `shouldBe` qIdHash
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
("", "", UP _ [_]) <- nGet user
|
|
-- Nothing in ServiceSubResult confirms that both counts and IDs hash match
|
|
-- SERVICE_ALL may be deliverd before SERVICE_UP event in case there are no messages to deliver
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 1 qIdHash'')))) -> qIdHash'' == qIdHash; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
exchangeGreetingsMsgId 8 service uId user sId
|
|
conns'@(uId', sId') <- makeConnection user service -- opposite direction
|
|
exchangeGreetings user sId' service uId'
|
|
pure conns'
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
liftIO $ threadDelay 250000
|
|
subscribeAllConnections service False Nothing
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 2 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
-- TODO [certs rcv] test message delivery during subscription
|
|
subscribeAllConnections user False Nothing
|
|
("", "", UP _ [_, _]) <- nGet user
|
|
exchangeGreetingsMsgId 4 user sId' service uId'
|
|
exchangeGreetingsMsgId 10 service uId user sId
|
|
|
|
testClientServiceIDChange :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testClientServiceIDChange ps@(_, ASType qs _) = do
|
|
(sId, uId) <- withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
conns <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
conns@(sId, uId) <- makeConnection service user
|
|
exchangeGreetings service uId user sId
|
|
pure conns
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 1 _)) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 1 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
("", "", UP _ [_]) <- nGet user
|
|
pure ()
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 1 _)) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
pure conns
|
|
_ :: () <- case qs of
|
|
SQSPostgres -> do
|
|
#if defined(dbServerPostgres)
|
|
st <- either (error . show) pure =<< Postgres.createDBStore testStoreDBOpts serverMigrations (MigrationConfig MCError Nothing)
|
|
void $ Postgres.withTransaction st (`PSQL.execute_` "DELETE FROM services")
|
|
#else
|
|
pure ()
|
|
#endif
|
|
SQSMemory -> do
|
|
s <- readFile testStoreLogFile
|
|
removeFile testStoreLogFile
|
|
writeFile testStoreLogFile $ unlines $ filter (not . ("NEW_SERVICE" `isPrefixOf`)) $ lines s
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
liftIO $ threadDelay 250000
|
|
subscribeAllConnections service False Nothing
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult (Just (SMP.SSErrorQueueCount 1 0)) (SMP.ServiceSub _ 0 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (UP _ [_])) -> True; _ -> False
|
|
]
|
|
subscribeAllConnections user False Nothing
|
|
("", "", UP _ [_]) <- nGet user
|
|
exchangeGreetingsMsgId 4 service uId user sId
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 1 _)) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
pure ()
|
|
-- disable service in the client
|
|
withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers) $ \notService user -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
subscribeAllConnections notService False Nothing
|
|
("", "", UP _ [_]) <- nGet notService
|
|
subscribeAllConnections user False Nothing
|
|
("", "", UP _ [_]) <- nGet user
|
|
exchangeGreetingsMsgId 6 notService uId user sId
|
|
|
|
-- | Test that service subscription is correctly cleared and re-established
|
|
-- when server temporarily stops supporting services (askClientCert = False).
|
|
testServiceUnavailableClearsPending :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testServiceUnavailableClearsPending (t, msType) = do
|
|
-- Same agent across all phases to test pendingServiceSub persistence
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
-- Phase 1: Establish connection with active service subscription on normal server
|
|
(_sId, _uId) <- withSmpServerStoreLogOn (t, msType) testPort $ \_ -> runRight $ do
|
|
conns@(sId, uId) <- makeConnection service user
|
|
exchangeGreetings service uId user sId
|
|
pure conns
|
|
("", "", SERVICE_DOWN _ _) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
-- Phase 2: Server without service support: agent gets NO_SERVICE, queue resubscribed without service
|
|
let cfgNoService = updateCfg (cfgMS msType) $ \(cfg' :: ServerConfig s) ->
|
|
let ServerConfig {transportConfig} = cfg'
|
|
in cfg' {transportConfig = transportConfig {askClientCert = False}} :: ServerConfig s
|
|
withSmpServerConfigOn t cfgNoService testPort $ \_ -> do
|
|
("", "", ERR (BROKER _ NO_SERVICE)) <- get service
|
|
("", "", UP _ [_]) <- nGet service
|
|
("", "", UP _ [_]) <- nGet user
|
|
pure ()
|
|
("", "", DOWN _ [_]) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
-- Phase 3: Server with service support restored: only queue subscription, no service subscription
|
|
withSmpServerStoreLogOn (t, msType) testPort $ \_ -> do
|
|
e1 <- nGet service
|
|
case e1 of
|
|
("", "", UP _ [_]) -> pure () -- Fixed: only queue subscription, no service subscription
|
|
("", "", SERVICE_UP _ _) ->
|
|
expectationFailure "pendingServiceSub not cleared, service subscription attempted again"
|
|
("", "", SERVICE_ALL _) ->
|
|
expectationFailure "pendingServiceSub not cleared, service subscription attempted again"
|
|
other -> expectationFailure $ "Unexpected first event: " <> show other
|
|
("", "", UP _ [_]) <- nGet user
|
|
pure ()
|
|
-- Phase 4: After another reconnect cycle, service subscription is re-established
|
|
("", "", SERVICE_DOWN _ _) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
withSmpServerStoreLogOn (t, msType) testPort $ \_ -> do
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ _)) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
("", "", UP _ [_]) <- nGet user
|
|
pure ()
|
|
|
|
-- | Test that service subscription recovers when service ID changes on reconnect.
|
|
-- Server restart with deleted service causes new service ID, triggering SSErrorServiceId.
|
|
-- Queues should be unassociated, resubscribed, and re-associated with new service.
|
|
testServiceIdChangeOnReconnect :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testServiceIdChangeOnReconnect ps@(_, ASType qs _) = do
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
-- Phase 1: Establish connection with active service subscription
|
|
(_sId, _uId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
conns@(sId, uId) <- makeConnection service user
|
|
exchangeGreetings service uId user sId
|
|
pure conns
|
|
("", "", SERVICE_DOWN _ _) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
-- Delete service from server storage, keeping queues
|
|
_ :: () <- case qs of
|
|
SQSPostgres -> do
|
|
#if defined(dbServerPostgres)
|
|
st <- either (error . show) pure =<< Postgres.createDBStore testStoreDBOpts serverMigrations (MigrationConfig MCError Nothing)
|
|
void $ Postgres.withTransaction st (`PSQL.execute_` "DELETE FROM services")
|
|
#else
|
|
pure ()
|
|
#endif
|
|
SQSMemory -> do
|
|
s <- readFile testStoreLogFile
|
|
removeFile testStoreLogFile
|
|
writeFile testStoreLogFile $ unlines $ filter (not . ("NEW_SERVICE" `isPrefixOf`)) $ lines s
|
|
-- Phase 2: Server restart with deleted service - new service ID, SSErrorServiceId
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
("", "", SERVICE_UP _ _) <- nGet service
|
|
("", "", UP _ [_]) <- nGet user
|
|
pure ()
|
|
-- Phase 3: Normal reconnect - service should subscribe normally
|
|
("", "", SERVICE_DOWN _ _) <- nGet service
|
|
("", "", DOWN _ [_]) <- nGet user
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ _)) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
("", "", UP _ [_]) <- nGet user
|
|
pure ()
|
|
|
|
-- | Test that subscribeAllConnections handles service unavailable on startup.
|
|
-- Agent has service credentials but server doesn't support services (askClientCert = False).
|
|
testServiceUnavailableOnStartup :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testServiceUnavailableOnStartup (t, msType) = do
|
|
let srv = initAgentServersClientService
|
|
noSrv = initAgentServers
|
|
-- Phase 1: Establish connection with service
|
|
(sId, uId) <- withAgentClientsServers2 (agentCfg, srv) (agentCfg, noSrv) $ \service user ->
|
|
withSmpServerStoreLogOn (t, msType) testPort $ \_ -> runRight $ do
|
|
conns@(sId, uId) <- makeConnection service user
|
|
exchangeGreetings service uId user sId
|
|
pure conns
|
|
-- Phase 2: Server without service support, new service agent
|
|
let cfgNoService = updateCfg (cfgMS msType) $ \(cfg' :: ServerConfig s) ->
|
|
let ServerConfig {transportConfig} = cfg'
|
|
in cfg' {transportConfig = transportConfig {askClientCert = False}} :: ServerConfig s
|
|
-- Phase 2: Server without service support, service agent gets NO_SERVICE
|
|
withAgentClientsServers2 (agentCfg, srv) (agentCfg, noSrv) $ \service user ->
|
|
withSmpServerConfigOn t cfgNoService testPort $ \_ -> runRight $ do
|
|
subscribeAllConnections service False Nothing
|
|
("", "", ERR (BROKER _ NO_SERVICE)) <- get service
|
|
("", "", UP _ [_]) <- nGet service
|
|
subscribeAllConnections user False Nothing
|
|
("", "", UP _ [_]) <- nGet user
|
|
exchangeGreetingsMsgId 4 service uId user sId
|
|
-- Phase 3: Normal server - cert was deleted, new cert generated,
|
|
-- no service sub in DB yet, queues subscribed individually
|
|
withAgentClientsServers2 (agentCfg, srv) (agentCfg, noSrv) $ \service user ->
|
|
withSmpServerStoreLogOn (t, msType) testPort $ \_ -> runRight $ do
|
|
liftIO $ threadDelay 250000
|
|
subscribeAllConnections service False Nothing
|
|
("", "", UP _ [_]) <- nGet service
|
|
subscribeAllConnections user False Nothing
|
|
("", "", UP _ [_]) <- nGet user
|
|
exchangeGreetingsMsgId 6 service uId user sId
|
|
|
|
testMigrateConnectionsToService :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testMigrateConnectionsToService ps = do
|
|
(((sId1, uId1), (uId2, sId2)), ((sId3, uId3), (uId4, sId4)), ((sId5, uId5), (uId6, sId6))) <-
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
-- starting without service
|
|
cs12@((sId1, uId1), (uId2, sId2)) <-
|
|
withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers) $ \notService user ->
|
|
runRight $ (,) <$> makeConnection notService user <*> makeConnection user notService
|
|
-- migrating to service
|
|
cs34@((sId3, uId3), (uId4, sId4)) <-
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> runRight $ do
|
|
subscribeAllConnections service False Nothing
|
|
service `up` 2
|
|
subscribeAllConnections user False Nothing
|
|
user `up` 2
|
|
exchangeGreetingsMsgId 2 service uId1 user sId1
|
|
exchangeGreetingsMsgId 2 service uId2 user sId2
|
|
(,) <$> makeConnection service user <*> makeConnection user service
|
|
-- starting as service
|
|
cs56 <-
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> runRight $ do
|
|
subscribeAllConnections service False Nothing
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 4 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
subscribeAllConnections user False Nothing
|
|
user `up` 4
|
|
exchangeGreetingsMsgId 4 service uId1 user sId1
|
|
exchangeGreetingsMsgId 4 service uId2 user sId2
|
|
exchangeGreetingsMsgId 2 service uId3 user sId3
|
|
exchangeGreetingsMsgId 2 service uId4 user sId4
|
|
(,) <$> makeConnection service user <*> makeConnection user service
|
|
pure (cs12, cs34, cs56)
|
|
-- server reconnecting resubscribes service
|
|
let testSendMessages6 s u n = do
|
|
exchangeGreetingsMsgId (n + 4) s uId1 u sId1
|
|
exchangeGreetingsMsgId (n + 4) s uId2 u sId2
|
|
exchangeGreetingsMsgId (n + 2) s uId3 u sId3
|
|
exchangeGreetingsMsgId (n + 2) s uId4 u sId4
|
|
exchangeGreetingsMsgId n s uId5 u sId5
|
|
exchangeGreetingsMsgId n s uId6 u sId6
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
subscribeAllConnections service False Nothing
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 6 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
subscribeAllConnections user False Nothing
|
|
user `up` 6
|
|
testSendMessages6 service user 2
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 6 _)) <- nGet service
|
|
user `down` 6
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 6 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
user `up` 6
|
|
testSendMessages6 service user 4
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 6 _)) <- nGet service
|
|
user `down` 6
|
|
-- disabling service and adding connections
|
|
((sId7, uId7), (uId8, sId8)) <-
|
|
withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers) $ \notService user -> do
|
|
cs78@((sId7, uId7), (uId8, sId8)) <-
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
subscribeAllConnections notService False Nothing
|
|
notService `up` 6
|
|
subscribeAllConnections user False Nothing
|
|
user `up` 6
|
|
testSendMessages6 notService user 6
|
|
(,) <$> makeConnection notService user <*> makeConnection user notService
|
|
notService `down` 8
|
|
user `down` 8
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
|
notService `up` 8
|
|
user `up` 8
|
|
testSendMessages6 notService user 8
|
|
exchangeGreetingsMsgId 2 notService uId7 user sId7
|
|
exchangeGreetingsMsgId 2 notService uId8 user sId8
|
|
notService `down` 8
|
|
user `down` 8
|
|
pure cs78
|
|
let testSendMessages8 s u n = do
|
|
testSendMessages6 s u (n + 8)
|
|
exchangeGreetingsMsgId (n + 2) s uId7 u sId7
|
|
exchangeGreetingsMsgId (n + 2) s uId8 u sId8
|
|
-- re-enabling service and adding connections
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
subscribeAllConnections service False Nothing
|
|
service `up` 8
|
|
subscribeAllConnections user False Nothing
|
|
user `up` 8
|
|
testSendMessages8 service user 2
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 8 _)) <- nGet service
|
|
user `down` 8
|
|
-- re-connect to server
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 8 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
user `up` 8
|
|
testSendMessages8 service user 4
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ _ _)) <- nGet service -- should be 8 here
|
|
user `down` 8
|
|
-- restart agents
|
|
withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
subscribeAllConnections service False Nothing
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 8 _)))) -> True; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
subscribeAllConnections user False Nothing
|
|
user `up` 8
|
|
testSendMessages8 service user 6
|
|
("", "", SERVICE_DOWN _ (SMP.ServiceSub _ 8 _)) <- nGet service
|
|
user `down` 8
|
|
runRight_ $ do
|
|
void $ sendMessage user sId7 SMP.noMsgFlags "hello 1"
|
|
void $ sendMessage user sId8 SMP.noMsgFlags "hello 2"
|
|
-- re-connect to server
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
|
liftIO $ getInAnyOrder service
|
|
[ \case ("", "", AEvt SAENone (SERVICE_UP _ (SMP.ServiceSubResult Nothing (SMP.ServiceSub _ 8 _)))) -> True; _ -> False,
|
|
\case ("", c, AEvt SAEConn (Msg "hello 1")) -> c == uId7; _ -> False,
|
|
\case ("", c, AEvt SAEConn (Msg "hello 2")) -> c == uId8; _ -> False,
|
|
\case ("", "", AEvt SAENone (SERVICE_ALL _)) -> True; _ -> False
|
|
]
|
|
liftIO $ getInAnyOrder user
|
|
[ \case ("", "", AEvt SAENone (UP _ [_, _, _, _, _, _, _, _])) -> True; _ -> False,
|
|
\case ("", c, AEvt SAEConn (SENT 10)) -> c == sId7; _ -> False,
|
|
\case ("", c, AEvt SAEConn (SENT 10)) -> c == sId8; _ -> False
|
|
]
|
|
testSendMessages6 service user 16
|
|
where
|
|
up c n = do
|
|
("", "", UP _ conns) <- nGet c
|
|
liftIO $ length conns `shouldBe` n
|
|
down c n = do
|
|
("", "", DOWN _ conns) <- nGet c
|
|
liftIO $ length conns `shouldBe` n
|
|
|
|
getSMPAgentClient' :: Int -> AgentConfig -> InitialAgentServers -> String -> IO AgentClient
|
|
getSMPAgentClient' clientId cfg' initServers dbPath = do
|
|
Right st <- liftIO $ createStore dbPath
|
|
Right c <- runExceptT $ getSMPAgentClient_ clientId cfg' initServers st False
|
|
when (dbNew st) $ insertUser st
|
|
pure c
|
|
|
|
#if defined(dbPostgres)
|
|
createStore :: String -> IO (Either MigrationError DBStore)
|
|
createStore schema = createAgentStore dbOpts $ MigrationConfig MCError Nothing
|
|
where
|
|
dbOpts =
|
|
DBOpts
|
|
{ connstr = testDBConnstr,
|
|
schema = B.pack schema,
|
|
poolSize = 10,
|
|
createSchema = True
|
|
}
|
|
|
|
insertUser :: DBStore -> IO ()
|
|
insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES")
|
|
#else
|
|
createStore :: String -> IO (Either MigrationError DBStore)
|
|
createStore dbPath = createAgentStore (DBOpts dbPath [] "" False True DB.TQOff) (MigrationConfig MCError Nothing)
|
|
|
|
insertUser :: DBStore -> IO ()
|
|
insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)")
|
|
#endif
|
|
|
|
testServerMultipleIdentities :: HasCallStack => IO ()
|
|
testServerMultipleIdentities =
|
|
withAgentClients2 $ \alice bob -> runRight_ $ do
|
|
(bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` True
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
get alice ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob ##> ("", aliceId, CON)
|
|
exchangeGreetings alice bobId bob aliceId
|
|
-- this saves queue with second server identity
|
|
bob' <- liftIO $ do
|
|
Left (BROKER _ (NETWORK _)) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" SMSubscribe
|
|
disposeAgentClient bob
|
|
threadDelay 250000
|
|
getSMPAgentClient' 3 agentCfg initAgentServers testDB2
|
|
subscribeConnection bob' aliceId
|
|
exchangeGreetingsMsgId 4 alice bobId bob' aliceId
|
|
liftIO $ disposeAgentClient bob'
|
|
where
|
|
secondIdentityCReq :: ConnectionRequestUri 'CMInvitation
|
|
secondIdentityCReq =
|
|
CRInvitationUri
|
|
connReqData
|
|
{ crSmpQueues =
|
|
[ SMPQueueUri
|
|
supportedSMPClientVRange
|
|
queueAddr
|
|
{ smpServer = SMPServer "localhost" "5001" (C.KeyHash "\215m\248\251")
|
|
}
|
|
]
|
|
}
|
|
testE2ERatchetParams12
|
|
|
|
testWaitForUserNetwork :: IO ()
|
|
testWaitForUserNetwork = do
|
|
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
|
|
noNetworkDelay a
|
|
setUserNetworkInfo a $ UserNetworkInfo UNNone False
|
|
networkDelay a 100000
|
|
networkDelay a 100000
|
|
setUserNetworkInfo a $ UserNetworkInfo UNCellular True
|
|
noNetworkDelay a
|
|
setUserNetworkInfo a $ UserNetworkInfo UNCellular False
|
|
networkDelay a 100000
|
|
concurrently_
|
|
(threadDelay 50000 >> setUserNetworkInfo a (UserNetworkInfo UNCellular True))
|
|
(networkDelay a 50000)
|
|
noNetworkDelay a
|
|
where
|
|
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0}
|
|
|
|
testDoNotResetOnlineToOffline :: IO ()
|
|
testDoNotResetOnlineToOffline = do
|
|
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
|
|
noNetworkDelay a
|
|
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
|
|
networkDelay a 100000
|
|
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
|
|
setUserNetworkInfo a $ UserNetworkInfo UNWifi True
|
|
noNetworkDelay a
|
|
setUserNetworkInfo a $ UserNetworkInfo UNWifi False -- ingnored
|
|
noNetworkDelay a
|
|
threadDelay 100000
|
|
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
|
|
networkDelay a 100000
|
|
setUserNetworkInfo a $ UserNetworkInfo UNNone False
|
|
networkDelay a 100000
|
|
setUserNetworkInfo a $ UserNetworkInfo UNWifi True
|
|
setUserNetworkInfo a $ UserNetworkInfo UNNone False -- ingnored
|
|
noNetworkDelay a
|
|
where
|
|
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0.1}
|
|
|
|
testResumeMultipleThreads :: IO ()
|
|
testResumeMultipleThreads = do
|
|
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
|
|
noNetworkDelay a
|
|
setUserNetworkInfo a $ UserNetworkInfo UNNone False
|
|
vs <-
|
|
replicateM 50000 $ do
|
|
v <- newEmptyTMVarIO
|
|
void . forkIO $ waitNetwork a >>= atomically . putTMVar v
|
|
pure v
|
|
threadDelay 1000000
|
|
setUserNetworkInfo a $ UserNetworkInfo UNCellular True
|
|
ts <- mapM (atomically . readTMVar) vs
|
|
-- print $ minimum ts
|
|
-- print $ maximum ts
|
|
-- print $ sum ts `div` fromIntegral (length ts)
|
|
let average = sum ts `div` fromIntegral (length ts)
|
|
average < 3000000 `shouldBe` True
|
|
maximum ts < 4000000 `shouldBe` True
|
|
where
|
|
aCfg = agentCfg {userOfflineDelay = 0}
|
|
|
|
testServerQueueInfo :: IO ()
|
|
testServerQueueInfo = do
|
|
withAgentClients2 $ \alice bob -> runRight_ $ do
|
|
(bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
|
liftIO $ threadDelay 200000
|
|
checkEmptyQ alice bobId False
|
|
(aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
|
|
liftIO $ sqSecured `shouldBe` True
|
|
("", _, CONF confId _ "bob's connInfo") <- get alice
|
|
liftIO $ threadDelay 200000
|
|
checkEmptyQ alice bobId True -- secured by sender
|
|
allowConnection alice bobId confId "alice's connInfo"
|
|
get alice ##> ("", bobId, CON)
|
|
get bob ##> ("", aliceId, INFO "alice's connInfo")
|
|
get bob ##> ("", aliceId, CON)
|
|
liftIO $ threadDelay 200000
|
|
checkEmptyQ alice bobId True
|
|
checkEmptyQ bob aliceId True
|
|
let msgId = 2
|
|
(msgId', PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello"
|
|
liftIO $ msgId' `shouldBe` msgId
|
|
get alice ##> ("", bobId, SENT msgId)
|
|
liftIO $ threadDelay 200000
|
|
Just srvMsgId <- checkMsgQ bob aliceId 1
|
|
get bob =##> \case
|
|
("", c, MSG MsgMeta {integrity = MsgOk, broker = (smId, _), recipient = (mId, _), pqEncryption = PQEncOn} _ "hello") ->
|
|
c == aliceId && decodeLatin1 (B64.encode smId) == srvMsgId && mId == msgId
|
|
_ -> False
|
|
ackMessage bob aliceId msgId Nothing
|
|
liftIO $ threadDelay 200000
|
|
checkEmptyQ bob aliceId True
|
|
(msgId1, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 1"
|
|
get alice ##> ("", bobId, SENT msgId1)
|
|
Just _ <- checkMsgQ bob aliceId 1
|
|
(msgId2, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 2"
|
|
get alice ##> ("", bobId, SENT msgId2)
|
|
(msgId3, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 3"
|
|
get alice ##> ("", bobId, SENT msgId3)
|
|
(msgId4, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 4"
|
|
get alice ##> ("", bobId, SENT msgId4)
|
|
Just _ <- checkMsgQ bob aliceId 4
|
|
(msgId5, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello: quota exceeded"
|
|
liftIO $ threadDelay 200000
|
|
Just _ <- checkMsgQ bob aliceId 5
|
|
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 1") -> c == aliceId && mId == msgId1; _ -> False
|
|
ackMessage bob aliceId msgId1 Nothing
|
|
liftIO $ threadDelay 200000
|
|
Just _ <- checkMsgQ bob aliceId 4
|
|
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 2") -> c == aliceId && mId == msgId2; _ -> False
|
|
ackMessage bob aliceId msgId2 Nothing
|
|
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 3") -> c == aliceId && mId == msgId3; _ -> False
|
|
ackMessage bob aliceId msgId3 Nothing
|
|
liftIO $ threadDelay 200000
|
|
Just _ <- checkMsgQ bob aliceId 2
|
|
get bob =##> \case ("", c, Msg' mId PQEncOn "hello 4") -> c == aliceId && mId == msgId4; _ -> False
|
|
ackMessage bob aliceId msgId4 Nothing
|
|
liftIO $ threadDelay 200000
|
|
Just _ <- checkMsgQ bob aliceId 1 -- the one that did not fit now accepted
|
|
get alice ##> ("", bobId, QCONT)
|
|
get alice ##> ("", bobId, SENT msgId5)
|
|
liftIO $ threadDelay 200000
|
|
Just _srvMsgId <- checkQ bob aliceId True (Just QNoSub) 1 (Just MTMessage)
|
|
get bob =##> \case ("", c, Msg' mId PQEncOn "hello: quota exceeded") -> c == aliceId && mId == msgId5 + 1; _ -> False
|
|
ackMessage bob aliceId (msgId5 + 1) Nothing
|
|
liftIO $ threadDelay 200000
|
|
checkEmptyQ bob aliceId True
|
|
pure ()
|
|
where
|
|
checkEmptyQ c cId qiSnd' = do
|
|
r <- checkQ c cId qiSnd' (Just QNoSub) 0 Nothing
|
|
liftIO $ r `shouldBe` Nothing
|
|
checkMsgQ c cId qiSize' = do
|
|
r <- checkQ c cId True (Just QNoSub) qiSize' (Just MTMessage)
|
|
liftIO $ isJust r `shouldBe` True
|
|
pure r
|
|
checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do
|
|
ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c NRMInteractive cId
|
|
liftIO $ do
|
|
qiSnd `shouldBe` qiSnd'
|
|
qiNtf `shouldBe` False
|
|
qSubThread <$> qiSub `shouldBe` qiSubThread_
|
|
qiSize `shouldBe` qiSize'
|
|
msgId_ <- forM qiMsg $ \MsgInfo {msgId, msgType} -> msgId <$ (Just msgType `shouldBe` msgType_)
|
|
qDelivered <$> qiSub `shouldBe` Just msgId_
|
|
pure msgId_
|
|
|
|
testClientNotice :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
|
|
testClientNotice ps = do
|
|
withAgent 1 agentCfg initAgentServers testDB $ \c -> do
|
|
(cId, _) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $
|
|
A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
|
("", "", DOWN _ [_]) <- nGet c
|
|
|
|
addNotice c cId $ Just 1
|
|
|
|
(cId', _) <- withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
subscribedWithErrors c 1
|
|
testNotice c True
|
|
threadDelay 1000000
|
|
runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
|
("", "", DOWN _ [_]) <- nGet c
|
|
|
|
addNotice c cId' $ Just 1
|
|
|
|
(cId'', _) <- withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
subscribedWithErrors c 1
|
|
testNotice c True
|
|
threadDelay 1000000
|
|
testNotice c True
|
|
threadDelay 1000000
|
|
runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
|
|
|
addNotice c cId'' $ Just 1
|
|
|
|
withAgent 1 agentCfg initAgentServers testDB $ \c -> do
|
|
(cId3, _) <- withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
runRight_ $ subscribeAllConnections c False Nothing
|
|
subscribedWithErrors c 3
|
|
testNotice c True
|
|
threadDelay 2000000
|
|
testNotice c True
|
|
threadDelay 1000000
|
|
runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
|
("", "", DOWN _ [_]) <- nGet c
|
|
|
|
addNotice c cId3 Nothing
|
|
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
subscribedWithErrors c 1
|
|
testNotice c False
|
|
|
|
removeNotice c cId3
|
|
|
|
withAgent 1 agentCfg initAgentServers testDB $ \c -> do
|
|
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
|
runRight_ $ subscribeAllConnections c False Nothing
|
|
subscribedWithErrors c 4
|
|
void $ runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
|
where
|
|
addNotice c cId ttl = logNotice c cId $ Just ClientNotice {ttl}
|
|
removeNotice c cId = logNotice c cId Nothing
|
|
logNotice :: AgentClient -> ConnId -> Maybe ClientNotice -> IO ()
|
|
logNotice c cId notice = do
|
|
Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction (store $ agentEnv c) (`getConn` cId)
|
|
withFile testStoreLogFile AppendMode $ \h -> B.hPutStrLn h $ strEncode $ BlockQueue rcvId $ SMP.BlockingInfo SMP.BRContent notice
|
|
subscribedWithErrors c n = do
|
|
("", "", ERRS errs) <- nGet c
|
|
length errs `shouldBe` n
|
|
forM_ errs $ \case
|
|
(_, SMP _ (BLOCKED _)) -> pure ()
|
|
r -> expectationFailure $ "unexpected event: " <> show r
|
|
testNotice :: HasCallStack => AgentClient -> Bool -> IO ()
|
|
testNotice c willExpire = do
|
|
NOTICE "localhost" False expiresAt_ <- runLeft $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
|
isJust expiresAt_ `shouldBe` willExpire
|
|
|
|
noNetworkDelay :: AgentClient -> IO ()
|
|
noNetworkDelay a = do
|
|
d <- waitNetwork a
|
|
unless (d < 10000) $ expectationFailure $ "expected no delay, d = " <> show d
|
|
|
|
networkDelay :: AgentClient -> Int64 -> IO ()
|
|
networkDelay a d' = do
|
|
d <- waitNetwork a
|
|
unless (d' - 1000 < d && d < d' + 15000) $ expectationFailure $ "expected delay " <> show d' <> ", d = " <> show d
|
|
|
|
waitNetwork :: AgentClient -> IO Int64
|
|
waitNetwork a = do
|
|
t <- getCurrentTime
|
|
waitForUserNetwork a
|
|
t' <- getCurrentTime
|
|
pure $ diffToMicroseconds $ diffUTCTime t' t
|
|
|
|
exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
|
exchangeGreetings = exchangeGreetings_ PQEncOn
|
|
|
|
exchangeGreetings_ :: HasCallStack => PQEncryption -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
|
exchangeGreetings_ pqEnc = exchangeGreetingsMsgId_ pqEnc 2
|
|
|
|
exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
|
exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn
|
|
|
|
exchangeGreetingsMsgId_ :: HasCallStack => PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
|
exchangeGreetingsMsgId_ pqEnc msgId = exchangeGreetingsViaProxyMsgId_ False pqEnc msgId msgId
|
|
|
|
exchangeGreetingsViaProxy :: HasCallStack => Bool -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
|
exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2 2
|
|
|
|
exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
|
exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc aMsgId bMsgId alice bobId bob aliceId = do
|
|
msgId1 <- A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello"
|
|
liftIO $ msgId1 `shouldBe` (aMsgId, pqEnc)
|
|
get alice =##> \case ("", c, A.SENT mId srv_) -> c == bobId && mId == aMsgId && viaProxy == isJust srv_; _ -> False
|
|
if aMsgId <= bMsgId
|
|
then get bob =##> \case ("", c, Msg' mId pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False
|
|
else get bob =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False
|
|
ackMessage bob aliceId bMsgId Nothing
|
|
msgId2 <- A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too"
|
|
let aMsgId' = aMsgId + 1
|
|
bMsgId' = bMsgId + 1
|
|
liftIO $ msgId2 `shouldBe` (bMsgId', pqEnc)
|
|
get bob =##> \case ("", c, A.SENT mId srv_) -> c == aliceId && mId == bMsgId' && viaProxy == isJust srv_; _ -> False
|
|
if aMsgId >= bMsgId
|
|
then get alice =##> \case ("", c, Msg' mId pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False
|
|
else get alice =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False
|
|
ackMessage alice bobId aMsgId' Nothing
|
|
|
|
exchangeGreetingsMsgIds :: HasCallStack => AgentClient -> ConnId -> Int64 -> AgentClient -> ConnId -> Int64 -> ExceptT AgentErrorType IO ()
|
|
exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do
|
|
msgId1 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
liftIO $ msgId1 `shouldBe` aliceMsgId
|
|
get alice ##> ("", bobId, SENT aliceMsgId)
|
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
|
ackMessage bob aliceId bobMsgId Nothing
|
|
msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
|
let aliceMsgId' = aliceMsgId + 1
|
|
bobMsgId' = bobMsgId + 1
|
|
liftIO $ msgId2 `shouldBe` bobMsgId'
|
|
get bob ##> ("", aliceId, SENT bobMsgId')
|
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
|
ackMessage alice bobId aliceMsgId' Nothing
|
|
|
|
newtype InternalException e = InternalException {unInternalException :: e}
|
|
deriving (Eq, Show)
|
|
|
|
instance Exception e => Exception (InternalException e)
|
|
|
|
instance Exception e => MonadUnliftIO (ExceptT e IO) where
|
|
{-# INLINE withRunInIO #-}
|
|
withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b
|
|
withRunInIO inner =
|
|
ExceptT . fmap (first unInternalException) . try $
|
|
withRunInIO $ \run ->
|
|
inner $ run . (either (throwIO . InternalException) pure <=< runExceptT)
|