diff --git a/plans/2026-05-18-parallel-message-processing.md b/plans/2026-05-18-parallel-message-processing.md new file mode 100644 index 0000000000..4c9a34ecba --- /dev/null +++ b/plans/2026-05-18-parallel-message-processing.md @@ -0,0 +1,161 @@ +# Parallel Message Processing - Eliminate Single-Thread Bottlenecks + +## Problem + +Message reception flows through two single-thread bottlenecks: + +1. **Agent `msgQ` bottleneck**: Multiple SMP server connections write to one shared `TBQueue` (`AgentClient.msgQ` / `SMPClientAgent.msgQ`). A single `subscriber` thread reads and processes all messages sequentially - DB lookups, double-ratchet decryption, DB writes - regardless of which connection they came from. + +2. **Chat `subQ` bottleneck**: The agent's `subscriber` thread writes processed events to one shared `TBQueue` (`AgentClient.subQ`). A single `agentSubscriber` thread in simplex-chat reads and processes all events sequentially. + +Both bottlenecks serialize work that could run in parallel, since messages from different connections are independent. + +## Solution + +Replace queues with callbacks at both layers. The producer calls a processing function directly in its own thread. + +### Layer 1: SMP client - eliminate `msgQ` + +**Current flow:** +``` +SMP connection thread -> writeTBQueue msgQ -> subscriber thread -> processSMPTransmissions +``` + +**New flow:** +``` +SMP connection thread -> processMsg callback (with per-client MVar lock) +``` + +**Why the MVar lock:** Within one SMP client, two threads produce messages: +- The receive loop (`processMsgs` in `Client.hs:686`) +- `writeSMPMessage` (`Client.hs:874`) - called from `processSUBResponse_` when a SUB response includes an inline MSG + +These two must be serialized within one client. An MVar lock ensures they take turns calling the callback. Across different clients (different server connections), no lock is shared - natural parallelism. + +#### Changes + +**`src/Simplex/Messaging/Client.hs`:** +- In `PClient`: replace `msgQ :: Maybe (TBQueue ...)` with `processServerMsg :: Maybe (ServerTransmissionBatch v err msg -> IO ())` and `processLock :: MVar ()` +- `processMsgs`: acquire `processLock`, call `processServerMsg` with the batch +- `writeSMPMessage`: acquire `processLock`, call `processServerMsg` +- `getProtocolClient`: takes `Maybe (ServerTransmissionBatch v err msg -> IO ())` instead of `Maybe (TBQueue ...)` +- `smpClientStub`: sets `processServerMsg = Nothing` +- `serverTransmission`: unchanged + +**`src/Simplex/Messaging/Agent/Client.hs`:** +- Remove `msgQ` field from `AgentClient` +- `smpConnectClient`: pass `processSMPTransmissions` wrapper as callback instead of `Just msgQ` +- Remove `AgentQueuesInfo` and `getAgentQueuesInfo` entirely (dead with no queues to monitor) +- Add `inflightCallbacks :: TVar Int` for monitoring instead - increment before callback, decrement in bracket + +**`src/Simplex/Messaging/Agent.hs`:** +- Remove `subscriber` function +- Remove `subscriber` from `runAgentThreads` +- `processSMPTransmissions` stays, called directly from SMP client threads +- `agentOperationBracket c AORcvNetwork` moves into the callback wrapper +- Exception handling: wrap callback with `catchOwn` matching current `subscriber`'s error handling + +**`src/Simplex/Messaging/Client/Agent.hs`:** +- `SMPClientAgent`: replace `msgQ` with callback field `processServerMsg :: ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO ()` +- `newSMPClientAgent`: takes callback parameter instead of creating `msgQ` +- `connectClient`: passes callback to `getProtocolClient` + +**`src/Simplex/Messaging/Notifications/Server.hs`:** +- `ntfSubscriber`: remove `receiveSMP` loop; the processing logic becomes the callback passed via `SMPClientAgent` +- Processing stays in M (via `UnliftIO` or pre-bound env) + +**Tests (`tests/SMPProxyTests.hs`):** +- 2 sites: change `getProtocolClient ... (Just msgQ) ...` to pass a callback that writes to a local test TBQueue + +### Layer 2: Agent to chat - eliminate `subQ` + +**Current flow:** +``` +agent processSMPTransmissions -> writeTBQueue subQ -> chat agentSubscriber -> process +``` + +**New flow:** +``` +agent processSMPTransmissions -> processEvent callback [events] +``` + +**Key design decisions:** +- Callback takes `[ATransmission]` (list), not single event. All events from one connection batch are passed together to maintain ordering within a connection. +- Error notifications (currently `nonBlockingWriteTBQueue`) use `forkIO $ callback [event]` - fire-and-forget, order doesn't matter for errors. +- The `isFullTBQueue subQ` / pending mechanism disappears - the callback receives the full list directly, no need to buffer/flush. +- `AgentClient` keeps `testQ :: Maybe (TBQueue ATransmission)` for tests only. + +#### Changes + +**`src/Simplex/Messaging/Agent/Client.hs`:** +- Replace `subQ :: TBQueue ATransmission` with: + - `processEvent :: [ATransmission] -> IO ()` - callback, accepts event list + - `testQ :: Maybe (TBQueue ATransmission)` - test-only, `Nothing` in production +- Remove `AgentQueuesInfo` / `getAgentQueuesInfo` +- Add `inflightCallbacks :: TVar Int` with bracket: `withInflight c $ processEvent c events` + +**`src/Simplex/Messaging/Agent.hs`:** +- `processSMPTransmissions`: accumulate events in a local list (currently uses `pendingMsgs` TVar + flush pattern). Call `processEvent` once at end with the full list. +- `runCommandProcessing`: same - call `processEvent` once with all events for the command batch. Remove `isFullTBQueue`/pending logic. +- All `notify`/`notify'` helpers within `processSMPTransmissions` write to a local `TVar [ATransmission]` instead of directly to `subQ`. Flushed at end as single `processEvent` call. +- Error sites (currently `nonBlockingWriteTBQueue`): use `forkIO $ processEvent c [event]` +- Other direct `writeTBQueue subQ` sites (CONNECT/DISCONNECT events, SUSPENDED, etc.): call `processEvent c [event]` directly. +- Remove `subscriber` function entirely. +- Exception safety: `processEvent` call wrapped in bracket that catches "own" exceptions and logs them. + +**`src/Simplex/Messaging/Agent/Client.hs`:** +- `notifySub'` (line 838): change to `forkIO $ processEvent c [event]` (non-blocking error notification) + +**`src/Simplex/Messaging/Agent/NtfSubSupervisor.hs`:** +- 1 site: change `nonBlockingWriteTBQueue subQ event` to `forkIO $ processEvent c [event]` + +**`src/Simplex/FileTransfer/Agent.hs`:** +- 1 site (line 351): `notify` helper changes to `processEvent c [event]` + +**`simplex-chat/src/Simplex/Chat/Library/Commands.hs`:** +- Remove `agentSubscriber` thread +- Pass chat's `process` function (adapted to accept `[ATransmission]`) as `processEvent` callback at agent initialization + +**Tests:** +- `pGet` changes from `readTBQueue (subQ c)` to `readTBQueue (fromJust $ testQ c)` - 1 line +- Agent test setup: `processEvent = mapM_ (atomically . writeTBQueue q)` where `q` is `testQ` +- ~348 test call sites unchanged + +## Concurrency Safety + +- **Per-SMP-connection:** MVar in each SMP client serializes `processMsgs` and `writeSMPMessage` +- **Cross-connection:** Different SMP clients have different MVars, run in different threads - fully parallel +- **Per-connection-id:** `withConnLock connId` in `processSMPTransmissions` handles per-connection locking +- **Chat callback:** Must be safe for concurrent calls from different agent threads. Chat dispatches by entity type and connection ID; individual handlers use their own locks. +- **Exception safety:** Callback wrapped with bracket pattern - catches own exceptions, logs, decrements inflight counter. Exceptions don't kill SMP client threads. + +## Implementation Order + +Both layers change in one PR since they share `Client.hs`. + +### Phase 1: SMP client callback (`Client.hs` + both agent types) + +- [ ] 1.1 `Client.hs`: Replace `msgQ` with `processServerMsg` callback + `processLock` MVar in `PClient` +- [ ] 1.2 `Client.hs`: Update `processMsgs`, `writeSMPMessage`, `getProtocolClient`, `smpClientStub` +- [ ] 1.3 `Client/Agent.hs`: Replace `msgQ` in `SMPClientAgent` with callback field, update `newSMPClientAgent`, `connectClient` +- [ ] 1.4 `Agent/Client.hs`: Remove `msgQ` from `AgentClient`, update `smpConnectClient` to pass `processSMPTransmissions` as callback +- [ ] 1.5 `Agent.hs`: Remove `subscriber` thread from `runAgentThreads`, add exception wrapper to callback +- [ ] 1.6 `Notifications/Server.hs`: Convert `receiveSMP` from loop to callback passed to `SMPClientAgent` +- [ ] 1.7 `SMPProxyTests.hs`: Update 2 call sites to use callback + local test queue + +### Phase 2: Agent event callback (`subQ` -> `processEvent`) + +- [ ] 2.1 `Agent/Client.hs`: Add `processEvent :: [ATransmission] -> IO ()` and `testQ :: Maybe (TBQueue ATransmission)`, remove `subQ`, remove `AgentQueuesInfo` +- [ ] 2.2 `Agent.hs`: Rewrite `processSMPTransmissions` to accumulate events in local list and call `processEvent` once at end +- [ ] 2.3 `Agent.hs`: Update `runCommandProcessing` - remove pending/isFullTBQueue pattern, call `processEvent` with list +- [ ] 2.4 `Agent.hs`, `Agent/Client.hs`, `NtfSubSupervisor.hs`, `FileTransfer/Agent.hs`: Update all `writeTBQueue subQ` / `nonBlockingWriteTBQueue subQ` sites (~32 total) +- [ ] 2.5 `Agent/Client.hs`: Add inflight counter with bracket +- [ ] 2.6 Update `pGet` to read from `testQ` (1 line), update test agent setup +- [ ] 2.7 `simplex-chat`: Pass chat's `process` as callback, remove `agentSubscriber` +- [ ] 2.8 Fix any multi-server test ordering issues + +## Risks + +- **Chat thread safety:** Chat's `process` may not be safe for concurrent calls. Audit needed. +- **Backpressure:** Slow callback blocks SMP client receive thread. Acceptable - the connection that produced the message waits. Cross-connection interference eliminated. +- **Ordering:** Within one SMP connection - preserved (MVar + list callback). Across connections - non-deterministic (same as today, since `msgQ` interleaving was arbitrary). Most tests use 1 server. diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index a8b220327c..959a45d5f4 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -348,7 +348,7 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m () -notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd) +notify c entId cmd = liftIO $ notifyEvent c ("", entId, AEvt (sAEntity @e) cmd) xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId xftpSendFile' c userId file numRecipients = do diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index bd77b892a1..ff434eda85 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -40,6 +40,7 @@ module Simplex.Messaging.Agent vrValue, getSMPAgentClient, getSMPAgentClient_, + startSMPAgentClient, disconnectAgentClient, disposeAgentClient, resumeAgentClient, @@ -49,6 +50,7 @@ module Simplex.Messaging.Agent deleteUser, setUserService, connRequestPQSupport, + prepareConnectionToCreate, createConnectionAsync, setConnShortLinkAsync, getConnShortLinkAsync, @@ -256,41 +258,45 @@ import UnliftIO.STM type AE a = ExceptT AgentErrorType IO a -- | Creates an SMP agent client instance -getSMPAgentClient :: AgentConfig -> InitialAgentServers -> DBStore -> Bool -> AE AgentClient +getSMPAgentClient :: AgentConfig -> InitialAgentServers -> DBStore -> (ATransmission -> IO ()) -> AE AgentClient getSMPAgentClient = getSMPAgentClient_ 1 {-# INLINE getSMPAgentClient #-} -getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> DBStore -> Bool -> AE AgentClient -getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp, netCfg, useServices, presetServers} store backgroundMode = do +getSMPAgentClient_ :: Int -> AgentConfig -> InitialAgentServers -> DBStore -> (ATransmission -> IO ()) -> AE AgentClient +getSMPAgentClient_ clientId cfg initServers@InitialAgentServers {smp, xftp, netCfg, useServices, presetServers} store processEvent = do -- This error should be prevented in the app when (any id useServices && sessionMode netCfg == TSMEntity) $ throwE $ CMD PROHIBITED "newAgentClient" - liftIO $ newSMPAgentEnv cfg store >>= runReaderT runAgent + liftIO $ newSMPAgentEnv cfg store >>= runReaderT createAgent where - runAgent = do + createAgent = do liftIO $ checkServers "SMP" smp >> checkServers "XFTP" xftp currentTs <- liftIO getCurrentTime notices <- liftIO $ withTransaction store (`getClientNotices` presetServers) `catchAll_` pure [] - c@AgentClient {acThread} <- liftIO . newAgentClient clientId initServers currentTs notices =<< ask - t <- runAgentThreads c `forkFinally` const (liftIO $ disconnectAgentClient c) - atomically . writeTVar acThread . Just =<< mkWeakThreadId t - pure c + env <- ask + let processMsg c t = subscriber c t `runReaderT` env + liftIO $ newAgentClient clientId initServers currentTs notices processEvent processMsg env checkServers protocol srvs = forM_ (M.assocs srvs) $ \(userId, srvs') -> checkUserServers ("getSMPAgentClient " <> protocol <> " " <> tshow userId) srvs' - runAgentThreads c - | backgroundMode = run c "subscriber" $ subscriber c - | otherwise = do - restoreServersStats c - raceAny_ - [ run c "subscriber" $ subscriber c, - run c "runNtfSupervisor" $ runNtfSupervisor c, - run c "cleanupManager" $ cleanupManager c, - run c "logServersStats" $ logServersStats c - ] - `E.finally` saveServersStats c - run AgentClient {subQ, acThread} name a = + +startSMPAgentClient :: AgentClient -> Bool -> IO () +startSMPAgentClient c@AgentClient {acThread, generalQ, agentEnv} backgroundMode = do + void $ forkIO $ connWorkerLoop c generalQ + unless backgroundMode $ do + t <- runAgentThreads `forkFinally` const (disconnectAgentClient c) + atomically . writeTVar acThread . Just =<< mkWeakThreadId t + where + runAgentThreads = flip runReaderT agentEnv $ do + restoreServersStats c + raceAny_ + [ run "runNtfSupervisor" $ runNtfSupervisor c, + run "cleanupManager" $ cleanupManager c, + run "logServersStats" $ logServersStats c + ] + `E.finally` saveServersStats c + run name a = a `E.catchAny` \e -> whenM (isJust <$> readTVarIO acThread) $ do logError $ "Agent thread " <> name <> " crashed: " <> tshow e - atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ CRITICAL True $ show e) + liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR $ CRITICAL True $ show e) logServersStats :: AgentClient -> AM' () logServersStats c = do @@ -303,19 +309,19 @@ logServersStats c = do liftIO $ threadDelay' int saveServersStats :: AgentClient -> AM' () -saveServersStats c@AgentClient {subQ, smpServersStats, xftpServersStats, ntfServersStats} = do +saveServersStats c@AgentClient {smpServersStats, xftpServersStats, ntfServersStats} = do sss <- mapM (liftIO . getAgentSMPServerStats) =<< readTVarIO smpServersStats xss <- mapM (liftIO . getAgentXFTPServerStats) =<< readTVarIO xftpServersStats nss <- mapM (liftIO . getAgentNtfServerStats) =<< readTVarIO ntfServersStats let stats = AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss} tryAllErrors' (withStore' c (`updateServersStats` stats)) >>= \case - Left e -> atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) + Left e -> liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) Right () -> pure () restoreServersStats :: AgentClient -> AM' () restoreServersStats c@AgentClient {smpServersStats, xftpServersStats, ntfServersStats, srvStatsStartedAt} = do tryAllErrors' (withStore c getServersStats) >>= \case - Left e -> atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) + Left e -> liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) Right (startedAt, Nothing) -> atomically $ writeTVar srvStatsStartedAt startedAt Right (startedAt, Just AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss, ntfServersStats = OptionalMap nss}) -> do atomically $ writeTVar srvStatsStartedAt startedAt @@ -356,9 +362,14 @@ setUserService :: AgentClient -> UserId -> Bool -> AE () setUserService c = withAgentEnv c .: setUserService' c {-# INLINE setUserService #-} --- | Create SMP agent connection (NEW command) asynchronously, synchronous response is new connection id -createConnectionAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AE ConnId -createConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:. newConnAsync c userId aCorrId enableNtfs +-- | Create SMP agent connection without queue (to be used with createConnectionAsync). +prepareConnectionToCreate :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AE ConnId +prepareConnectionToCreate c userId enableNtfs = withAgentEnv c .: newConnNoQueues c userId enableNtfs +{-# INLINE prepareConnectionToCreate #-} + +-- | Enqueue NEW command for a prepared connection. +createConnectionAsync :: ConnectionModeI c => AgentClient -> ACorrId -> ConnId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AE () +createConnectionAsync c aCorrId connId enableNtfs = withAgentEnv c .:. newConnAsync c aCorrId connId enableNtfs {-# INLINE createConnectionAsync #-} -- | Create or update user's contact connection short link (LSET command) asynchronously, no synchronous response @@ -371,10 +382,9 @@ getConnShortLinkAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Con getConnShortLinkAsync c = withAgentEnv c .:: getConnShortLinkAsync' c {-# INLINE getConnShortLinkAsync #-} --- | Join SMP agent connection (JOIN command) asynchronously, synchronous response is new connection id. --- If connId is provided (for contact URIs), it updates the existing connection record created by getConnShortLinkAsync. -joinConnectionAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId -joinConnectionAsync c userId aCorrId connId_ enableNtfs = withAgentEnv c .:: joinConnAsync c userId aCorrId connId_ enableNtfs +-- | Enqueue JOIN command for a prepared connection. +joinConnectionAsync :: AgentClient -> ACorrId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE () +joinConnectionAsync c aCorrId updateConn connId enableNtfs = withAgentEnv c .:: joinConnAsync c aCorrId updateConn connId enableNtfs {-# INLINE joinConnectionAsync #-} -- | Allow connection to continue after CONF notification (LET command), no synchronous response @@ -382,9 +392,9 @@ allowConnectionAsync :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> Co allowConnectionAsync c = withAgentEnv c .:: allowConnectionAsync' c {-# INLINE allowConnectionAsync #-} --- | Accept contact after REQ notification (ACPT command) asynchronously, synchronous response is new connection id -acceptContactAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId -acceptContactAsync c userId aCorrId enableNtfs = withAgentEnv c .:: acceptContactAsync' c userId aCorrId enableNtfs +-- | Accept contact after REQ notification (ACPT command) asynchronously, for a prepared connection. +acceptContactAsync :: AgentClient -> ACorrId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE () +acceptContactAsync c aCorrId connId enableNtfs = withAgentEnv c .:: acceptContactAsync' c aCorrId connId enableNtfs {-# INLINE acceptContactAsync #-} -- | Acknowledge message (ACK command) asynchronously, no synchronous response @@ -820,8 +830,8 @@ deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueue lift $ saveServersStats c where delUser = - whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $ - writeTBQueue (subQ c) ("", "", AEvt SAENone $ DEL_USER userId) + whenM (withStore' c (`deleteUserWithoutConns` userId)) . liftIO $ + notifyEvent c ("", "", AEvt SAENone $ DEL_USER userId) setUserService' :: AgentClient -> UserId -> Bool -> AM () setUserService' c userId enable = do @@ -837,11 +847,10 @@ setUserService' c userId enable = do unless ok $ throwE $ CMD PROHIBITED "setUserService" when (changed && not enable) $ withStore' c (`deleteClientServices` userId) -newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId -newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do - connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys) +newConnAsync :: ConnectionModeI c => AgentClient -> ACorrId -> ConnId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM () +newConnAsync c corrId connId enableNtfs cMode pqInitKeys subMode = enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pqInitKeys subMode - pure connId +{-# INLINE newConnAsync #-} newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId newConnNoQueues c userId enableNtfs cMode pqSupport = do @@ -852,34 +861,21 @@ newConnNoQueues c userId enableNtfs cMode pqSupport = do -- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection, -- and join should retry, the same as 1-time invitation joins. -joinConnAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId -joinConnAsync c userId corrId connId_ enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do - when (isJust connId_) $ throwE $ CMD PROHIBITED "joinConnAsync: connId not allowed for invitation URI" - withInvLock c (strEncode cReqUri) "joinConnAsync" $ do +joinConnAsync :: AgentClient -> ACorrId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM () +joinConnAsync c corrId updateConn connId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do + when updateConn $ throwE $ CMD PROHIBITED "joinConnAsync: updateConn not allowed for invitation URI" + withInvLock c (strEncode cReqUri) "joinConnAsync" $ lift (compatibleInvitationUri cReqUri) >>= \case Just (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do - g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) - cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo - pure connId Nothing -> throwE $ AGENT A_VERSION -joinConnAsync c userId corrId connId_ enableNtfs cReqUri@(CRContactUri _) cInfo pqSup subMode = do +joinConnAsync c corrId updateConn connId enableNtfs cReqUri@(CRContactUri _) cInfo pqSup subMode = lift (compatibleContactUri cReqUri) >>= \case Just (_, Compatible connAgentVersion) -> do let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion Nothing - connId <- case connId_ of - Just cId -> do - -- update connection record created by getConnShortLinkAsync - withStore' c $ \db -> updateNewConnJoin db cId connAgentVersion pqSupport enableNtfs - pure cId - Nothing -> do - g <- asks random - let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - withStore c $ \db -> createNewConn db g cData SCMInvitation + when updateConn $ withStore' c $ \db -> updateNewConnJoin db connId connAgentVersion pqSupport enableNtfs enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo - pure connId Nothing -> throwE $ AGENT A_VERSION allowConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> AM () @@ -895,11 +891,11 @@ allowConnectionAsync' c corrId connId confId ownConnInfo = -- and also it can't be triggered by user concurrently several times in a row. It could be improved similarly to -- `acceptContact` by creating a new map for invitation locks and taking lock here, and removing `unacceptInvitation` -- while marking invitation as accepted inside "lock level transaction" after successful `joinConnAsync`. -acceptContactAsync' :: AgentClient -> UserId -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId -acceptContactAsync' c userId corrId enableNtfs invId ownConnInfo pqSupport subMode = do +acceptContactAsync' :: AgentClient -> ACorrId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM () +acceptContactAsync' c corrId connId enableNtfs invId ownConnInfo pqSupport subMode = do Invitation {connReq} <- withStore c $ \db -> getInvitation db "acceptContactAsync'" invId withStore' c $ \db -> acceptInvitation db invId ownConnInfo - joinConnAsync c userId corrId Nothing enableNtfs connReq ownConnInfo pqSupport subMode `catchAllErrors` \err -> do + joinConnAsync c corrId False connId enableNtfs connReq ownConnInfo pqSupport subMode `catchAllErrors` \err -> do withStore' c (`unacceptInvitation` invId) throwE err @@ -1324,7 +1320,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = getSndRatchet db connId v >>= \case Right r -> pure $ Right $ snd r Left e -> do - nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) + nonBlockingNotifyEvent c ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) runExceptT $ createRatchet_ db g maxSupported pqSupport e2eRcvParams pure (cData, sq, e2eSndParams, Nothing) _ -> do @@ -1418,7 +1414,7 @@ joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup su getRatchetX3dhKeys db connId >>= \case Right keys -> pure $ CR.mkRcvE2ERatchetParams (maxVersion e2eVR) keys Left e -> do - nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no rcv ratchet " <> show e)) + nonBlockingNotifyEvent c ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no rcv ratchet " <> show e)) let pqEnc = CR.initialPQEncryption False pqInitKeys (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eVR) pqEnc createRatchetX3dhKeys db connId pk1 pk2 pKem @@ -1430,7 +1426,7 @@ joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup su delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SMP.LinkId -> AM () delInvSL c connId srv lnkId = withStore' c (\db -> deleteInvShortLink db (protoServer srv) lnkId) `catchE` \e -> - liftIO $ nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "error deleting short link " <> show e)) + liftIO $ nonBlockingNotifyEvent c ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "error deleting short link " <> show e)) joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do @@ -1603,8 +1599,8 @@ subscribeConnections_ c conns = do notifyResultError rs = do let actual = M.size rs expected = length conns - when (actual /= expected) . atomically $ - writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected) + when (actual /= expected) . liftIO $ + notifyEvent c ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected) subscribeAllConnections' :: AgentClient -> Bool -> Maybe UserId -> AM () subscribeAllConnections' c onlyNeeded activeUserId_ = handleErr $ do @@ -1651,7 +1647,7 @@ subscribeAllConnections' c onlyNeeded activeUserId_ = handleErr $ do Just SSErrorQueueCount {expectedQueueCount = n, subscribedQueueCount = n'} | n > 0 && n' == 0 -> unassocQueues _ -> pure True Left e -> do - atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR e) + liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR e) if clientServiceError e then False <$ withStore' c (\db -> unassocUserServerRcvQueueSubs' db userId srv) else pure True @@ -1860,10 +1856,10 @@ getAsyncCmdWorker hasWork c connId server = data CommandCompletion = CCMoved | CCCompleted runCommandProcessing :: AgentClient -> ConnId -> Maybe SMPServer -> Worker -> AM () -runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do +runCommandProcessing c connId server_ Worker {doWork} = do ri <- asks $ messageRetryInterval . config -- different retry interval? forever $ do - atomically $ endAgentOperation c AOSndNetwork + endAgentOp c AOSndNetwork lift $ waitForWork doWork liftIO $ throwWhenInactive c atomically $ beginAgentOperation c AOSndNetwork @@ -1872,7 +1868,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do runProcessCmd ri cmd = do pending <- newTVarIO [] processCmd ri cmd pending - mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending + mapM_ (liftIO . notifyEvent c) . reverse =<< readTVarIO pending processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM () processCmd ri PendingCommand {cmdId, corrId, userId, command} pendingCmds = case command of AClientCommand cmd -> case cmd of @@ -2028,9 +2024,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command) cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId) notify :: forall e. AEntityI e => AEvent e -> AM () - notify cmd = - let t = (corrId, connId, AEvt (sAEntity @e) cmd) - in atomically $ ifM (isFullTBQueue subQ) (modifyTVar' pendingCmds (t :)) (writeTBQueue subQ t) + notify cmd = atomically $ modifyTVar' pendingCmds ((corrId, connId, AEvt (sAEntity @e) cmd) :) -- ^ ^ ^ async command processing / enqueueMessages :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption) @@ -2163,17 +2157,17 @@ submitPendingMsg c sq = do void $ getDeliveryWorker True c sq runSmpQueueMsgDelivery :: AgentClient -> SndQueue -> (Worker, TMVar ()) -> AM () -runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, queueMode} (Worker {doWork}, qLock) = do +runSmpQueueMsgDelivery c sq@SndQueue {userId, connId, server, queueMode} (Worker {doWork}, qLock) = do AgentConfig {messageRetryInterval = ri, messageTimeout, helloTimeout, quotaExceededTimeout} <- asks config forever $ do - atomically $ endAgentOperation c AOSndNetwork + endAgentOp c AOSndNetwork lift $ waitForWork doWork liftIO $ throwWhenInactive c liftIO $ throwWhenNoDelivery c sq atomically $ beginAgentOperation c AOSndNetwork withWork c doWork (\db -> getPendingQueueMsg db connId sq) $ \(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs, internalSndId, prevMsgHash, pendingMsgPrepData_}) -> do - atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in submitPendingMsg + endAgentOp c AOMsgDelivery -- this operation begins in submitPendingMsg let mId = unId msgId ri' = maybe id updateRetryInterval2 msgRetryState ri withRetryLock2 ri' qLock $ \riState loop -> do @@ -2331,7 +2325,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, delMsgKeep :: Bool -> InternalId -> AM () delMsgKeep keepForReceipt msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId keepForReceipt notify :: forall e. AEntityI e => AEvent e -> AM () - notify cmd = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) cmd) + notify cmd = liftIO $ notifyEvent c ("", connId, AEvt (sAEntity @e) cmd) notifyDel :: AEntityI e => InternalId -> AEvent e -> AM () notifyDel msgId cmd = notify cmd >> delMsg msgId connError msgId = notifyDel msgId . ERR . (`CONN` "") @@ -2343,17 +2337,22 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, retrySndOp :: AgentClient -> AM () -> AM () retrySndOp c loop = do -- end... is in a separate atomically because if begin... blocks, SUSPENDED won't be sent - atomically $ endAgentOperation c AOSndNetwork + endAgentOp c AOSndNetwork liftIO $ throwWhenInactive c atomically $ beginAgentOperation c AOSndNetwork loop +endAgentOp :: MonadIO m => AgentClient -> AgentOperation -> m () +endAgentOp c op = do + suspended <- atomically $ endAgentOperation c op + when suspended $ liftIO $ notifyEvent c ("", "", AEvt SAENone SUSPENDED) + -- | Like 'withConnLock', but writes the returned 'ATransmission' to 'subQ' -- after releasing the lock, preventing deadlock with agentSubscriber. withConnLockNotify :: AgentClient -> ConnId -> Text -> AM (Maybe ATransmission) -> AM () withConnLockNotify c connId name action = do t_ <- withConnLock c connId name action - forM_ t_ $ atomically . writeTBQueue (subQ c) + forM_ t_ $ liftIO . notifyEvent c ackMessage' :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AM () ackMessage' c connId msgId rcptInfo_ = withConnLockNotify c connId "ackMessage" $ do @@ -2570,7 +2569,7 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do unsubNtfConnIds connIds' = do ns <- asks ntfSupervisor atomically $ writeTBQueue (ntfSubQ ns) (NSCDeleteSub, connIds') - notify = atomically . writeTBQueue (subQ c) + notify = liftIO . notifyEvent c deleteConnQueues :: AgentClient -> NetworkRequestMode -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ())) deleteConnQueues c nm waitDelivery ntf rqs = do @@ -2604,7 +2603,7 @@ deleteConnQueues c nm waitDelivery ntf rqs = do -- attempts and successes are counted in deleteQueues function atomically $ incSMPServerStat c userId server connDeleted pure ((rq, Right ()), Just (Just e)) - notify = when ntf . atomically . writeTBQueue (subQ c) + notify = when ntf . liftIO . notifyEvent c connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty where @@ -2640,8 +2639,8 @@ deleteConnections_ getConnections ntf waitDelivery c nm connIds = do notifyResultError rs = do let actual = M.size rs expected = length connIds - when (actual /= expected) . atomically $ - writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected) + when (actual /= expected) . liftIO $ + notifyEvent c ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected) getConnectionServers' :: AgentClient -> ConnId -> AM ConnectionStats getConnectionServers' c connId = do @@ -2944,20 +2943,19 @@ suspendAgent c 0 = do where suspend opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = True} suspendAgent c@AgentClient {agentState = as} maxDelay = do - state <- - atomically $ do - writeTVar as ASSuspending - suspendOperation c AONtfNetwork $ pure () - suspendOperation c AORcvNetwork $ - suspendOperation c AOMsgDelivery $ - suspendSendingAndDatabase c - readTVar as + (state, suspended) <- atomically $ do + writeTVar as ASSuspending + void $ suspendOperation c AONtfNetwork $ pure False + suspended <- suspendOperation c AORcvNetwork $ + suspendOperation c AOMsgDelivery $ + suspendSendingAndDatabase c + (,suspended) <$> readTVar as + when suspended $ notifyEvent c ("", "", AEvt SAENone SUSPENDED) when (state == ASSuspending) . void . forkIO $ do threadDelay maxDelay - -- liftIO $ putStrLn "suspendAgent after timeout" - atomically . whenSuspending c $ do - -- unsafeIOToSTM $ putStrLn $ "in timeout: suspendSendingAndDatabase" + suspended' <- atomically . whenSuspendingB c $ suspendSendingAndDatabase c + when suspended' $ notifyEvent c ("", "", AEvt SAENone SUSPENDED) execAgentStoreSQL :: AgentClient -> Text -> AE [Text] execAgentStoreSQL c sql = withAgentEnv c $ withStore' c (`execSQL` sql) @@ -2982,17 +2980,17 @@ getNextSMPServer :: AgentClient -> UserId -> [SMPServer] -> AM SMPServerWithAuth getNextSMPServer c userId = getNextServer c userId storageSrvs {-# INLINE getNextSMPServer #-} -subscriber :: AgentClient -> AM' () -subscriber c@AgentClient {msgQ, subQ} = run $ forever $ do - t <- atomically $ readTBQueue msgQ +subscriber :: AgentClient -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> AM' () +subscriber c t = run $ agentOperationBracket c AORcvNetwork waitUntilActive $ processSMPTransmissions c t where - run a = a `catchOwn` \e -> notify $ CRITICAL True $ "Agent subscriber stopped: " <> show e - notify err = atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR err) + run a = a `catchOwn` \e -> notify $ CRITICAL True $ "subscriber error: " <> show e + notify err = liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR err) + cleanupManager :: AgentClient -> AM' () -cleanupManager c@AgentClient {subQ} = do +cleanupManager c = do AgentConfig {initialCleanupDelay, cleanupInterval = int, storedMsgDataTTL = ttl, cleanupBatchSize = limit} <- asks config liftIO $ threadDelay' initialCleanupDelay @@ -3060,7 +3058,7 @@ cleanupManager c@AgentClient {subQ} = do rcvFilesTTL <- asks $ rcvFilesTTL . config withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL) notify :: forall e. AEntityI e => AEntityId -> AEvent e -> AM () - notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd) + notify entId cmd = liftIO $ notifyEvent c ("", entId, AEvt (sAEntity @e) cmd) data ACKd = ACKd | ACKPending @@ -3068,7 +3066,7 @@ data ACKd = ACKd | ACKPending -- It cannot be finally, as sometimes it needs to be ACK+DEL, -- and sometimes ACK has to be sent from the consumer. processSMPTransmissions :: AgentClient -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> AM' () -processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandleParams {thAuth, sessionId = sessId}, ts) = do +processSMPTransmissions c (tSess@(userId, srv, _), THandleParams {thAuth, sessionId = sessId}, ts) = do upConnIds <- newTVarIO [] serviceRQs <- newTVarIO ([] :: [RcvQueue]) forM_ ts $ \(entId, t) -> case t of @@ -3141,14 +3139,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar (atomically $ putTMVar (clientNoticesLock c) ()) (processClientNotices c tSess [(rcvQueueSub rq, notice_)]) notify' :: forall e m. (AEntityI e, MonadIO m) => ConnId -> AEvent e -> m () - notify' connId msg = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) msg) + notify' connId msg = liftIO $ notifyEvent c ("", connId, AEvt (sAEntity @e) msg) notifyErr :: ConnId -> SMPClientError -> AM' () notifyErr connId = notify' connId . ERR . protocolClientError SMP (B.unpack $ strEncode srv) runProcessSMP :: RcvQueue -> Connection c -> ConnData -> BrokerMsg -> AM () runProcessSMP rq conn cData msg = do pending <- newTVarIO [] processSMP rq conn cData msg pending - mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending + mapM_ (liftIO . notifyEvent c) . reverse =<< readTVarIO pending processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> TVar [ATransmission] -> AM () processSMP rq@RcvQueue {rcvId = rId, queueMode, e2ePrivKey, e2eDhSecret, status, smpClientVersion = agreedClientVerion} @@ -3355,9 +3353,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar notify :: forall e m. (AEntityI e, MonadIO m) => AEvent e -> m () notify = notify_ connId notify_ :: forall e m. (AEntityI e, MonadIO m) => ConnId -> AEvent e -> m () - notify_ connId' msg = - let t = ("", connId', AEvt (sAEntity @e) msg) - in atomically $ ifM (isFullTBQueue subQ) (modifyTVar' pendingMsgs (t :)) (writeTBQueue subQ t) + notify_ connId' msg = atomically $ modifyTVar' pendingMsgs (("", connId', AEvt (sAEntity @e) msg) :) prohibited :: Text -> AM () prohibited s = do diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index d33794006b..2715a9c86c 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -157,6 +157,7 @@ module Simplex.Messaging.Agent.Client suspendOperation, notifySuspended, whenSuspending, + whenSuspendingB, withStore, withStore', withStoreBatch, @@ -165,6 +166,9 @@ module Simplex.Messaging.Agent.Client storeError, notifySub, notifySub', + notifyEvent, + nonBlockingNotifyEvent, + connWorkerLoop, userServers, pickServer, getNextServer, @@ -334,11 +338,21 @@ type NtfTransportSession = TransportSession NtfResponse type XFTPTransportSession = TransportSession FileResponse +data EventWorker = EventWorker + { eventQ :: TBQueue ATransmission, + workerThreadId :: Weak ThreadId + } + +type EventWorkerVar = SessionVar EventWorker + data AgentClient = AgentClient { acThread :: TVar (Maybe (Weak ThreadId)), active :: TVar Bool, - subQ :: TBQueue ATransmission, - msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg), + processEvent :: ATransmission -> IO (), + generalQ :: TBQueue ATransmission, + connWorkers :: TMap ConnId EventWorkerVar, + connWorkerSeq :: TVar Int, + processServerMsg :: AgentClient -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO (), smpServers :: TMap UserId (UserServers 'PSMP), smpClients :: TMap SMPTransportSession SMPClientVar, useClientServices :: TMap UserId Bool, @@ -419,7 +433,8 @@ getAgentWorker' toW fromW name hasWork c@AgentClient {agentEnv} key ws work = do t <- liftIO getSystemTime let maxRestarts = maxWorkerRestartsPerMin $ config agentEnv -- worker may terminate because it was deleted from the map (getWorker returns Nothing), then it won't restart - restart <- atomically $ getWorker >>= maybe (pure False) (shouldRestart e_ (toW w) t maxRestarts) + (restart, notify_) <- atomically $ getWorker >>= maybe (pure (False, Nothing)) (shouldRestart e_ (toW w) t maxRestarts) + forM_ notify_ $ liftIO . notifyEvent c when restart runWork shouldRestart e_ Worker {workerId = wId, doWork, action, restarts} t maxRestarts w' | wId == workerId (toW w') = do @@ -427,24 +442,21 @@ getAgentWorker' toW fromW name hasWork c@AgentClient {agentEnv} key ws work = do isActive <- readTVar $ active c checkRestarts isActive $ updateRestartCount t rc | otherwise = - pure False -- there is a new worker in the map, no action + pure (False, Nothing) -- there is a new worker in the map, no action where checkRestarts isActive rc | isActive && restartCount rc < maxRestarts = do writeTVar restarts rc hasWorkToDo' doWork void $ tryPutTMVar action Nothing - notifyErr INTERNAL - pure True + pure (True, Just $ notifyMsg rc INTERNAL) | otherwise = do TM.delete key ws - when isActive $ notifyErr $ CRITICAL True - pure False - where - notifyErr err = do - let e = either ((", error: " <>) . show) (\_ -> ", no error") e_ - msg = "Worker " <> name <> " for " <> show key <> " terminated " <> show (restartCount rc) <> " times" <> e - writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err msg) + pure (False, if isActive then Just (notifyMsg rc $ CRITICAL True) else Nothing) + notifyMsg rc err = + let e = either ((", error: " <>) . show) (\_ -> ", no error") e_ + msg = "Worker " <> name <> " for " <> show key <> " terminated " <> show (restartCount rc) <> " times" <> e + in ("", "", AEvt SAEConn $ ERR $ err msg) newWorker :: AgentClient -> STM Worker newWorker c = do @@ -505,15 +517,16 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther deriving (Eq, Show) -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's. -newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> Env -> IO AgentClient -newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do +newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> (ATransmission -> IO ()) -> (AgentClient -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO ()) -> Env -> IO AgentClient +newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices, presetDomains, presetServers} currentTs notices processEvent processServerMsg agentEnv = do let cfg = config agentEnv qSize = tbqSize cfg proxySessTs <- newTVarIO =<< getCurrentTime acThread <- newTVarIO Nothing active <- newTVarIO True - subQ <- newTBQueueIO qSize - msgQ <- newTBQueueIO qSize + generalQ <- newTBQueueIO qSize + connWorkers <- TM.emptyIO + connWorkerSeq <- newTVarIO 0 smpServers <- newTVarIO $ M.map mkUserServers smp smpClients <- TM.emptyIO useClientServices <- newTVarIO useServices @@ -552,8 +565,11 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices AgentClient { acThread, active, - subQ, - msgQ, + processEvent, + generalQ, + connWorkers, + connWorkerSeq, + processServerMsg, smpServers, smpClients, useClientServices, @@ -733,7 +749,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient -smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs, presetDomains} nm tSess@(userId, srv, _) prs v = +smpConnectClient c@AgentClient {processServerMsg, smpClients, proxySessTs, presetDomains} nm tSess@(userId, srv, _) prs v = newProtocolClient c tSess smpClients connectClient v `catchAllErrors` \e -> lift (resubscribeSMPSession c tSess) >> throwE e where @@ -746,7 +762,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs, presetDomains} nm env <- ask smp <- liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do ts <- readTVarIO proxySessTs - ExceptT $ getProtocolClient g nm tSess cfg' presetDomains (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs + ExceptT $ getProtocolClient g nm tSess cfg' presetDomains (Just $ processServerMsg c) ts $ smpClientDisconnected c tSess env v' prs atomically $ SS.setSessionId tSess (sessionId $ thParams smp) $ currentSubs c updateClientService service smp pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs} @@ -835,7 +851,7 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do handleNotify = E.handleAny $ notifySub' c "" . ERR . INTERNAL . show notifySub' :: forall e m. (AEntityI e, MonadIO m) => AgentClient -> ConnId -> AEvent e -> m () -notifySub' c connId cmd = liftIO $ nonBlockingWriteTBQueue (subQ c) (B.empty, connId, AEvt (sAEntity @e) cmd) +notifySub' c connId cmd = liftIO $ notifyEvent c (B.empty, connId, AEvt (sAEntity @e) cmd) {-# INLINE notifySub' #-} notifySub :: MonadIO m => AgentClient -> AEvent 'AENone -> m () @@ -863,7 +879,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, pr clientDisconnected :: NtfClientVar -> NtfClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess ntfClients - atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client) + notifyEvent c ("", "", AEvt SAENone $ hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient @@ -887,7 +903,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess xftpClients - atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client) + notifyEvent c ("", "", AEvt SAENone $ hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv waitForProtocolClient :: @@ -926,7 +942,7 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v = Right client -> do logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")" atomically $ putTMVar (sessionVar v) (Right client) - liftIO $ nonBlockingWriteTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client) + liftIO $ notifyEvent c ("", "", AEvt SAENone $ hostEvent CONNECT client) pure client Left e -> do ei <- asks $ persistErrorInterval . config @@ -1054,6 +1070,36 @@ withConnLock' _ "" _ = id withConnLock' AgentClient {connLocks} connId name = withLockMap connLocks connId name {-# INLINE withConnLock' #-} +notifyEvent :: AgentClient -> ATransmission -> IO () +notifyEvent = notifyEvent_ $ atomically .: writeTBQueue + +nonBlockingNotifyEvent :: AgentClient -> ATransmission -> IO () +nonBlockingNotifyEvent = notifyEvent_ nonBlockingWriteTBQueue + +notifyEvent_ :: (TBQueue ATransmission -> ATransmission -> IO ()) -> AgentClient -> ATransmission -> IO () +notifyEvent_ write c t@(_, connId, _) + | B.null connId = write (generalQ c) t + | otherwise = do + q <- getOrCreateConnWorker c connId + write q t + +getOrCreateConnWorker :: AgentClient -> ConnId -> IO (TBQueue ATransmission) +getOrCreateConnWorker c@AgentClient {connWorkers, connWorkerSeq} connId = do + ts <- getCurrentTime + atomically (getSessVar connWorkerSeq connId connWorkers ts) >>= \case + Left v -> do + q <- newTBQueueIO 64 + tId <- mkWeakThreadId =<< forkIO (connWorkerLoop c q) + atomically $ putTMVar (sessionVar v) EventWorker {eventQ = q, workerThreadId = tId} + pure q + Right v -> eventQ <$> atomically (readTMVar $ sessionVar v) + +connWorkerLoop :: AgentClient -> TBQueue ATransmission -> IO () +connWorkerLoop AgentClient {processEvent} q = forever $ do + t <- atomically $ readTBQueue q + processEvent t `E.catchAny` \e -> + logError $ "connWorkerLoop error: " <> tshow e + withInvLock :: AgentClient -> ByteString -> Text -> AM a -> AM a withInvLock c key name = ExceptT . withInvLock' c key name . runExceptT {-# INLINE withInvLock #-} @@ -1740,7 +1786,7 @@ resubscribeClientService c tSess@(userId, srv, _) serviceSub = r <$ withStore' c (\db -> removeRcvServiceAssocs db userId srv) _ -> pure r Left e -> do - atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR e) + liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR e) when (clientServiceError e) $ do atomically $ SS.deleteServiceSub tSess $ currentSubs c unassocSubscribeQueues @@ -2266,7 +2312,7 @@ withWork_ c doWork getWork action = noWork = liftIO $ noWorkToDo doWork notifyErr err e = do logError $ "withWork_ error: " <> tshow e - atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e) + liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR $ err $ show e) withWorkItems :: (AnyStoreError e', MonadIO m) => AgentClient -> TMVar () -> ExceptT e m (Either e' [Either e' a]) -> (NonEmpty a -> ExceptT e m ()) -> ExceptT e m () withWorkItems c doWork getWork action = do @@ -2291,7 +2337,7 @@ withWorkItems c doWork getWork action = do noWork = liftIO $ noWorkToDo doWork notifyErr err e = do logError $ "withWorkItems error: " <> tshow e - atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e) + liftIO $ notifyEvent c ("", "", AEvt SAEConn $ ERR $ err $ show e) noWorkToDo :: TMVar () -> IO () noWorkToDo = void . atomically . tryTakeTMVar @@ -2305,9 +2351,9 @@ hasWorkToDo' :: TMVar () -> STM () hasWorkToDo' = void . (`tryPutTMVar` ()) {-# INLINE hasWorkToDo' #-} -endAgentOperation :: AgentClient -> AgentOperation -> STM () +endAgentOperation :: AgentClient -> AgentOperation -> STM Bool endAgentOperation c op = endOperation c op $ case op of - AONtfNetwork -> pure () + AONtfNetwork -> pure False AORcvNetwork -> suspendOperation c AOMsgDelivery $ suspendSendingAndDatabase c @@ -2319,36 +2365,37 @@ endAgentOperation c op = endOperation c op $ case op of AODatabase -> notifySuspended c -suspendSendingAndDatabase :: AgentClient -> STM () +suspendSendingAndDatabase :: AgentClient -> STM Bool suspendSendingAndDatabase c = suspendOperation c AOSndNetwork $ suspendOperation c AODatabase $ notifySuspended c -suspendOperation :: AgentClient -> AgentOperation -> STM () -> STM () +suspendOperation :: AgentClient -> AgentOperation -> STM Bool -> STM Bool suspendOperation c op endedAction = do n <- stateTVar (agentOpSel op c) $ \s -> (opsInProgress s, s {opSuspended = True}) - -- unsafeIOToSTM $ putStrLn $ "suspendOperation_ " <> show op <> " " <> show n - when (n == 0) $ whenSuspending c endedAction + if n == 0 then whenSuspendingB c endedAction else pure False -notifySuspended :: AgentClient -> STM () +notifySuspended :: AgentClient -> STM Bool notifySuspended c = do - -- unsafeIOToSTM $ putStrLn "notifySuspended" - writeTBQueue (subQ c) ("", "", AEvt SAENone SUSPENDED) writeTVar (agentState c) ASSuspended + pure True -endOperation :: AgentClient -> AgentOperation -> STM () -> STM () +endOperation :: AgentClient -> AgentOperation -> STM Bool -> STM Bool endOperation c op endedAction = do (suspended, n) <- stateTVar (agentOpSel op c) $ \s -> let n = max 0 (opsInProgress s - 1) in ((opSuspended s, n), s {opsInProgress = n}) - -- unsafeIOToSTM $ putStrLn $ "endOperation: " <> show op <> " " <> show suspended <> " " <> show n - when (suspended && n == 0) $ whenSuspending c endedAction + if suspended && n == 0 then whenSuspendingB c endedAction else pure False whenSuspending :: AgentClient -> STM () -> STM () whenSuspending c = whenM ((== ASSuspending) <$> readTVar (agentState c)) {-# INLINE whenSuspending #-} +whenSuspendingB :: AgentClient -> STM Bool -> STM Bool +whenSuspendingB c action = + ifM ((== ASSuspending) <$> readTVar (agentState c)) action (pure False) + beginAgentOperation :: AgentClient -> AgentOperation -> STM () beginAgentOperation c op = do let opVar = agentOpSel op c @@ -2362,7 +2409,9 @@ agentOperationBracket :: MonadUnliftIO m => AgentClient -> AgentOperation -> (Ag agentOperationBracket c op check action = E.bracket (liftIO (check c) >> atomically (beginAgentOperation c op)) - (\_ -> atomically $ endAgentOperation c op) + (\_ -> do + suspended <- atomically $ endAgentOperation c op + when suspended $ liftIO $ notifyEvent c ("", "", AEvt SAENone SUSPENDED)) (const action) waitUntilForeground :: AgentClient -> IO () @@ -2835,9 +2884,9 @@ data ClientInfo deriving (Show) getAgentQueuesInfo :: AgentClient -> IO AgentQueuesInfo -getAgentQueuesInfo AgentClient {msgQ, subQ, smpClients} = do - msgQInfo <- atomically $ getTBQueueInfo msgQ - subQInfo <- atomically $ getTBQueueInfo subQ +getAgentQueuesInfo AgentClient {smpClients} = do + let msgQInfo = TBQueueInfo {qLength = 0, qFull = False} + subQInfo = TBQueueInfo {qLength = 0, qFull = False} smpClientsMap <- readTVarIO smpClients let smpClientsMap' = M.mapKeys (decodeLatin1 . strEncode) smpClientsMap smpClientsQueues <- mapM getClientQueuesInfo smpClientsMap' diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 06c9b4ca44..b66285acd2 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -502,9 +502,9 @@ workerInternalError c connId internalErrStr = do -- TODO change error notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m () -notifyInternalError AgentClient {subQ} connId internalErrStr = do +notifyInternalError c connId internalErrStr = do logError $ T.pack internalErrStr - liftIO $ nonBlockingWriteTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr) + liftIO $ notifyEvent c ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr) notifyInternalError' :: MonadIO m => AgentClient -> String -> m () notifyInternalError' c = notifyInternalError c "" diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 67b31de186..6f0a5655c7 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -562,10 +562,10 @@ type SMPTransportSession = TransportSession BrokerMsg -- | Connects to 'ProtocolServer' using passed client configuration -- and queue for messages and notifications. -- --- A single queue can be used for multiple 'SMPClient' instances, +-- A single callback can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) -getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do +getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (ServerTransmissionBatch v err msg -> IO ()) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) +getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains processServerMsg proxySessTs disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost) @@ -583,6 +583,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS sentCommands <- TM.emptyIO sndQ <- newTBQueueIO qSize rcvQ <- newTBQueueIO qSize + msgQ <- mapM (const $ newTBQueueIO qSize) processServerMsg return PClient { connected, @@ -641,7 +642,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS atomically $ do writeTVar (connected c) True putTMVar cVar $ Right c' - raceAny_ ([send c' th, process c', receive c' th] <> [monitor c' | smpPingInterval > 0]) + raceAny_ ([send c' th, process c', receive c' th] <> readMsgs c' <> [monitor c' | smpPingInterval > 0]) `E.finally` disconnected c' send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () @@ -680,13 +681,18 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS recoverWindow = 15 * 60 -- seconds maxCnt = smpPingCount networkConfig + readMsgs :: ProtocolClient v err msg -> [IO ()] + readMsgs c = case (processServerMsg, msgQ $ client_ c) of + (Just cb, Just q) -> [forever $ atomically (readTBQueue q) >>= cb] + _ -> [] + process :: ProtocolClient v err msg -> IO () process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= processMsgs c processMsgs :: ProtocolClient v err msg -> NonEmpty (Transmission (Either err msg)) -> IO () processMsgs c ts = do ts' <- catMaybes <$> mapM (processMsg c) (L.toList ts) - forM_ msgQ $ \q -> + forM_ (msgQ $ client_ c) $ \q -> mapM_ (atomically . writeTBQueue q . serverTransmission c) (L.nonEmpty ts') processMsg :: ProtocolClient v err msg -> Transmission (Either err msg) -> IO (Maybe (EntityId, ServerTransmission err msg)) @@ -714,7 +720,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS Just e -> Left $ PCEProtocolError e _ -> Right r sendMsg :: ServerTransmission err msg -> IO (Maybe (EntityId, ServerTransmission err msg)) - sendMsg t = case msgQ of + sendMsg t = case processServerMsg of Just _ -> pure $ Just (entId, t) Nothing -> Nothing <$ case clientResp of diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 76b2a7cf93..f035a800f4 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -138,7 +138,7 @@ data SMPClientAgent p = SMPClientAgent dbService :: Maybe DBService, active :: TVar Bool, startedAt :: UTCTime, - msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg), + processMsg :: SMPClientAgent p -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO (), agentQ :: TBQueue SMPClientAgentEvent, randomDrg :: TVar ChaChaDRG, smpClients :: TMap SMPServer SMPClientVar, @@ -158,11 +158,10 @@ data SMPClientAgent p = SMPClientAgent type OwnServer = Bool -newSMPClientAgent :: SParty p -> SMPClientAgentConfig -> Maybe DBService -> TVar ChaChaDRG -> IO (SMPClientAgent p) -newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} dbService randomDrg = do +newSMPClientAgent :: SParty p -> SMPClientAgentConfig -> (SMPClientAgent p -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO ()) -> Maybe DBService -> TVar ChaChaDRG -> IO (SMPClientAgent p) +newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {agentQSize} processMsg dbService randomDrg = do active <- newTVarIO True startedAt <- getCurrentTime - msgQ <- newTBQueueIO msgQSize agentQ <- newTBQueueIO agentQSize smpClients <- TM.emptyIO smpSessions <- TM.emptyIO @@ -179,7 +178,7 @@ newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize dbService, active, startedAt, - msgQ, + processMsg, agentQ, randomDrg, smpClients, @@ -257,7 +256,7 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} = -- | Run an SMP client for SMPClientVar connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient) -connectClient ca@SMPClientAgent {agentCfg, dbService, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v = case dbService of +connectClient ca@SMPClientAgent {agentCfg, dbService, smpClients, smpSessions, processMsg, randomDrg, startedAt} srv v = case dbService of Just dbs -> runExceptT $ do creds <- ExceptT $ getCredentials dbs srv smp <- ExceptT $ getClient cfg {serviceCredentials = Just creds} @@ -267,7 +266,7 @@ connectClient ca@SMPClientAgent {agentCfg, dbService, smpClients, smpSessions, m Nothing -> getClient cfg where cfg = smpCfg agentCfg - getClient cfg' = getProtocolClient randomDrg NRMBackground (1, srv, Nothing) cfg' [] (Just msgQ) startedAt clientDisconnected + getClient cfg' = getProtocolClient randomDrg NRMBackground (1, srv, Nothing) cfg' [] (Just $ processMsg ca) startedAt clientDisconnected clientDisconnected :: SMPClient -> IO () clientDisconnected smp = do diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 02429e9108..e4d20acff5 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -54,7 +54,7 @@ import GHC.IORef (atomicSwapIORef) import GHC.Stats (getRTSStats) import Network.Socket (ServiceName, Socket, socketToHandle) import Numeric.Natural (Natural) -import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..)) +import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch) import Simplex.Messaging.Client.Agent import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -68,7 +68,7 @@ import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore, TokenNtfMessag import Simplex.Messaging.Notifications.Server.Store.Postgres import Simplex.Messaging.Notifications.Server.Store.Types import Simplex.Messaging.Notifications.Transport -import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), NotifierId, Party (..), ProtocolServer (host), SMPServer, ServiceSub (..), SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGetServer, tPut) +import Simplex.Messaging.Protocol (BrokerMsg, EntityId (..), ErrorType (..), NotifierId, Party (..), ProtocolServer (host), SMPServer, ServiceSub (..), SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGetServer, tPut) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Control (CPClientRole (..)) @@ -77,7 +77,7 @@ import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), import Simplex.Messaging.Session import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) -import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams) +import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), SMPVersion, THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer) import Simplex.Messaging.Util @@ -101,7 +101,7 @@ runNtfServer cfg = do runNtfServerBlocking started cfg runNtfServerBlocking :: TMVar Bool -> NtfServerConfig -> IO () -runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg +runNtfServerBlocking started cfg = runReaderT (ntfServer cfg started) =<< newNtfServerEnv cfg receiveSMPMessage type M a = ReaderT NtfEnv IO a @@ -525,92 +525,83 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm void $ updateSubStatus st srvId' nId NSPending subscribeQueuesNtfs ca smpServer' [sub] +receiveSMPMessage :: NtfPostgresStore -> NtfPushServer -> NtfServerStats -> SMPClientAgent 'NotifierService -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO () +receiveSMPMessage st ps stats ca ((_, srv@(SMPServer (h :| _) _ _), _), THandleParams {sessionId}, ts) = + forM_ ts $ \(ntfId, t) -> case t of + STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen + STResponse {} -> pure () -- it was already reported as timeout error + STEvent msgOrErr -> do + let smpQueue = SMPQueueNtf srv ntfId + case msgOrErr of + Right (SMP.NMSG nmsgNonce encNMsgMeta) -> do + ntfTs <- getSystemTime + updatePeriodStats (activeSubs stats) ntfId + let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} + srvHost = safeDecodeUtf8 $ strEncode h + isOwn = isOwnServer ca srv + addTokenLastNtf st newNtf >>= \case + Right (tkn, lastNtfs) -> do + pushNotification st stats ps (Just srvHost) isOwn tkn $ PNMessage lastNtfs + incNtfStat_ stats ntfReceived + when isOwn $ incServerStat srvHost (ntfReceivedOwn stats) + Left AUTH -> do + incNtfStat_ stats ntfReceivedAuth + when isOwn $ incServerStat srvHost (ntfReceivedAuthOwn stats) + Left _ -> pure () + Right SMP.END -> + whenM (atomically $ activeClientSession' ca sessionId srv) $ + void $ updateSrvSubStatus st smpQueue NSEnd + Right SMP.DELD -> + void $ updateSrvSubStatus st smpQueue NSDeleted + Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e + Right _ -> logError "SMP server unexpected response" + Left e -> logError $ "SMP client error: " <> tshow e + ntfSubscriber :: NtfSubscriber -> M () -ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = - race_ receiveSMP receiveAgent +ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {agentQ}} = do + st <- asks store + batchSize <- asks $ subsBatchSize . config + liftIO $ forever $ + atomically (readTBQueue agentQ) >>= \case + CAConnected srv serviceId -> do + let asService = if isJust serviceId then "as service " else "" + logInfo $ "SMP server reconnected " <> asService <> showServer' srv + CADisconnected srv nIds -> do + updated <- batchUpdateSrvSubStatus st srv Nothing nIds NSInactive + logSubStatus srv "disconnected" (L.length nIds) updated + CASubscribed srv serviceId nIds -> do + updated <- batchUpdateSrvSubStatus st srv serviceId nIds NSActive + let asService = if isJust serviceId then " as service" else "" + logSubStatus srv ("subscribed" <> asService) (L.length nIds) updated + CASubError srv errs -> do + forM_ (L.nonEmpty $ mapMaybe (\(nId, err) -> (nId,) <$> queueSubErrorStatus err) $ L.toList errs) $ \subStatuses -> do + updated <- batchUpdateSrvSubErrors st srv subStatuses + logSubErrors srv subStatuses updated + -- TODO [certs rcv] resubscribe queues with statuses NSErr and NSService + CAServiceDisconnected srv serviceSub -> + logNote $ "SMP server service disconnected " <> showService srv serviceSub + CAServiceSubscribed srv serviceSub@(ServiceSub _ n idsHash) (ServiceSub _ n' idsHash') + | n /= n' -> logWarn $ msg <> ", confirmed subs: " <> tshow n' + | idsHash /= idsHash' -> logWarn $ msg <> ", different IDs hash" + | otherwise -> logNote msg + where + msg = "SMP server service subscribed " <> showService srv serviceSub + CAServiceSubError srv serviceSub e -> + -- Errors that require re-subscribing queues directly are reported as CAServiceUnavailable. + -- See smpSubscribeService in Simplex.Messaging.Client.Agent + logError $ "SMP server service subscription error " <> showService srv serviceSub <> ": " <> tshow e + CAServiceUnavailable srv serviceSub -> do + logError $ "SMP server service unavailable: " <> showService srv serviceSub + removeServiceAndAssociations st srv >>= \case + Right (srvId, updated) -> do + logSubStatus srv "removed service association" updated updated + void $ subscribeSrvSubs ca st batchSize (srv, srvId, Nothing) + Left e -> logError $ "SMP server update and resubscription error " <> tshow e where - receiveSMP = do - st <- asks store - ps <- asks pushServer - stats <- asks serverStats - forever $ do - ((_, srv@(SMPServer (h :| _) _ _), _), THandleParams {sessionId}, ts) <- atomically $ readTBQueue msgQ - forM_ ts $ \(ntfId, t) -> case t of - STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen - STResponse {} -> pure () -- it was already reported as timeout error - STEvent msgOrErr -> do - let smpQueue = SMPQueueNtf srv ntfId - case msgOrErr of - Right (SMP.NMSG nmsgNonce encNMsgMeta) -> do - ntfTs <- liftIO getSystemTime - liftIO $ updatePeriodStats (activeSubs stats) ntfId - let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta} - srvHost = safeDecodeUtf8 $ strEncode h - isOwn = isOwnServer ca srv - liftIO (addTokenLastNtf st newNtf) >>= \case - Right (tkn, lastNtfs) -> do - pushNotification ps (Just srvHost) isOwn tkn $ PNMessage lastNtfs - liftIO $ incNtfStat_ stats ntfReceived - when isOwn $ liftIO $ incServerStat srvHost (ntfReceivedOwn stats) - Left AUTH -> liftIO $ do - incNtfStat_ stats ntfReceivedAuth - when isOwn $ incServerStat srvHost (ntfReceivedAuthOwn stats) - Left _ -> pure () - Right SMP.END -> - whenM (atomically $ activeClientSession' ca sessionId srv) $ - void $ liftIO $ updateSrvSubStatus st smpQueue NSEnd - Right SMP.DELD -> - void $ liftIO $ updateSrvSubStatus st smpQueue NSDeleted - Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e - Right _ -> logError "SMP server unexpected response" - Left e -> logError $ "SMP client error: " <> tshow e - - receiveAgent = do - st <- asks store - batchSize <- asks $ subsBatchSize . config - liftIO $ forever $ - atomically (readTBQueue agentQ) >>= \case - CAConnected srv serviceId -> do - let asService = if isJust serviceId then "as service " else "" - logInfo $ "SMP server reconnected " <> asService <> showServer' srv - CADisconnected srv nIds -> do - updated <- batchUpdateSrvSubStatus st srv Nothing nIds NSInactive - logSubStatus srv "disconnected" (L.length nIds) updated - CASubscribed srv serviceId nIds -> do - updated <- batchUpdateSrvSubStatus st srv serviceId nIds NSActive - let asService = if isJust serviceId then " as service" else "" - logSubStatus srv ("subscribed" <> asService) (L.length nIds) updated - CASubError srv errs -> do - forM_ (L.nonEmpty $ mapMaybe (\(nId, err) -> (nId,) <$> queueSubErrorStatus err) $ L.toList errs) $ \subStatuses -> do - updated <- batchUpdateSrvSubErrors st srv subStatuses - logSubErrors srv subStatuses updated - -- TODO [certs rcv] resubscribe queues with statuses NSErr and NSService - CAServiceDisconnected srv serviceSub -> - logNote $ "SMP server service disconnected " <> showService srv serviceSub - CAServiceSubscribed srv serviceSub@(ServiceSub _ n idsHash) (ServiceSub _ n' idsHash') - | n /= n' -> logWarn $ msg <> ", confirmed subs: " <> tshow n' - | idsHash /= idsHash' -> logWarn $ msg <> ", different IDs hash" - | otherwise -> logNote msg - where - msg = "SMP server service subscribed " <> showService srv serviceSub - CAServiceSubError srv serviceSub e -> - -- Errors that require re-subscribing queues directly are reported as CAServiceUnavailable. - -- See smpSubscribeService in Simplex.Messaging.Client.Agent - logError $ "SMP server service subscription error " <> showService srv serviceSub <> ": " <> tshow e - CAServiceUnavailable srv serviceSub -> do - logError $ "SMP server service unavailable: " <> showService srv serviceSub - removeServiceAndAssociations st srv >>= \case - Right (srvId, updated) -> do - logSubStatus srv "removed service association" updated updated - void $ subscribeSrvSubs ca st batchSize (srv, srvId, Nothing) - Left e -> logError $ "SMP server update and resubscription error " <> tshow e - where - showService srv (ServiceSub serviceId n _) = showServer' srv <> ", service ID " <> decodeLatin1 (strEncode serviceId) <> ", " <> tshow n <> " subs" - + showService srv (ServiceSub serviceId n _) = showServer' srv <> ", service ID " <> decodeLatin1 (strEncode serviceId) <> ", " <> tshow n <> " subs" logSubErrors :: SMPServer -> NonEmpty (SMP.NotifierId, NtfSubStatus) -> Int -> IO () - logSubErrors srv subs updated = forM_ (L.group $ L.sort $ L.map snd subs) $ \ss -> do + logSubErrors srv subs updated = forM_ (L.group $ L.sort $ L.map snd subs) $ \ss -> logError $ "SMP server subscription errors " <> showServer' srv <> ": " <> tshow (L.head ss) <> " (" <> tshow (length ss) <> " errors, " <> tshow updated <> " subs updated)" - queueSubErrorStatus :: SMPClientError -> Maybe NtfSubStatus queueSubErrorStatus = \case PCEProtocolError AUTH -> Just NSAuth @@ -639,55 +630,53 @@ logSubStatus srv event n updated = showServer' :: SMPServer -> Text showServer' = decodeLatin1 . strEncode . host -pushNotification :: NtfPushServer -> Maybe T.Text -> OwnServer -> NtfTknRec -> PushNotification -> M () -pushNotification s srvHost_ isOwn tkn@NtfTknRec {token = DeviceToken pp _} ntf = do - q <- getOrCreatePushWorker s (srvHost_, pp) isOwn +pushNotification :: NtfPostgresStore -> NtfServerStats -> NtfPushServer -> Maybe T.Text -> OwnServer -> NtfTknRec -> PushNotification -> IO () +pushNotification st stats s srvHost_ isOwn tkn@NtfTknRec {token = DeviceToken pp _} ntf = do + q <- getOrCreatePushWorker st stats s (srvHost_, pp) isOwn atomically $ writeTBQueue q (tkn, ntf) -getOrCreatePushWorker :: NtfPushServer -> (Maybe T.Text, PushProvider) -> OwnServer -> M (TBQueue (NtfTknRec, PushNotification)) -getOrCreatePushWorker s@NtfPushServer {pushWorkers, pushWorkerSeq, pushQSize} key@(srvHost_, _) isOwn = do - ts <- liftIO getCurrentTime +getOrCreatePushWorker :: NtfPostgresStore -> NtfServerStats -> NtfPushServer -> (Maybe T.Text, PushProvider) -> OwnServer -> IO (TBQueue (NtfTknRec, PushNotification)) +getOrCreatePushWorker st stats s@NtfPushServer {pushWorkers, pushWorkerSeq, pushQSize} key@(srvHost_, _) isOwn = do + ts <- getCurrentTime atomically (getSessVar pushWorkerSeq key pushWorkers ts) >>= \case Left v -> do - q <- liftIO $ newTBQueueIO pushQSize - tId <- mkWeakThreadId =<< forkIO (runPushWorker s srvHost_ isOwn q) + q <- newTBQueueIO pushQSize + tId <- mkWeakThreadId =<< forkIO (runPushWorker st stats s srvHost_ isOwn q) atomically $ putTMVar (sessionVar v) PushWorker {workerQ = q, workerThreadId = tId} pure q Right v -> workerQ <$> atomically (readTMVar $ sessionVar v) -runPushWorker :: NtfPushServer -> Maybe T.Text -> OwnServer -> TBQueue (NtfTknRec, PushNotification) -> M () -runPushWorker s srvHost_ isOwn q = forever $ do +runPushWorker :: NtfPostgresStore -> NtfServerStats -> NtfPushServer -> Maybe T.Text -> OwnServer -> TBQueue (NtfTknRec, PushNotification) -> IO () +runPushWorker st stats s srvHost_ isOwn q = forever $ do (tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue q) - liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp) - st <- asks store + logDebug $ "sending push notification to " <> T.pack (show pp) case ntf of PNVerification _ -> - liftIO (deliverNotification st pp tkn ntf) >>= \case + deliverNotification st pp tkn ntf >>= \case Right _ -> do - void $ liftIO $ setTknStatusConfirmed st tkn - incNtfStatT t ntfVrfDelivered - Left _ -> incNtfStatT t ntfVrfFailed + void $ setTknStatusConfirmed st tkn + incNtfStatT_ stats t ntfVrfDelivered + Left _ -> incNtfStatT_ stats t ntfVrfFailed PNCheckMessages -> - liftIO (deliverNotification st pp tkn ntf) >>= \case + deliverNotification st pp tkn ntf >>= \case Right _ -> do - void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime - incNtfStatT t ntfCronDelivered - Left _ -> incNtfStatT t ntfCronFailed + void $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime + incNtfStatT_ stats t ntfCronDelivered + Left _ -> incNtfStatT_ stats t ntfCronFailed PNMessage {} -> checkActiveTkn tknStatus $ do - stats <- asks serverStats - liftIO $ updatePeriodStats (activeTokens stats) ntfTknId - liftIO (deliverNotification st pp tkn ntf) >>= \case + updatePeriodStats (activeTokens stats) ntfTknId + deliverNotification st pp tkn ntf >>= \case Left _ -> do - incNtfStatT t ntfFailed - when isOwn $ liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_ + incNtfStatT_ stats t ntfFailed + when isOwn $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_ Right () -> do - incNtfStatT t ntfDelivered - when isOwn $ liftIO $ mapM_ (`incServerStat` ntfDeliveredOwn stats) srvHost_ + incNtfStatT_ stats t ntfDelivered + when isOwn $ mapM_ (`incServerStat` ntfDeliveredOwn stats) srvHost_ where - checkActiveTkn :: NtfTknStatus -> M () -> M () + checkActiveTkn :: NtfTknStatus -> IO () -> IO () checkActiveTkn status action | status == NTActive = action - | otherwise = liftIO $ logError "bad notification token status" + | otherwise = logError "bad notification token status" deliverNotification :: NtfPostgresStore -> PushProvider -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ()) deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf' = do (deliver, clientVar) <- getPushClient s pp @@ -730,13 +719,13 @@ pushWorkersQLength workers = do periodicNtfsThread :: NtfPushServer -> M () periodicNtfsThread s = do st <- asks store + stats <- asks serverStats ntfsInterval <- asks $ periodicNtfsInterval . config let interval = 1000000 * ntfsInterval - UnliftIO unlift <- askUnliftIO liftIO $ forever $ do threadDelay interval now <- systemSeconds <$> getSystemTime - cnt <- withPeriodicNtfTokens st now $ \tkn -> unlift $ pushNotification s Nothing False tkn PNCheckMessages + cnt <- withPeriodicNtfTokens st now $ \tkn -> pushNotification st stats s Nothing False tkn PNCheckMessages logNote $ "Scheduled periodic notifications: " <> tshow cnt runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M () @@ -826,14 +815,16 @@ verifyNtfTransmission st thAuth (tAuth, authorized, (corrId, entId, cmd)) = case e -> VRFailed e client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M () -client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} ps = +client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} ps = do + st <- asks store + stats <- asks serverStats forever $ atomically (readTBQueue rcvQ) - >>= mapM processCommand + >>= mapM (processCommand st stats) >>= atomically . writeTBQueue sndQ where - processCommand :: NtfRequest -> M (Transmission NtfResponse) - processCommand = \case + processCommand :: NtfPostgresStore -> NtfServerStats -> NtfRequest -> M (Transmission NtfResponse) + processCommand st stats = \case NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> (corrId,NoEntity,) <$> do logDebug "TNEW - new token" (srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random @@ -843,7 +834,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} ps = ts <- liftIO $ getSystemDate let tkn = mkNtfTknRec tknId newTkn srvDhPrivKey dhSecret regCode ts withNtfStore (`addNtfToken` tkn) $ \_ -> do - pushNotification ps Nothing False tkn $ PNVerification regCode + liftIO $ pushNotification st stats ps Nothing False tkn $ PNVerification regCode incNtfStatT token ntfVrfQueued incNtfStatT token tknCreated pure $ NRTknId tknId srvDhPubKey @@ -859,7 +850,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} ps = | otherwise -> withNtfStore (\st -> updateTknStatus st tkn NTRegistered) $ \_ -> sendVerification where sendVerification = do - pushNotification ps Nothing False tkn $ PNVerification tknRegCode + liftIO $ pushNotification st stats ps Nothing False tkn $ PNVerification tknRegCode incNtfStatT token ntfVrfQueued pure $ NRTknId ntfTknId $ C.publicKey tknDhPrivKey TVFY code -- this allows repeated verification for cases when client connection dropped before server response @@ -877,7 +868,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} ps = regCode <- getRegCode let tkn' = tkn {token = token', tknStatus = NTRegistered, tknRegCode = regCode} withNtfStore (`replaceNtfToken` tkn') $ \_ -> do - pushNotification ps Nothing False tkn' $ PNVerification regCode + liftIO $ pushNotification st stats ps Nothing False tkn' $ PNVerification regCode incNtfStatT token ntfVrfQueued incNtfStatT token tknReplaced pure NROk @@ -949,6 +940,11 @@ incNtfStatT (DeviceToken PPApnsNull _) _ = pure () incNtfStatT _ statSel = incNtfStat statSel {-# INLINE incNtfStatT #-} +incNtfStatT_ :: NtfServerStats -> DeviceToken -> (NtfServerStats -> IORef Int) -> IO () +incNtfStatT_ _ (DeviceToken PPApnsNull _) _ = pure () +incNtfStatT_ stats _ statSel = incNtfStat_ stats statSel +{-# INLINE incNtfStatT_ #-} + incNtfStat :: (NtfServerStats -> IORef Int) -> M () incNtfStat statSel = asks serverStats >>= liftIO . (`incNtfStat_` statSel) {-# INLINE incNtfStat #-} diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 365d464c85..67659c7887 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -45,7 +45,7 @@ import qualified Data.X509.Validation as XV import Network.Socket import qualified Network.TLS as TLS import Numeric.Natural -import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError) +import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmissionBatch) import Simplex.Messaging.Client.Agent import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol @@ -54,14 +54,14 @@ import Simplex.Messaging.Notifications.Server.Stats import Simplex.Messaging.Notifications.Server.Store.Postgres import Simplex.Messaging.Notifications.Server.Store.Types import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF) -import Simplex.Messaging.Protocol (BasicAuth, CorrId, Party (..), SMPServer, SParty (..), ServiceId, Transmission) +import Simplex.Messaging.Protocol (BasicAuth, BrokerMsg, CorrId, ErrorType, Party (..), SMPServer, SParty (..), ServiceId, Transmission) import Simplex.Messaging.Server.Env.STM (StartOptions (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..)) import Simplex.Messaging.Session import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ASrvTransport, SMPServiceRole (..), ServiceCredentials (..), THandleParams, TransportPeer (..)) +import Simplex.Messaging.Transport (ASrvTransport, SMPServiceRole (..), SMPVersion, ServiceCredentials (..), THandleParams, TransportPeer (..)) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential) import Simplex.Messaging.Util (liftEitherWith, tshow) @@ -119,16 +119,17 @@ data NtfEnv = NtfEnv serverStats :: NtfServerStats } -newNtfServerEnv :: NtfServerConfig -> IO NtfEnv -newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds} = do +newNtfServerEnv :: NtfServerConfig -> (NtfPostgresStore -> NtfPushServer -> NtfServerStats -> SMPClientAgent 'NotifierService -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO ()) -> IO NtfEnv +newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds} mkProcessMsg = do random <- C.newRandom store <- newNtfDbStore dbStoreConfig tlsServerCreds <- loadServerCredential ntfCredentials XV.Fingerprint fp <- loadFingerprint ntfCredentials let dbService = if useServiceCreds then Just $ mkDbService random store else Nothing - subscriber <- newNtfSubscriber smpAgentCfg dbService random pushServer <- newNtfPushServer pushQSize apnsConfig serverStats <- newNtfServerStats =<< getCurrentTime + let processMsg = mkProcessMsg store pushServer serverStats + subscriber <- newNtfSubscriber smpAgentCfg processMsg dbService random pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats} where mkDbService g st = DBService {getCredentials, updateServiceId} @@ -158,11 +159,11 @@ data NtfSubscriber = NtfSubscriber type SMPSubscriberVar = SessionVar SMPSubscriber -newNtfSubscriber :: SMPClientAgentConfig -> Maybe DBService -> TVar ChaChaDRG -> IO NtfSubscriber -newNtfSubscriber smpAgentCfg dbService random = do +newNtfSubscriber :: SMPClientAgentConfig -> (SMPClientAgent 'NotifierService -> ServerTransmissionBatch SMPVersion ErrorType BrokerMsg -> IO ()) -> Maybe DBService -> TVar ChaChaDRG -> IO NtfSubscriber +newNtfSubscriber smpAgentCfg processMsg dbService random = do smpSubscribers <- TM.emptyIO subscriberSeq <- newTVarIO 0 - smpAgent <- newSMPClientAgent SNotifierService smpAgentCfg dbService random + smpAgent <- newSMPClientAgent SNotifierService smpAgentCfg processMsg dbService random pure NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent} data SMPSubscriber = SMPSubscriber diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 574111c15e..123ccd545c 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -706,7 +706,7 @@ mkJournalStoreConfig queueStoreCfg storePath msgQueueQuota maxJournalMsgCount ma newSMPProxyAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> IO ProxyAgent newSMPProxyAgent smpAgentCfg random = do - smpAgent <- newSMPClientAgent SSender smpAgentCfg Nothing random + smpAgent <- newSMPClientAgent SSender smpAgentCfg (\_ _ -> pure ()) Nothing random pure ProxyAgent {smpAgent} readWriteQueueStore :: forall q. StoreQueueClass q => Bool -> (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO (StoreLog 'WriteMode) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index fba0eac4ad..265310409c 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -19,7 +19,8 @@ {-# OPTIONS_GHC -Wno-orphans #-} module AgentTests.FunctionalAPITests - ( functionalAPITests, + ( AgentClient (..), + functionalAPITests, testServerMatrix2, withAgentClientsCfg2, withAgentClientsCfgServers2, @@ -52,6 +53,11 @@ module AgentTests.FunctionalAPITests pattern Msg', pattern SENT, agentCfgVPrevPQ, + allowConnection, + ackMessage, + subscribeConnection, + deleteConnection, + disposeAgentClient, ) where @@ -82,10 +88,11 @@ 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 Simplex.Messaging.Agent hiding (AgentClient, abortConnectionSwitch, acceptContact, ackMessage, ackMessageAsync, allowConnection, allowConnectionAsync, changeConnectionUser, createConnection, createConnectionAsync, createUser, deleteConnection, deleteConnectionAsync, deleteConnections, deleteConnectionsAsync, deleteUser, disposeAgentClient, foregroundAgent, getConnShortLink, getConnShortLinkAsync, getConnectionMessages, getConnectionRatchetAdHash, getConnectionServers, joinConnection, joinConnectionAsync, prepareConnectionLink, prepareConnectionToAccept, rejectContact, resubscribeConnections, sendMessage, sendMessagesB, setConnShortLink, setConnShortLinkAsync, setNetworkConfig, setUserNetworkInfo, subscribeAllConnections, subscribeClientServices, subscribeConnection, subscribeConnections, suspendAgent, suspendConnection, switchConnectionAsync, synchronizeRatchet, testProtocolServer) 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.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..)) +import qualified Simplex.Messaging.Agent.Client as AC +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), ServerCfg (..), 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 (..)) @@ -94,14 +101,14 @@ 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 Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), NetworkRequestMode, 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 Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, NetworkError (..), ProtocolServer (..), ProtocolType (..), 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 (..)) @@ -138,6 +145,11 @@ import Simplex.Messaging.Server.QueueStore.Postgres.Migrations import Simplex.Messaging.Server.QueueStore.Types (QueueStoreClass (..)) #endif +data AgentClient = AgentClient + { client :: A.AgentClient, + subQ :: TBQueue ATransmission + } + type AEntityTransmission e = (ACorrId, ConnId, AEvent e) -- deriving instance Eq (ValidFileDescription p) @@ -183,8 +195,8 @@ 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) +pGet' c@AgentClient {subQ} skipWarn = do + t@(_, _, AEvt _ cmd) <- atomically (readTBQueue subQ) case cmd of CONNECT {} -> pGet c DISCONNECT {} -> pGet c @@ -284,41 +296,140 @@ inAnyOrder g rs = withFrozenCallStack $ do 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 + (connId, CCLink cReq _) <- A.createConnection (client 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 + connId <- A.prepareConnectionToJoin (client c) userId enableNtfs cReq PQSupportOn + sndSecure <- A.joinConnection (client 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 +acceptContact c = A.acceptContact (client c) NRMInteractive subscribeConnection :: AgentClient -> ConnId -> AE () -subscribeConnection c = void . A.subscribeConnection c +subscribeConnection c = void . A.subscribeConnection (client c) sendMessage :: AgentClient -> ConnId -> SMP.MsgFlags -> MsgBody -> AE AgentMsgId sendMessage c connId msgFlags msgBody = do - (msgId, pqEnc) <- A.sendMessage c connId PQEncOn msgFlags msgBody + (msgId, pqEnc) <- A.sendMessage (client c) connId PQEncOn msgFlags msgBody liftIO $ pqEnc `shouldBe` PQEncOn pure msgId deleteConnection :: AgentClient -> ConnId -> AE () -deleteConnection c = A.deleteConnection c NRMInteractive +deleteConnection c = A.deleteConnection (client c) NRMInteractive deleteConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ())) -deleteConnections c = A.deleteConnections c NRMInteractive +deleteConnections c = A.deleteConnections (client c) NRMInteractive getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (FixedLinkData c, ConnLinkData c) -getConnShortLink c = A.getConnShortLink c NRMInteractive +getConnShortLink c = A.getConnShortLink (client c) NRMInteractive setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AE (ConnShortLink c) -setConnShortLink c = A.setConnShortLink c NRMInteractive +setConnShortLink c = A.setConnShortLink (client c) NRMInteractive suspendConnection :: AgentClient -> ConnId -> AE () -suspendConnection c = A.suspendConnection c NRMInteractive +suspendConnection c = A.suspendConnection (client c) NRMInteractive + +allowConnection :: AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> AE () +allowConnection c = A.allowConnection (client c) + +ackMessage :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE () +ackMessage c = A.ackMessage (client c) + +ackMessageAsync :: AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE () +ackMessageAsync c = A.ackMessageAsync (client c) + +disposeAgentClient :: AgentClient -> IO () +disposeAgentClient = A.disposeAgentClient . client + +subscribeConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ())) +subscribeConnections c = A.subscribeConnections (client c) + +switchConnectionAsync :: AgentClient -> ACorrId -> ConnId -> AE ConnectionStats +switchConnectionAsync c = A.switchConnectionAsync (client c) + +foregroundAgent :: AgentClient -> IO () +foregroundAgent = A.foregroundAgent . client + +suspendAgent :: AgentClient -> Int -> IO () +suspendAgent c = A.suspendAgent (client c) + +subscribeAllConnections :: AgentClient -> Bool -> Maybe UserId -> AE () +subscribeAllConnections c = A.subscribeAllConnections (client c) + +subscribeClientServices :: AgentClient -> UserId -> AE (M.Map SMPServer (Either AgentErrorType SMP.ServiceSubResult)) +subscribeClientServices c = A.subscribeClientServices (client c) + +deleteConnectionAsync :: AgentClient -> Bool -> ConnId -> AE () +deleteConnectionAsync c = A.deleteConnectionAsync (client c) + +deleteConnectionsAsync :: AgentClient -> Bool -> [ConnId] -> AE () +deleteConnectionsAsync c = A.deleteConnectionsAsync (client c) + +resubscribeConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ())) +resubscribeConnections c = A.resubscribeConnections (client c) + +createUser :: AgentClient -> Bool -> NonEmpty (ServerCfg 'PSMP) -> NonEmpty (ServerCfg 'PXFTP) -> AE UserId +createUser c = A.createUser (client c) + +deleteUser :: AgentClient -> UserId -> Bool -> AE () +deleteUser c = A.deleteUser (client c) + +changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE () +changeConnectionUser c = A.changeConnectionUser (client c) + +rejectContact :: AgentClient -> ConfirmationId -> AE () +rejectContact c = A.rejectContact (client c) + +setConnShortLinkAsync :: AgentClient -> ACorrId -> ConnId -> UserConnLinkData 'CMContact -> Maybe CRClientData -> AE () +setConnShortLinkAsync c = A.setConnShortLinkAsync (client c) + +getConnShortLinkAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> ConnShortLink 'CMContact -> AE ConnId +getConnShortLinkAsync c = A.getConnShortLinkAsync (client c) + +abortConnectionSwitch :: AgentClient -> ConnId -> AE ConnectionStats +abortConnectionSwitch c = A.abortConnectionSwitch (client c) + +synchronizeRatchet :: AgentClient -> ConnId -> PQSupport -> Bool -> AE ConnectionStats +synchronizeRatchet c = A.synchronizeRatchet (client c) + +setNetworkConfig :: AgentClient -> NetworkConfig -> AE () +setNetworkConfig c = A.setNetworkConfig (client c) + +setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO () +setUserNetworkInfo c = A.setUserNetworkInfo (client c) + +getConnectionServers :: AgentClient -> ConnId -> AE ConnectionStats +getConnectionServers c = A.getConnectionServers (client c) + +prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> ConfirmationId -> PQSupport -> AE ConnId +prepareConnectionToAccept c = A.prepareConnectionToAccept (client c) + +allowConnectionAsync :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> AE () +allowConnectionAsync c = A.allowConnectionAsync (client c) + +joinConnectionAsync :: ConnectionModeI c => AgentClient -> ACorrId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE () +joinConnectionAsync c = A.joinConnectionAsync (client c) + +sendMessagesB :: AgentClient -> [Either AgentErrorType MsgReq] -> AE [Either AgentErrorType (AgentMsgId, PQEncryption)] +sendMessagesB c = A.sendMessagesB (client c) + +createConnectionAsync :: ConnectionModeI c => AgentClient -> ACorrId -> ConnId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AE () +createConnectionAsync c = A.createConnectionAsync (client c) + +testProtocolServer :: SMP.ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> SMP.ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure) +testProtocolServer c = A.testProtocolServer (client c) + +getConnectionRatchetAdHash :: AgentClient -> ConnId -> AE ByteString +getConnectionRatchetAdHash c = A.getConnectionRatchetAdHash (client c) + +getConnectionMessages :: AgentClient -> NonEmpty ConnMsgReq -> IO (NonEmpty (Either AgentErrorType (Maybe SMP.SMPMsgMeta))) +getConnectionMessages c = A.getConnectionMessages (client c) + +waitForUserNetwork :: AgentClient -> IO () +waitForUserNetwork = AC.waitForUserNetwork . client functionalAPITests :: (ASrvTransport, AStoreType) -> Spec functionalAPITests ps = do @@ -723,9 +834,9 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob 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 + (bobId, CCLink qInfo Nothing) <- A.createConnection (client alice) NRMInteractive 1 True True SCMInvitation Nothing Nothing aPQ SMSubscribe + aliceId <- A.prepareConnectionToJoin (client bob) 1 True qInfo bPQ + sqSecured' <- A.joinConnection (client 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 @@ -736,24 +847,24 @@ runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId = 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" + 1 <- msgId <$> A.sendMessage (client 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?" + 2 <- msgId <$> A.sendMessage (client 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" + 3 <- msgId <$> A.sendMessage (client 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" + 4 <- msgId <$> A.sendMessage (client 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" + 5 <- msgId <$> A.sendMessage (client 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" @@ -771,7 +882,7 @@ runAgentClientStressTestOneWay n pqSupport sqSecured viaProxy alice bob baseId = message i = "message " <> bshow i concurrently_ ( forM_ ([1 .. n] :: [Int64]) $ \i -> do - mId <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags (message i) + mId <- msgId <$> A.sendMessage (client alice) bobId pqEnc SMP.noMsgFlags (message i) liftIO $ do mId >= i `shouldBe` True let getEvent = @@ -817,7 +928,7 @@ runAgentClientStressTestConc n pqSupport sqSecured viaProxy alice bob _baseId = 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) + send a bId = mapM_ $ \i -> void $ A.sendMessage (client 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 @@ -872,14 +983,14 @@ testEnablePQEncryption = -- 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 + Left (A.CMD LARGE _) <- tryError $ A.sendMessage (client ca) bId PQEncOn SMP.noMsgFlags lrg + (7, PQEncOff) <- A.sendMessage (client 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 + Left (A.CMD LARGE _) <- tryError $ A.sendMessage (client cb) aId PQEncOn SMP.noMsgFlags lrg + (8, PQEncOff) <- A.sendMessage (client 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 @@ -905,8 +1016,8 @@ testEnablePQEncryption = (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") + Left (A.CMD LARGE _) <- tryError $ A.sendMessage (client ca) bId PQEncOff SMP.noMsgFlags (sml <> "123456") + Left (A.CMD LARGE _) <- tryError $ A.sendMessage (client cb) aId PQEncOff SMP.noMsgFlags (sml <> "123456") pure () where (\#>\) = PQEncOff `sndRcv` PQEncOff @@ -916,7 +1027,7 @@ testEnablePQEncryption = 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 + r <- A.sendMessage (client 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 @@ -952,13 +1063,13 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob 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 + (_, CCLink qInfo Nothing) <- A.createConnection (client alice) NRMInteractive 1 True True SCMContact Nothing Nothing aPQ SMSubscribe + aliceId <- A.prepareConnectionToJoin (client bob) 1 True qInfo bPQ + sqSecuredJoin <- A.joinConnection (client 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) + bobId <- 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 @@ -970,24 +1081,24 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b 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" + 1 <- msgId <$> A.sendMessage (client 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?" + 2 <- msgId <$> A.sendMessage (client 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" + 3 <- msgId <$> A.sendMessage (client 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" + 4 <- msgId <$> A.sendMessage (client 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" + 5 <- msgId <$> A.sendMessage (client 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" @@ -996,7 +1107,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b 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 + (_, CCLink qInfo Nothing) <- A.createConnection (client 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 @@ -1004,12 +1115,12 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId 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 + aId <- A.prepareConnectionToJoin (client b) 1 True qInfo pq + sqSecuredJoin <- A.joinConnection (client 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) + bId <- 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 @@ -1022,11 +1133,11 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId 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" + 1 <- msgId <$> A.sendMessage (client 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" + 2 <- msgId <$> A.sendMessage (client 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 @@ -1049,9 +1160,9 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () 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 + (_addrConnId, CCLink qInfo Nothing) <- A.createConnection (client alice) NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe + aliceId <- A.prepareConnectionToJoin (client bob) 1 True qInfo PQSupportOn + sqSecured <- A.joinConnection (client 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 @@ -1063,8 +1174,8 @@ testUpdateConnectionUserId = (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 + aliceId <- A.prepareConnectionToJoin (client bob) 1 True qInfo PQSupportOn + sqSecured' <- A.joinConnection (client 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 @@ -1085,10 +1196,10 @@ testAsyncInitiatingOffline = liftIO $ sqSecured `shouldBe` True -- send messages - msgId1 <- A.sendMessage bob aliceId PQEncOn SMP.noMsgFlags "can send 1" + msgId1 <- A.sendMessage (client 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" + msgId2 <- A.sendMessage (client bob) aliceId PQEncOn SMP.noMsgFlags "can send 2" liftIO $ msgId2 `shouldBe` (3, PQEncOff) get bob ##> ("", aliceId, SENT 3) @@ -1222,15 +1333,15 @@ testInvitationErrors ps restart = do 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 + aId <- runRight $ A.prepareConnectionToJoin (client 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 + BROKER srv (NETWORK _) <- runLeft $ A.joinConnection (client 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 + BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection (client 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 @@ -1238,7 +1349,7 @@ testInvitationErrors ps restart = 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 + BROKER srv' (NETWORK _) <- runLeft $ A.joinConnection (client 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] @@ -1247,7 +1358,7 @@ testInvitationErrors ps restart = do ("", "", UP _ [_]) <- nGet a threadDelay 200000 let loopConfirm n = - runExceptT (A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case + runExceptT (A.joinConnection (client 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) @@ -1292,14 +1403,14 @@ testContactErrors ps restart = do 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 + aId <- runRight $ A.prepareConnectionToJoin (client 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 + BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection (client 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 + BROKER srv' (NETWORK _) <- runLeft $ A.joinConnection (client 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 @@ -1309,7 +1420,7 @@ testContactErrors ps restart = 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 + runExceptT (A.joinConnection (client 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 @@ -1317,7 +1428,7 @@ testContactErrors ps restart = do ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get a pure invId ("", "", DOWN _ [_]) <- nGet a - bId <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn + bId <- runRight $ prepareConnectionToAccept a 1 True invId PQSupportOn withServer2 ps $ do ("", "", UP _ [_]) <- nGet b'' let loopSecure = do @@ -1376,7 +1487,7 @@ 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 + (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection (client 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 @@ -1397,8 +1508,8 @@ testInvitationShortLink viaProxy a b = 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 + aId <- A.prepareConnectionToJoin (client b) 1 True connReq PQSupportOn + sndSecure' <- A.joinConnection (client 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" @@ -1412,20 +1523,21 @@ 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 + (bId, CCLink connReq Nothing) <- A.createConnection (client 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 + (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection (client 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 + aId <- A.prepareConnectionToJoin (client b) 1 True connReq PQSupportOn + A.joinConnectionAsync (client b) "123" False aId 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" @@ -1446,7 +1558,7 @@ testContactShortLink viaProxy a b = 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 + (contactId, CCLink connReq0 (Just shortLink)) <- runRight $ A.createConnection (client 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 @@ -1464,7 +1576,7 @@ testContactShortLink viaProxy a b = (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 + bId <- 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 @@ -1486,14 +1598,14 @@ testContactShortLink viaProxy a b = shortLink2 <- runRight $ setConnShortLink a contactId SCMContact userLinkData' Nothing shortLink2 `shouldBe` shortLink -- delete short link - runRight_ $ deleteConnShortLink a NRMInteractive contactId SCMContact + runRight_ $ A.deleteConnShortLink (client 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 + (contactId, CCLink connReq0 Nothing) <- runRight $ A.createConnection (client 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} @@ -1515,7 +1627,7 @@ testAddContactShortLink viaProxy a b = (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 + bId <- 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 @@ -1539,7 +1651,7 @@ 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 + runRight $ A.createConnection (client 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 @@ -1553,7 +1665,7 @@ testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do 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 + runRight $ A.createConnection (client 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} @@ -1577,7 +1689,7 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do 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@(contactId, _) <- A.createConnection (client 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" @@ -1599,13 +1711,13 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do 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 + A.createConnection (client 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 + let AgentClient {client = A.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 () @@ -1662,9 +1774,9 @@ testPrepareCreateConnectionLink ps = withSmpServer ps $ withAgentClients2 $ \a b linkEntId <- atomically $ C.randomBytes 32 g runRight $ do (ccLink@(CCLink connReq (Just shortLink)), preparedParams) <- - A.prepareConnectionLink a 1 rootKey linkEntId True Nothing + A.prepareConnectionLink (client 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 + _ <- A.createConnectionForLink (client 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) @@ -1673,7 +1785,7 @@ testPrepareCreateConnectionLink ps = withSmpServer ps $ withAgentClients2 $ \a b (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 + aId <- 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 @@ -2406,9 +2518,9 @@ 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 + (bobId, CCLink qInfo Nothing) <- A.createConnection (client alice) NRMInteractive aliceUserId True True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe + aliceId <- A.prepareConnectionToJoin (client bob) bobUserId True qInfo pqSupport + sqSecured' <- A.joinConnection (client 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 @@ -2685,10 +2797,12 @@ receiveMsg c cId msgId msg = do testAsyncCommands :: SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO () testAsyncCommands sqSecured alice bob baseId = runRight_ $ do - bobId <- createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe + bobId <- prepareConnectionToCreate (client alice) 1 True SCMInvitation PQSupportOn + createConnectionAsync alice "1" bobId 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 + aliceId <- prepareConnectionToJoin (client bob) 1 True qInfo PQSupportOn + joinConnectionAsync bob "2" False aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe ("2", aliceId', JOINED sqSecured') <- get bob liftIO $ do aliceId' `shouldBe` aliceId @@ -2739,7 +2853,7 @@ testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> 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 + (cId, CCLink qInfo (Just shortLink)) <- A.createConnection (client 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 @@ -2757,7 +2871,7 @@ testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> -- 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 + bobId <- 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" @@ -2771,7 +2885,7 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> 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 + (_, CCLink qInfo (Just shortLink)) <- A.createConnection (client 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 @@ -2779,13 +2893,13 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> 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 + joinConnectionAsync bob "2" True newId True qInfo' "bob's connInfo" PQSupportOn SMSubscribe + let aliceId = 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 + bobId <- 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" @@ -2796,7 +2910,10 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> testAsyncCommandsRestore :: (ASrvTransport, AStoreType) -> IO () testAsyncCommandsRestore ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe + bobId <- runRight $ do + connId <- prepareConnectionToCreate (client alice) 1 True SCMInvitation PQSupportOn + createConnectionAsync alice "1" connId True SCMInvitation IKPQOn SMSubscribe + pure connId liftIO $ noMessages alice "alice doesn't receive INV because server is down" disposeAgentClient alice withAgent 2 agentCfg initAgentServers testDB $ \alice' -> @@ -2812,7 +2929,8 @@ testAcceptContactAsync sqSecured alice bob baseId = (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 + bobId <- prepareConnectionToAccept alice 1 True invId PQSupportOn + acceptContactAsync (client alice) "1" bobId 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" @@ -3083,10 +3201,12 @@ testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do 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 + bId <- prepareConnectionToCreate (client a) 1 True SCMInvitation PQSupportOn + createConnectionAsync a "1" bId 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 + aId <- prepareConnectionToJoin (client b) 1 True qInfo PQSupportOn + joinConnectionAsync b "2" False aId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) @@ -3128,10 +3248,12 @@ testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do 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 + bId <- prepareConnectionToCreate (client a) 1 True SCMInvitation PQSupportOn + createConnectionAsync a "1" bId 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 + aId <- prepareConnectionToJoin (client b) 1 True qInfo PQSupportOn + joinConnectionAsync b "2" False aId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) @@ -3670,12 +3792,12 @@ testDeliveryReceiptsVersion ps = 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" + (2, _) <- A.sendMessage (client 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" + (3, _) <- A.sendMessage (client 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 "" @@ -3693,19 +3815,19 @@ testDeliveryReceiptsVersion ps = do 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" + (6, PQEncOff) <- A.sendMessage (client 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" + (8, PQEncOff) <- A.sendMessage (client 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" + (10, _) <- A.sendMessage (client 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 "" @@ -3833,7 +3955,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do 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 + hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients $ client c) `shouldReturn` n testClientServiceConnection :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testClientServiceConnection ps = do @@ -4218,9 +4340,11 @@ testMigrateConnectionsToService ps = do 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 + subQ <- newTBQueueIO 1024 + Right client <- runExceptT $ getSMPAgentClient_ clientId cfg' initServers st (atomically . writeTBQueue subQ) when (dbNew st) $ insertUser st - pure c + startSMPAgentClient client False + pure AgentClient {client, subQ} #if defined(dbPostgres) createStore :: String -> IO (Either MigrationError DBStore) @@ -4361,7 +4485,7 @@ testServerQueueInfo = do checkEmptyQ alice bobId True checkEmptyQ bob aliceId True let msgId = 2 - (msgId', PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello" + (msgId', PQEncOn) <- A.sendMessage (client alice) bobId PQEncOn SMP.noMsgFlags "hello" liftIO $ msgId' `shouldBe` msgId get alice ##> ("", bobId, SENT msgId) liftIO $ threadDelay 200000 @@ -4373,17 +4497,17 @@ testServerQueueInfo = do ackMessage bob aliceId msgId Nothing liftIO $ threadDelay 200000 checkEmptyQ bob aliceId True - (msgId1, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 1" + (msgId1, PQEncOn) <- A.sendMessage (client 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" + (msgId2, PQEncOn) <- A.sendMessage (client alice) bobId PQEncOn SMP.noMsgFlags "hello 2" get alice ##> ("", bobId, SENT msgId2) - (msgId3, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 3" + (msgId3, PQEncOn) <- A.sendMessage (client alice) bobId PQEncOn SMP.noMsgFlags "hello 3" get alice ##> ("", bobId, SENT msgId3) - (msgId4, PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello 4" + (msgId4, PQEncOn) <- A.sendMessage (client 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" + (msgId5, PQEncOn) <- A.sendMessage (client 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 @@ -4418,7 +4542,7 @@ testServerQueueInfo = do 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 + ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo (client c) NRMInteractive cId liftIO $ do qiSnd `shouldBe` qiSnd' qiNtf `shouldBe` False @@ -4432,7 +4556,7 @@ 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 + A.createConnection (client c) NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe ("", "", DOWN _ [_]) <- nGet c addNotice c cId $ Just 1 @@ -4441,7 +4565,7 @@ testClientNotice ps = do subscribedWithErrors c 1 testNotice c True threadDelay 1000000 - runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe + runRight $ A.createConnection (client c) NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe ("", "", DOWN _ [_]) <- nGet c addNotice c cId' $ Just 1 @@ -4452,7 +4576,7 @@ testClientNotice ps = do threadDelay 1000000 testNotice c True threadDelay 1000000 - runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe + runRight $ A.createConnection (client c) NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe addNotice c cId'' $ Just 1 @@ -4464,7 +4588,7 @@ testClientNotice ps = do threadDelay 2000000 testNotice c True threadDelay 1000000 - runRight $ A.createConnection c NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe + runRight $ A.createConnection (client c) NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe ("", "", DOWN _ [_]) <- nGet c addNotice c cId3 Nothing @@ -4479,13 +4603,13 @@ testClientNotice ps = 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 + void $ runRight $ A.createConnection (client 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) + Right (SomeConn _ (ContactConnection _ RcvQueue {rcvId})) <- withTransaction (store $ agentEnv $ client 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 @@ -4495,7 +4619,7 @@ testClientNotice ps = do 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 + NOTICE "localhost" False expiresAt_ <- runLeft $ A.createConnection (client c) NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn SMSubscribe isJust expiresAt_ `shouldBe` willExpire noNetworkDelay :: AgentClient -> IO () @@ -4532,14 +4656,14 @@ exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQ 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" + msgId1 <- A.sendMessage (client 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" + msgId2 <- A.sendMessage (client bob) aliceId pqEnc SMP.noMsgFlags "hello too" let aMsgId' = aMsgId + 1 bMsgId' = bMsgId + 1 liftIO $ msgId2 `shouldBe` (bMsgId', pqEnc) diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 6a1c5cef99..c172e1adb3 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -17,7 +17,10 @@ module AgentTests.NotificationTests where -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) import AgentTests.FunctionalAPITests - ( agentCfgVPrevPQ, + ( AgentClient (..), + ackMessage, + agentCfgVPrevPQ, + allowConnection, createConnection, exchangeGreetings, get, @@ -27,6 +30,7 @@ import AgentTests.FunctionalAPITests runRight, runRight_, sendMessage, + subscribeConnection, switchComplete, testServerMatrix2, withAgent, @@ -61,7 +65,7 @@ import qualified Database.PostgreSQL.Simple as PSQL import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) import SMPClient -import Simplex.Messaging.Agent hiding (checkNtfToken, createConnection, joinConnection, registerNtfToken, sendMessage, verifyNtfToken) +import Simplex.Messaging.Agent hiding (AgentClient, ackMessage, allowConnection, checkNtfToken, createConnection, deleteNtfToken, foregroundAgent, getConnectionMessages, getNtfTokenData, getNotificationConns, joinConnection, registerNtfToken, sendMessage, setNtfServers, subscribeConnection, suspendAgent, switchConnectionAsync, toggleConnectionNtfs, verifyNtfToken) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -197,13 +201,41 @@ testNtfMatrix ps@(_, msType) runTest = do cfgVPrev' = cfgVPrev msType registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus -registerNtfToken c = A.registerNtfToken c NRMInteractive +registerNtfToken c = A.registerNtfToken (client c) NRMInteractive checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus -checkNtfToken c = A.checkNtfToken c NRMInteractive +checkNtfToken c = A.checkNtfToken (client c) NRMInteractive verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE () -verifyNtfToken c = A.verifyNtfToken c NRMInteractive +verifyNtfToken c = A.verifyNtfToken (client c) NRMInteractive + +deleteNtfToken :: AgentClient -> DeviceToken -> AE () +deleteNtfToken c = A.deleteNtfToken (client c) + +getNtfTokenData :: AgentClient -> AE NtfToken +getNtfTokenData = A.getNtfTokenData . client + +setNtfServers :: AgentClient -> [NtfServer] -> IO () +setNtfServers c = A.setNtfServers (client c) + +foregroundAgent :: AgentClient -> IO () +foregroundAgent = A.foregroundAgent . client + +suspendAgent :: AgentClient -> Int -> IO () +suspendAgent c = A.suspendAgent (client c) + +toggleConnectionNtfs :: AgentClient -> ConnId -> Bool -> AE () +toggleConnectionNtfs c = A.toggleConnectionNtfs (client c) + +getNotificationConns :: AgentClient -> C.CbNonce -> ByteString -> AE (NonEmpty NotificationInfo) +getNotificationConns c = A.getNotificationConns (client c) + +getConnectionMessages :: AgentClient -> NonEmpty ConnMsgReq -> IO (NonEmpty (Either AgentErrorType (Maybe SMPMsgMeta))) +getConnectionMessages c = A.getConnectionMessages (client c) + +switchConnectionAsync :: AgentClient -> ACorrId -> ConnId -> AE ConnectionStats +switchConnectionAsync c = A.switchConnectionAsync (client c) + runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do @@ -335,7 +367,7 @@ testNtfTokenServerRestartReverify t apns = do testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReverifyTimeout t apns = do let tkn = DeviceToken PPApnsTest "abcd" - withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do + withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {client = A.AgentClient {agentEnv = Env {store}}} -> do (nonce, verification) <- withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- @@ -394,7 +426,7 @@ testNtfTokenServerRestartReregister t apns = do testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReregisterTimeout t apns = do let tkn = DeviceToken PPApnsTest "abcd" - withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do + withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {client = A.AgentClient {agentEnv = Env {store}}} -> do withNtfServer t $ runRight $ do NTRegistered <- registerNtfToken a tkn NMPeriodic APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just _}} <- @@ -428,7 +460,7 @@ testNtfTokenServerRestartReregisterTimeout t apns = do getTestNtfTokenPort :: AgentClient -> AE String getTestNtfTokenPort a = - ExceptT (runExceptT (withStore' a getSavedNtfToken) `runReaderT` agentEnv a) >>= \case + ExceptT (runExceptT (withStore' (client a) getSavedNtfToken) `runReaderT` agentEnv (client a)) >>= \case Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port Nothing -> error "no active NtfToken" @@ -540,10 +572,10 @@ testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFai testRunNTFServerTests t srv = withNtfServer t $ withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing + A.testProtocolServer (client a) NRMInteractive 1 $ ProtoServerWithAuth srv Nothing testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do +testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {client = A.AgentClient {agentEnv = Env {config = aliceCfg, store}}} bob = do (bobId, aliceId, nonce, message) <- runRight $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe diff --git a/tests/AgentTests/ServerChoice.hs b/tests/AgentTests/ServerChoice.hs index 8412c6761a..4c00b1a5ad 100644 --- a/tests/AgentTests/ServerChoice.hs +++ b/tests/AgentTests/ServerChoice.hs @@ -74,17 +74,17 @@ testChooseDifferentOperator = do c <- getSMPAgentClient' 1 agentCfg initServers testDB runRight_ $ do -- chooses the only operator with storage role - srv1 <- withAgentEnv c $ getNextServer c 1 storageSrvs [] + srv1 <- withAgentEnv (client c) $ getNextServer (client c) 1 storageSrvs [] liftIO $ srv1 == testOp1Srv1 || srv1 == testOp1Srv2 `shouldBe` True -- chooses another server for storage - srv2 <- withAgentEnv c $ getNextServer c 1 storageSrvs [protoServer testOp1Srv1] + srv2 <- withAgentEnv (client c) $ getNextServer (client c) 1 storageSrvs [protoServer testOp1Srv1] liftIO $ srv2 `shouldBe` testOp1Srv2 -- chooses another operator for proxy - srv3 <- withAgentEnv c $ getNextServer c 1 proxySrvs [protoServer srv1] + srv3 <- withAgentEnv (client c) $ getNextServer (client c) 1 proxySrvs [protoServer srv1] liftIO $ srv3 == testOp2Srv1 || srv3 == testOp2Srv2 `shouldBe` True -- chooses another operator for proxy - srv3' <- withAgentEnv c $ getNextServer c 1 proxySrvs [protoServer testOp1Srv1, protoServer testOp1Srv2] + srv3' <- withAgentEnv (client c) $ getNextServer (client c) 1 proxySrvs [protoServer testOp1Srv1, protoServer testOp1Srv2] liftIO $ srv3' == testOp2Srv1 || srv3' == testOp2Srv2 `shouldBe` True -- chooses any other server - srv4 <- withAgentEnv c $ getNextServer c 1 proxySrvs [protoServer testOp1Srv1, protoServer testOp2Srv1] + srv4 <- withAgentEnv (client c) $ getNextServer (client c) 1 proxySrvs [protoServer testOp1Srv1, protoServer testOp2Srv1] liftIO $ srv4 == testOp1Srv2 || srv4 == testOp2Srv2 `shouldBe` True diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 0d8ccdf89e..c4e052980b 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -27,7 +27,7 @@ import Data.Time.Clock (getCurrentTime) import SMPAgentClient import SMPClient import ServerTests (decryptMsgV3, sendRecv) -import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) +import Simplex.Messaging.Agent hiding (AgentClient, createConnection, joinConnection, sendMessage, allowConnection, ackMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..)) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ) @@ -172,7 +172,7 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- set up relay msgQ <- newTBQueueIO 1024 - rc' <- getProtocolClient g NRMInteractive (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ()) + rc' <- getProtocolClient g NRMInteractive (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just $ atomically . writeTBQueue msgQ) ts (\_ -> pure ()) rc <- either (fail . show) pure rc' -- prepare receiving queue (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g @@ -224,9 +224,9 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId = withAgent 1 aCfg (servers aTestCfg) testDB $ \alice -> withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do - (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe - aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (bobId, CCLink qInfo Nothing) <- A.createConnection (client alice) NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + aliceId <- A.prepareConnectionToJoin (client bob) 1 True qInfo PQSupportOn + sqSecured <- A.joinConnection (client 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 @@ -237,18 +237,18 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b get bob ##> ("", aliceId, A.CON pqEnc) -- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4 let aProxySrv = if aViaProxy then Just $ L.head aSrvs else Nothing - 1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 + 1 <- msgId <$> A.sendMessage (client alice) bobId pqEnc noMsgFlags msg1 get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv) - 2 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg2 + 2 <- msgId <$> A.sendMessage (client alice) bobId pqEnc noMsgFlags msg2 get alice ##> ("", bobId, A.SENT (baseId + 2) aProxySrv) get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False ackMessage bob aliceId (baseId + 1) Nothing get bob =##> \case ("", c, Msg' _ pq msg2') -> c == aliceId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage bob aliceId (baseId + 2) Nothing let bProxySrv = if bViaProxy then Just $ L.head bSrvs else Nothing - 3 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg1 + 3 <- msgId <$> A.sendMessage (client bob) aliceId pqEnc noMsgFlags msg1 get bob ##> ("", aliceId, A.SENT (baseId + 3) bProxySrv) - 4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 + 4 <- msgId <$> A.sendMessage (client bob) aliceId pqEnc noMsgFlags msg2 get bob ##> ("", aliceId, A.SENT (baseId + 4) bProxySrv) get alice =##> \case ("", c, Msg' _ pq msg1') -> c == bobId && pq == pqEnc && msg1 == msg1'; _ -> False ackMessage alice bobId (baseId + 3) Nothing @@ -280,9 +280,9 @@ agentDeliverMessagesViaProxyConc agentServers msgs = -- agent connections have to be set up in advance -- otherwise the CONF messages would get mixed with MSG prePair alice bob = do - (bobId, CCLink qInfo Nothing) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe - aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - sqSecured <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (bobId, CCLink qInfo Nothing) <- runExceptT' $ A.createConnection (client alice) NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + aliceId <- runExceptT' $ A.prepareConnectionToJoin (client bob) 1 True qInfo PQSupportOn + sqSecured <- runExceptT' $ A.joinConnection (client bob) NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True confId <- get alice >>= \case @@ -297,7 +297,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs = pure (alice, bobId, bob, aliceId) -- stream messages in opposite directions, while getting deliveries and sending ACKs run (alice, bobId, bob, aliceId) = do - aSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage alice bobId pqEnc noMsgFlags + aSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage (client alice) bobId pqEnc noMsgFlags bRecipient <- async $ forever $ @@ -305,7 +305,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs = ("", _, A.SENT _ _) -> pure () ("", _, Msg' mId' _ _) -> runExceptT' $ ackMessage alice bobId mId' Nothing huh -> fail (show huh) - bSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage bob aliceId pqEnc noMsgFlags + bSender <- async $ forM_ msgs $ runExceptT' . A.sendMessage (client bob) aliceId pqEnc noMsgFlags aRecipient <- async $ forever $ @@ -331,9 +331,9 @@ agentViaProxyVersionError = withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do Left (A.BROKER _ (TRANSPORT TEVersion)) <- withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do - (_bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe - aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (_bobId, CCLink qInfo Nothing) <- A.createConnection (client alice) NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + aliceId <- A.prepareConnectionToJoin (client bob) 1 True qInfo PQSupportOn + A.joinConnection (client bob) NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () where servers srvs = (initAgentServersProxy_ SPMUnknown SPFProhibit) {smp = userServers srvs} @@ -351,9 +351,9 @@ agentViaProxyRetryOffline = do let pqEnc = CR.PQEncOn withServer $ \_ -> do (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do - (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe - aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (bobId, CCLink qInfo Nothing) <- A.createConnection (client alice) NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + aliceId <- A.prepareConnectionToJoin (client bob) 1 True qInfo PQSupportOn + sqSecured <- A.joinConnection (client 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 @@ -361,18 +361,18 @@ agentViaProxyRetryOffline = do get alice ##> ("", bobId, A.CON pqEnc) get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) - 1 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 + 1 <- msgId <$> A.sendMessage (client alice) bobId pqEnc noMsgFlags msg1 get alice ##> ("", bobId, A.SENT (baseId + 1) aProxySrv) get bob =##> \case ("", c, Msg' _ pq msg1') -> c == aliceId && pq == pqEnc && msg1 == msg1'; _ -> False ackMessage bob aliceId (baseId + 1) Nothing - 2 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 + 2 <- msgId <$> A.sendMessage (client bob) aliceId pqEnc noMsgFlags msg2 get bob ##> ("", aliceId, A.SENT (baseId + 2) bProxySrv) get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage alice bobId (baseId + 2) Nothing pure (aliceId, bobId) runRight_ $ do -- destination relay down - 3 <- msgId <$> A.sendMessage alice bobId pqEnc noMsgFlags msg1 + 3 <- msgId <$> A.sendMessage (client alice) bobId pqEnc noMsgFlags msg1 bob `down` aliceId withServer2 $ \_ -> runRight_ $ do bob `up` aliceId @@ -381,7 +381,7 @@ agentViaProxyRetryOffline = do ackMessage bob aliceId (baseId + 3) Nothing runRight_ $ do -- proxy relay down - 4 <- msgId <$> A.sendMessage bob aliceId pqEnc noMsgFlags msg2 + 4 <- msgId <$> A.sendMessage (client bob) aliceId pqEnc noMsgFlags msg2 bob `down` aliceId withServer2 $ \_ -> do getInAnyOrder diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index af1d2f5c24..f03fe003dd 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -10,7 +10,7 @@ module XFTPAgent where -import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent) +import AgentTests.FunctionalAPITests (AgentClient (..), get, rfGet, runRight, runRight_, sfGet, withAgent) import Control.Logger.Simple import Control.Monad @@ -30,7 +30,7 @@ import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..)) import Simplex.FileTransfer.Server.Store (STMFileStore) import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) -import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) +import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg) import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv) @@ -99,7 +99,7 @@ testXFTPServerTest newFileBasicAuth srv = withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a NRMInteractive 1 srv + A.testProtocolServer (client a) NRMInteractive 1 srv rfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m () rfProgress c expected = loop 0 @@ -132,7 +132,7 @@ testXFTPAgentSendReceive = do -- send file, delete snd file internally (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (sfId, _, rfd1, rfd2) <- testSend sndr filePath - liftIO $ xftpDeleteSndFileInternal sndr sfId + liftIO $ A.xftpDeleteSndFileInternal (client sndr) sfId pure (rfd1, rfd2) -- receive file, delete rcv file testReceiveDelete 2 rfd1 filePath @@ -141,7 +141,7 @@ testXFTPAgentSendReceive = do testReceiveDelete clientId rfd originalFilePath = withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do rfId <- runRight $ testReceive rcp rfd originalFilePath - xftpDeleteRcvFile rcp rfId + A.xftpDeleteRcvFile (client rcp) rfId testXFTPAgentSendReceiveEncrypted :: HasCallStack => AFStoreType -> IO () testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do @@ -152,7 +152,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do runRight_ $ CF.writeFile file s (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do (sfId, _, rfd1, rfd2) <- testSendCF sndr file - liftIO $ xftpDeleteSndFileInternal sndr sfId + liftIO $ A.xftpDeleteSndFileInternal (client sndr) sfId pure (rfd1, rfd2) -- receive file, delete rcv file testReceiveDelete 2 rfd1 filePath g @@ -162,7 +162,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do cfArgs <- atomically $ Just <$> CF.randomArgs g rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath - xftpDeleteRcvFile rcp rfId + A.xftpDeleteRcvFile (client rcp) rfId testXFTPAgentSendReceiveRedirect :: HasCallStack => AFStoreType -> IO () testXFTPAgentSendReceiveRedirect = withXFTPServer $ do @@ -171,7 +171,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do let fileSize = mb 17 totalSize = fileSize + mb 1 withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do - directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 + directFileId <- runRight $ A.xftpSendFile (client sndr) 1 (CryptoFile filePathIn Nothing) 1 sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize) sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize) @@ -185,7 +185,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do testNoRedundancy vfdDirect - redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1 + redirectFileId <- runRight $ A.xftpSendDescription (client sndr) 1 vfdDirect 1 logInfo $ "File sent, sending redirect: " <> tshow redirectFileId sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536) vfdRedirect@(ValidFileDescription fdRedirect) <- @@ -206,7 +206,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do FileDescriptionURI {description} <- either fail pure $ strDecode uri - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True + rcvFileId <- runRight $ A.xftpReceiveFile (client rcp) 1 description Nothing True rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize) @@ -228,7 +228,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do let fileSize = mb 5 filePathIn <- createRandomFile_ fileSize "testfile" withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do - directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1 + directFileId <- runRight $ A.xftpSendFile (client sndr) 1 (CryptoFile filePathIn Nothing) 1 let totalSize = fileSize + mb 1 sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize) sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize) @@ -250,7 +250,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do FileDescriptionURI {description} <- either fail pure $ strDecode uri let ValidFileDescription FileDescription {redirect} = description redirect `shouldBe` Nothing - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True + rcvFileId <- runRight $ A.xftpReceiveFile (client rcp) 1 description Nothing True -- NO extra "RFPROG 65k 65k" before switching to real file rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize) @@ -286,10 +286,10 @@ testXFTPAgentSendReceiveMatrix = do filePath <- createRandomFile_ (kb 319 :: Integer) "testfile" rfd <- withAgent 1 sender initAgentServers testDB $ \sndr -> do (sfId, _, rfd1, _) <- runRight $ testSendCF' sndr (CF.plain filePath) (kb 320) - rfd1 <$ xftpDeleteSndFileInternal sndr sfId + rfd1 <$ A.xftpDeleteSndFileInternal (client sndr) sfId withAgent 2 receiver initAgentServers testDB2 $ \rcp -> do rfId <- runRight $ testReceiveCF' rcp rfd Nothing filePath (kb 320) - xftpDeleteRcvFile rcp rfId + A.xftpDeleteRcvFile (client rcp) rfId createRandomFile :: HasCallStack => IO FilePath createRandomFile = createRandomFile' "testfile" @@ -312,8 +312,8 @@ testSendCF sndr file = testSendCF' sndr file $ mb 18 testSendCF' :: HasCallStack => AgentClient -> CryptoFile -> Int64 -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient) testSendCF' sndr file size = do - xftpStartWorkers sndr (Just senderFiles) - sfId <- xftpSendFile sndr 1 file 2 + A.xftpStartWorkers (client sndr) (Just senderFiles) + sfId <- A.xftpSendFile (client sndr) 1 file 2 sfProgress sndr size ("", sfId', SFDONE sndDescr [rfd1, rfd2]) <- sfGet sndr liftIO $ testNoRedundancy rfd1 @@ -330,7 +330,7 @@ testReceive rcp rfd = testReceiveCF rcp rfd Nothing testReceiveCF :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId testReceiveCF rcp rfd cfArgs originalFilePath = do - xftpStartWorkers rcp (Just recipientFiles) + A.xftpStartWorkers (client rcp) (Just recipientFiles) testReceiveCF' rcp rfd cfArgs originalFilePath $ mb 18 testReceive' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId @@ -338,7 +338,7 @@ testReceive' rcp rfd originalFilePath = testReceiveCF' rcp rfd Nothing originalF testReceiveCF' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> Int64 -> ExceptT AgentErrorType IO RcvFileId testReceiveCF' rcp rfd cfArgs originalFilePath size = do - rfId <- xftpReceiveFile rcp 1 rfd cfArgs True + rfId <- A.xftpReceiveFile (client rcp) 1 rfd cfArgs True rfProgress rcp size ("", rfId', RFDONE path) <- rfGet rcp liftIO $ do @@ -362,8 +362,8 @@ testXFTPAgentReceiveRestore = do -- receive file - should not succeed with server down rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do - xftpStartWorkers rcp (Just recipientFiles) - rfId <- xftpReceiveFile rcp 1 rfd Nothing True + A.xftpStartWorkers (client rcp) (Just recipientFiles) + rfId <- A.xftpReceiveFile (client rcp) 1 rfd Nothing True liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId @@ -374,7 +374,7 @@ testXFTPAgentReceiveRestore = do withXFTPServerStoreLogOn $ \_ -> -- receive file - should start downloading with server up withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + runRight_ $ A.xftpStartWorkers (client rcp') (Just recipientFiles) ("", rfId', RFPROG _ _) <- rfGet rcp' liftIO $ rfId' `shouldBe` rfId threadDelay 100000 @@ -382,7 +382,7 @@ testXFTPAgentReceiveRestore = do withXFTPServerStoreLogOn $ \_ -> -- receive file - should continue downloading with server up withAgent 4 agentCfg initAgentServers testDB2 $ \rcp' -> do - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + runRight_ $ A.xftpStartWorkers (client rcp') (Just recipientFiles) rfProgress rcp' $ mb 18 ("", rfId', RFDONE path) <- rfGet rcp' liftIO $ do @@ -406,8 +406,8 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should not succeed with server down rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do - xftpStartWorkers rcp (Just recipientFiles) - rfId <- xftpReceiveFile rcp 1 rfd Nothing True + A.xftpStartWorkers (client rcp) (Just recipientFiles) + rfId <- A.xftpReceiveFile (client rcp) 1 rfd Nothing True liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId @@ -418,7 +418,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do withXFTPServerThreadOn $ \_ -> -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do - runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) + runRight_ $ A.xftpStartWorkers (client rcp') (Just recipientFiles) ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp' rfId' `shouldBe` rfId @@ -431,8 +431,8 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do -- send file - should not succeed with server down sfId <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do - xftpStartWorkers sndr (Just senderFiles) - sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2 + A.xftpStartWorkers (client sndr) (Just senderFiles) + sfId <- A.xftpSendFile (client sndr) 1 (CF.plain filePath) 2 liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing -- wait for worker to encrypt and attempt to create file pure sfId @@ -446,7 +446,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do withXFTPServerStoreLogOn $ \_ -> -- send file - should start uploading with server up withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + runRight_ $ A.xftpStartWorkers (client sndr') (Just senderFiles) ("", sfId', SFPROG _ _) <- sfGet sndr' liftIO $ sfId' `shouldBe` sfId @@ -455,7 +455,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do withXFTPServerStoreLogOn $ \_ -> do -- send file - should continue uploading with server up rfd1 <- withAgent 3 agentCfg initAgentServers testDB $ \sndr' -> do - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + runRight_ $ A.xftpStartWorkers (client sndr') (Just senderFiles) sfProgress sndr' $ mb 18 ("", sfId', SFDONE _sndDescr [rfd1, rfd2]) <- sfGet sndr' liftIO $ testNoRedundancy rfd1 @@ -479,8 +479,8 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do sfId <- withXFTPServerStoreLogOn $ \_ -> -- send file withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do - xftpStartWorkers sndr (Just senderFiles) - sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2 + A.xftpStartWorkers (client sndr) (Just senderFiles) + sfId <- A.xftpSendFile (client sndr) 1 (CF.plain filePath) 2 -- wait for progress events for 5 out of 6 chunks - at this point all chunks should be created on the server forM_ [1 .. 5 :: Integer] $ \_ -> do (_, _, SFPROG _ _) <- sfGet sndr @@ -497,7 +497,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do withXFTPServerThreadOn $ \_ -> -- send file - should fail with AUTH error withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + runRight_ $ A.xftpStartWorkers (client sndr') (Just senderFiles) ("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- sfGet sndr' sfId' `shouldBe` sfId @@ -523,8 +523,8 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test length <$> listDirectory xftpServerFiles `shouldReturn` 6 -- delete file - runRight_ $ xftpStartWorkers sndr (Just senderFiles) - xftpDeleteSndFileRemote sndr 1 sfId sndDescr + runRight_ $ A.xftpStartWorkers (client sndr) (Just senderFiles) + A.xftpDeleteSndFileRemote (client sndr) 1 sfId sndDescr Nothing <- 100000 `timeout` sfGet sndr pure () @@ -533,8 +533,8 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do - xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True + A.xftpStartWorkers (client rcp2) (Just recipientFiles) + rfId <- A.xftpReceiveFile (client rcp2) 1 rfd2 Nothing True ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -555,8 +555,8 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do -- delete file - should not succeed with server down withAgent 3 agentCfg initAgentServers testDB $ \sndr -> do - runRight_ $ xftpStartWorkers sndr (Just senderFiles) - xftpDeleteSndFileRemote sndr 1 sfId sndDescr + runRight_ $ A.xftpStartWorkers (client sndr) (Just senderFiles) + A.xftpDeleteSndFileRemote (client sndr) 1 sfId sndDescr timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt threadDelay 300000 length <$> listDirectory xftpServerFiles `shouldReturn` 6 @@ -564,15 +564,15 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do withXFTPServerStoreLogOn $ \_ -> do -- delete file - should succeed with server up withAgent 4 agentCfg initAgentServers testDB $ \sndr' -> do - runRight_ $ xftpStartWorkers sndr' (Just senderFiles) + runRight_ $ A.xftpStartWorkers (client sndr') (Just senderFiles) threadDelay 1000000 length <$> listDirectory xftpServerFiles `shouldReturn` 0 -- receive file - should fail with AUTH error withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do - xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True + A.xftpStartWorkers (client rcp2) (Just recipientFiles) + rfId <- A.xftpReceiveFile (client rcp2) 1 rfd2 Nothing True ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -608,7 +608,7 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer te runRight_ . void $ do -- receive file 1 again - rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True + rfId1 <- A.xftpReceiveFile (client rcp) 1 rfd1_2 Nothing True ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp liftIO $ rfId1 `shouldBe` rfId1' @@ -640,7 +640,7 @@ testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $ -- receive file 1 again - should fail with AUTH error runRight $ do - rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True + rfId <- A.xftpReceiveFile (client rcp) 1 rfd1_2 Nothing True ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp liftIO $ rfId' `shouldBe` rfId @@ -662,8 +662,8 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do -- send file rfds <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do - xftpStartWorkers sndr (Just senderFiles) - sfId <- xftpSendFile sndr 1 (CF.plain filePath) 500 + A.xftpStartWorkers (client sndr) (Just senderFiles) + sfId <- A.xftpSendFile (client sndr) 1 (CF.plain filePath) 500 sfProgress sndr $ mb 18 ("", sfId', SFDONE _sndDescr rfds) <- sfGet sndr liftIO $ do @@ -685,4 +685,4 @@ testXFTPServerTest_ :: HasCallStack => XFTPServerWithAuth -> IO (Maybe ProtocolT testXFTPServerTest_ srv = -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a NRMInteractive 1 srv + A.testProtocolServer (client a) NRMInteractive 1 srv diff --git a/tests/XFTPWebTests.hs b/tests/XFTPWebTests.hs index c9a98eef1c..309d610ffe 100644 --- a/tests/XFTPWebTests.hs +++ b/tests/XFTPWebTests.hs @@ -47,8 +47,8 @@ import Util import Simplex.FileTransfer.Server.Env (XFTPServerConfig) import Simplex.FileTransfer.Server.Store (STMFileStore) import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpTestPort) -import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent) -import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpSendFile, xftpStartWorkers) +import AgentTests.FunctionalAPITests (AgentClient (..), rfGet, runRight, runRight_, sfGet, withAgent) +import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Protocol (AEvent (..)) import SMPAgentClient (agentCfg, initAgentServers, testDB) import XFTPCLI (recipientFiles, senderFiles, testBracket) @@ -3126,8 +3126,8 @@ tsUploadHaskellDownloadTest cfg caFile = do <> jsOut2 "Buffer.from(yaml)" "Buffer.from(originalData)" let vfd :: ValidFileDescription 'FRecipient = either error id $ strDecode yamlDesc withAgent 1 agentCfg initAgentServers testDB $ \rcp -> do - runRight_ $ xftpStartWorkers rcp (Just recipientFiles) - _ <- runRight $ xftpReceiveFile rcp 1 vfd Nothing True + runRight_ $ A.xftpStartWorkers (client rcp) (Just recipientFiles) + _ <- runRight $ A.xftpReceiveFile (client rcp) 1 vfd Nothing True rfProgress rcp 50000 (_, _, RFDONE outPath) <- rfGet rcp downloadedData <- B.readFile outPath @@ -3162,8 +3162,8 @@ tsUploadRedirectHaskellDownloadTest cfg caFile = do let vfd@(ValidFileDescription fd) :: ValidFileDescription 'FRecipient = either error id $ strDecode yamlDesc redirect fd `shouldSatisfy` (/= Nothing) withAgent 1 agentCfg initAgentServers testDB $ \rcp -> do - runRight_ $ xftpStartWorkers rcp (Just recipientFiles) - _ <- runRight $ xftpReceiveFile rcp 1 vfd Nothing True + runRight_ $ A.xftpStartWorkers (client rcp) (Just recipientFiles) + _ <- runRight $ A.xftpReceiveFile (client rcp) 1 vfd Nothing True outPath <- waitRfDone rcp downloadedData <- B.readFile outPath downloadedData `shouldBe` originalData @@ -3177,8 +3177,8 @@ haskellUploadTsDownloadTest cfg = do B.writeFile filePath originalData withXFTPServerCfg cfg $ \_ -> do vfd <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do - runRight_ $ xftpStartWorkers sndr (Just senderFiles) - _ <- runRight $ xftpSendFile sndr 1 (CF.plain filePath) 1 + runRight_ $ A.xftpStartWorkers (client sndr) (Just senderFiles) + _ <- runRight $ A.xftpSendFile (client sndr) 1 (CF.plain filePath) 1 sfProgress sndr 50000 (_, _, SFDONE _ [rfd]) <- sfGet sndr pure rfd