diff --git a/CHANGELOG.md b/CHANGELOG.md index 707a6ff5f..90706a19e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 5.8.2 + +Agent: +- fast handshake support (disabled). +- new statistics api. + +SMP server: +- fast handshake support (SKEY command). +- minor changes to reduce memory usage. + # 5.8.1 Agent: diff --git a/package.yaml b/package.yaml index 916506e8b..04513e1a6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 5.8.1.0 +version: 6.0.0.0 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, diff --git a/rfcs/2024-06-14-fast-connection.md b/rfcs/2024-06-14-fast-connection.md new file mode 100644 index 000000000..000f0ef10 --- /dev/null +++ b/rfcs/2024-06-14-fast-connection.md @@ -0,0 +1,42 @@ +# Faster connection establishment + +## Problem + +SMP protocol is unidirectional, and to create a connection users have to agree two messaging queues. + +V1 of handshake protocol required 5 messages and multiple HELLO sent between the users, which consumed a lot of traffic. + +V2 of handshake protocol was optimized to remove multiple HELLO and also REPLY message, thanks to including queue address together with the key to secure this queue into the confirmation message. + +This eliminated unnecessary traffic from repeated HELLOs, but still requires 4 messages in total and 2 times of each client being online. It is perceived by the users as "it didn't work" (because they see "connecting" after using the link) or "we have to be online at the same time" (and even in this case it is slow on bad network). This hurts usability and creates churn of the new users, as unless people are onboarded by the friends who know how the app works, they cannot figure out how to connect. + +Ideally, we want to have handshake protocol design when an accepting user can send messages straight after using the link (their client says "connected") and the initiating client can send messages as soon as it received confirmation message with the profile. + +This RFC proposes modifications to SMP and SMP Agent protocols to reduce the number of required messages to 2 and allows accepting client to send messages straight after using the link (and sending the confirmation), before receiving the profile of the initiating client in the second message, and the initiating client can send the messages straight after processing the confirmation and sending its own confirmation. + +## Solution + +The current protocol design allows additional confirmation step where the initiating client can confirm the connection having received the profile of the sender. We don't use it in the UI - this confirmation is done automatically and unconditionally. + +Instead of requiring the initiating client to secure its queue with sender's key, we can allow the accepting client to secure it with the additional SKEY command. This would avoid "connecting" state but would introduce "Profile unknown" state where the accepting client does not yet have the profile of the initiating client. In this case we could also use the non-optional alias created during the connection (or have something like "Add alias to be able to send messages immediately" and show warning if the user proceeds without it). + +The additional advantage here is that if the queue of the initiating client was removed, the connection will not procede to create additional queue, failing faster. + +These are the proposed changes: + +1. Modify NEW command to add flag allowing sender to secure the queue (it should not be allowed if queue is created for the contact address). +2. Include flag into the invitation link URI and in reply address encoding that queue(s) can be secured by the sender (to avoid coupling with the protocol version and preserve the possibility of the longer handshakes). +3. Add SKEY command to SMP protocol to allow the sender securing the message queue. +4. This command has to be supported by SMP proxy as well, so that the sender does not connect to the recipient's server directly. +5. Accepting client will secure the messaging queue before sending the confirmation to it. +6. Initiating client will secure the messaging queue before sending the confirmation. + +See [this sequence diagram](../protocol/diagrams/duplex-messaging/duplex-creating-v6.mmd) for the updated handshake protocol. + +Changes to threat model: the attacker who compromised TLS and knows the queue address can block the connection, as the protocol no longer requires the recipient to decrypt the confirmation to secure the queue. + +Possibly, "fast connection" should be an option in Privacy & security settings. + +## Implementation questions + +Currently we store received confirmations in the database, so that the client can confirm them. This becomes unnecessary. diff --git a/simplexmq.cabal b/simplexmq.cabal index 38c44b229..3264f0b58 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 5.8.1.0 +version: 6.0.0.0 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and @@ -95,6 +95,7 @@ library Simplex.Messaging.Agent.Protocol Simplex.Messaging.Agent.QueryString Simplex.Messaging.Agent.RetryInterval + Simplex.Messaging.Agent.Stats Simplex.Messaging.Agent.Store Simplex.Messaging.Agent.Store.SQLite Simplex.Messaging.Agent.Store.SQLite.Common @@ -132,6 +133,8 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 890966888..4683143c5 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -49,6 +49,7 @@ import qualified Data.Set as S import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) +import Simplex.FileTransfer.Chunks (toKB) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Client.Main import Simplex.FileTransfer.Crypto @@ -63,6 +64,7 @@ import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C @@ -184,6 +186,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do liftIO $ waitForUserNetwork c + atomically $ incXFTPServerStat c userId srv downloadAttempts downloadFileChunk fc replica approvedRelays `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e where @@ -194,13 +197,18 @@ runXFTPRcvWorker c srv Worker {doWork} = do withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay atomically $ assertAgentForeground c loop - retryDone = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) + retryDone e = do + atomically . incXFTPServerStat c userId srv $ case e of + XFTP _ XFTP.AUTH -> downloadAuthErrs + _ -> downloadErrs + rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) e downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM () downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwE $ FILE NOT_APPROVED fsFileTmpPath <- lift $ toFSFilePath fileTmpPath chunkPath <- uniqueCombine fsFileTmpPath $ show chunkNo - let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) + let chSize = unFileSize chunkSize + chunkSpec = XFTPRcvChunkSpec chunkPath chSize (unFileDigest digest) relChunkPath = fileTmpPath takeFileName chunkPath agentXFTPDownloadChunk c userId digest replica chunkSpec atomically $ waitUntilForeground c @@ -214,6 +222,8 @@ runXFTPRcvWorker c srv Worker {doWork} = do Just RcvFileRedirect {redirectFileInfo = RedirectFileInfo {size = FileSize finalSize}, redirectEntityId} -> (redirectEntityId, finalSize) liftIO . when complete $ updateRcvFileStatus db rcvFileId RFSReceived pure (entityId, complete, RFPROG rcvd total) + atomically $ incXFTPServerStat c userId srv downloads + atomically $ incXFTPServerSizeStat c userId srv downloadsSize (fromIntegral $ toKB chSize) notify c entityId progress when complete . lift . void $ getXFTPRcvWorker True c Nothing @@ -484,6 +494,7 @@ runXFTPSndWorker c srv Worker {doWork} = do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do liftIO $ waitForUserNetwork c + atomically $ incXFTPServerStat c userId srv uploadAttempts uploadFileChunk cfg fc replica `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e where @@ -494,9 +505,11 @@ runXFTPSndWorker c srv Worker {doWork} = do withStore' c $ \db -> updateSndChunkReplicaDelay db sndChunkReplicaId replicaDelay atomically $ assertAgentForeground c loop - retryDone = sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) + retryDone e = do + atomically $ incXFTPServerStat c userId srv uploadErrs + sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) e uploadFileChunk :: AgentConfig -> SndFileChunk -> SndFileChunkReplica -> AM () - uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath}, digest = chunkDigest} replica = do + uploadFileChunk AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients} sndFileChunk@SndFileChunk {sndFileId, userId, chunkSpec = chunkSpec@XFTPChunkSpec {filePath, chunkSize = chSize}, digest = chunkDigest} replica = do replica'@SndFileChunkReplica {sndChunkReplicaId} <- addRecipients sndFileChunk replica fsFilePath <- lift $ toFSFilePath filePath unlessM (doesFileExist fsFilePath) $ throwE $ FILE NO_FILE @@ -510,6 +523,8 @@ runXFTPSndWorker c srv Worker {doWork} = do let uploaded = uploadedSize chunks total = totalSize chunks complete = all chunkUploaded chunks + atomically $ incXFTPServerStat c userId srv uploads + atomically $ incXFTPServerSizeStat c userId srv uploadsSize (fromIntegral $ toKB chSize) notify c sndFileEntityId $ SFPROG uploaded total when complete $ do (sndDescr, rcvDescrs) <- sndFileToDescrs sf @@ -651,6 +666,7 @@ runXFTPDelWorker c srv Worker {doWork} = do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do liftIO $ waitForUserNetwork c + atomically $ incXFTPServerStat c userId srv deleteAttempts deleteChunkReplica `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e where @@ -661,10 +677,13 @@ runXFTPDelWorker c srv Worker {doWork} = do withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay atomically $ assertAgentForeground c loop - retryDone = delWorkerInternalError c deletedSndChunkReplicaId + retryDone e = do + atomically $ incXFTPServerStat c userId srv deleteErrs + delWorkerInternalError c deletedSndChunkReplicaId e deleteChunkReplica = do agentXFTPDeleteChunk c userId replica withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId + atomically $ incXFTPServerStat c userId srv deletions delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM () delWorkerInternalError c deletedSndChunkReplicaId e = do diff --git a/src/Simplex/FileTransfer/Chunks.hs b/src/Simplex/FileTransfer/Chunks.hs index 0b35649c5..d8890944d 100644 --- a/src/Simplex/FileTransfer/Chunks.hs +++ b/src/Simplex/FileTransfer/Chunks.hs @@ -26,6 +26,10 @@ kb :: Integral a => a -> a kb n = 1024 * n {-# INLINE kb #-} +toKB :: Integral a => a -> a +toKB n = n `div` 1024 +{-# INLINE toKB #-} + mb :: Integral a => a -> a mb n = 1024 * kb n {-# INLINE mb #-} diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 445def724..1404fd434 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -22,7 +22,6 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Time (UTCTime) import Data.Word (Word32) import qualified Data.X509 as X import qualified Data.X509.Validation as XV @@ -168,9 +167,6 @@ xftpClientServer = B.unpack . strEncode . snd3 . transportSession xftpTransportHost :: XFTPClient -> TransportHost xftpTransportHost XFTPClient {http2Client = HTTP2Client {client_ = HClient {host}}} = host -xftpSessionTs :: XFTPClient -> UTCTime -xftpSessionTs = sessionTs . http2Client - xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = defaultHTTP2ClientConfig diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index f1ab78200..2262a96e5 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -104,14 +104,13 @@ module Simplex.Messaging.Agent rcConnectHost, rcConnectCtrl, rcDiscoverCtrl, + getAgentServersSummary, + resetAgentServersStats, foregroundAgent, suspendAgent, execAgentStoreSQL, getAgentMigrations, debugAgentLocks, - getAgentStats, - resetAgentStats, - getMsgCounts, getAgentSubscriptions, logConnection, ) @@ -124,7 +123,7 @@ import Control.Monad.Reader import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J -import Data.Bifunctor (bimap, first, second) +import Data.Bifunctor (bimap, first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Composition ((.:), (.:.), (.::), (.::.)) @@ -157,6 +156,7 @@ import Simplex.Messaging.Agent.Lock (withLock, withLock') import Simplex.Messaging.Agent.NtfSubSupervisor import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -172,9 +172,8 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, XFTPServerWithAuth, sndAuthKeySMPClientVersion) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPVersion, THandleParams (sessionId)) @@ -202,23 +201,57 @@ getSMPAgentClient_ clientId cfg initServers store backgroundMode = liftIO $ newSMPAgentEnv cfg store >>= runReaderT runAgent where runAgent = do - c@AgentClient {acThread} <- atomically . newAgentClient clientId initServers =<< ask + currentTs <- liftIO getCurrentTime + c@AgentClient {acThread} <- atomically . newAgentClient clientId initServers currentTs =<< ask t <- runAgentThreads c `forkFinally` const (liftIO $ disconnectAgentClient c) atomically . writeTVar acThread . Just =<< mkWeakThreadId t pure c runAgentThreads c | backgroundMode = run c "subscriber" $ subscriber c - | otherwise = + | otherwise = do + restoreServersStats c raceAny_ [ run c "subscriber" $ subscriber c, run c "runNtfSupervisor" $ runNtfSupervisor c, - run c "cleanupManager" $ cleanupManager c + run c "cleanupManager" $ cleanupManager c, + run c "logServersStats" $ logServersStats c ] + `E.finally` saveServersStats c run AgentClient {subQ, acThread} 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) +logServersStats :: AgentClient -> AM' () +logServersStats c = do + delay <- asks (initialLogStatsDelay . config) + liftIO $ threadDelay' delay + int <- asks (logStatsInterval . config) + forever $ do + saveServersStats c + liftIO $ threadDelay' int + +saveServersStats :: AgentClient -> AM' () +saveServersStats c@AgentClient {subQ, smpServersStats, xftpServersStats} = do + sss <- mapM (lift . getAgentSMPServerStats) =<< readTVarIO smpServersStats + xss <- mapM (lift . getAgentXFTPServerStats) =<< readTVarIO xftpServersStats + let stats = AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss} + tryAgentError' (withStore' c (`updateServersStats` stats)) >>= \case + Left e -> atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) + Right () -> pure () + +restoreServersStats :: AgentClient -> AM' () +restoreServersStats c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt} = do + tryAgentError' (withStore c getServersStats) >>= \case + Left e -> atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ show e) + Right (startedAt, Nothing) -> atomically $ writeTVar srvStatsStartedAt startedAt + Right (startedAt, Just AgentPersistedServerStats {smpServersStats = sss, xftpServersStats = xss}) -> do + atomically $ writeTVar srvStatsStartedAt startedAt + sss' <- mapM (atomically . newAgentSMPServerStats') sss + atomically $ writeTVar smpServersStats sss' + xss' <- mapM (atomically . newAgentXFTPServerStats') xss + atomically $ writeTVar xftpServersStats xss' + disconnectAgentClient :: AgentClient -> IO () disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do closeAgentClient c @@ -369,7 +402,7 @@ ackMessage :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE ackMessage c = withAgentEnv c .:. ackMessage' c {-# INLINE ackMessage #-} -getConnectionQueueInfo :: AgentClient -> ConnId -> AE QueueInfo +getConnectionQueueInfo :: AgentClient -> ConnId -> AE ServerQueueInfo getConnectionQueueInfo c = withAgentEnv c . getConnectionQueueInfo' c {-# INLINE getConnectionQueueInfo #-} @@ -550,15 +583,9 @@ rcDiscoverCtrl :: AgentClient -> NonEmpty RCCtrlPairing -> AE (RCCtrlPairing, RC rcDiscoverCtrl AgentClient {agentEnv = Env {multicastSubscribers = subs}} = withExceptT RCP . discoverRCCtrl subs {-# INLINE rcDiscoverCtrl #-} -getAgentStats :: AgentClient -> IO [(AgentStatsKey, Int)] -getAgentStats c = readTVarIO (agentStats c) >>= mapM (\(k, cnt) -> (k,) <$> readTVarIO cnt) . M.assocs - -resetAgentStats :: AgentClient -> IO () -resetAgentStats = atomically . TM.clear . agentStats -{-# INLINE resetAgentStats #-} - -getMsgCounts :: AgentClient -> IO [(ConnId, (Int, Int))] -- (total, duplicates) -getMsgCounts c = readTVarIO (msgCounts c) >>= mapM (\(connId, cnt) -> (connId,) <$> readTVarIO cnt) . M.assocs +resetAgentServersStats :: AgentClient -> AE () +resetAgentServersStats c = withAgentEnv c $ resetAgentServersStats' c +{-# INLINE resetAgentServersStats #-} withAgentEnv' :: AgentClient -> AM' a -> IO a withAgentEnv' c = (`runReaderT` agentEnv c) @@ -581,11 +608,15 @@ createUser' c smp xftp = do pure userId deleteUser' :: AgentClient -> UserId -> Bool -> AM () -deleteUser' c userId delSMPQueues = do +deleteUser' c@AgentClient {smpServersStats, xftpServersStats} userId delSMPQueues = do if delSMPQueues then withStore c (`setUserDeleted` userId) >>= deleteConnectionsAsync_ delUser c False else withStore c (`deleteUserRecord` userId) atomically $ TM.delete userId $ smpServers c + atomically $ TM.delete userId $ xftpServers c + atomically $ modifyTVar' smpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) + atomically $ modifyTVar' xftpServersStats $ M.filterWithKey (\(userId', _) _ -> userId' /= userId) + lift $ saveServersStats c where delUser = whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $ @@ -701,12 +732,14 @@ newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys sub newRcvConnSrv c userId connId' enableNtfs cMode clientData pqInitKeys subMode srv newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c) -newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv = do +newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do case (cMode, pqInitKeys) of (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" _ -> pure () AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv smpClientVRange subMode `catchAgentError` \e -> liftIO (print e) >> throwE e + let sndSecure = case cMode of SCMInvitation -> True; SCMContact -> False + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srvWithAuth smpClientVRange subMode sndSecure `catchAgentError` \e -> liftIO (print e) >> throwE e + atomically $ incSMPServerStat c userId srv connCreated rq' <- withStore c $ \db -> updateNewConnRcv db connId rq lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId when enableNtfs $ do @@ -725,7 +758,7 @@ newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Connection newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of CRInvitationUri {} -> lift (compatibleInvitationUri cReq) >>= \case - Just (_, (Compatible (CR.E2ERatchetParams v _ _ _)), aVersion) -> create aVersion (Just v) + Just (_, Compatible (CR.E2ERatchetParams v _ _ _), aVersion) -> create aVersion (Just v) Nothing -> throwE $ AGENT A_VERSION CRContactUri {} -> lift (compatibleContactUri cReq) >>= \case @@ -747,10 +780,10 @@ joinConn c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode = do _ -> getSMPServer c userId joinConnSrv c userId connId hasNewConn enableNtfs cReq cInfo pqSupport subMode srv -startJoinInvitation :: UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) -startJoinInvitation userId connId enableNtfs cReqUri pqSup = +startJoinInvitation :: UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, NewSndQueue, C.PublicKeyX25519, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) +startJoinInvitation userId connId sq_ enableNtfs cReqUri pqSup = lift (compatibleInvitationUri cReqUri) >>= \case - Just (qInfo, (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), Compatible connAgentVersion) -> do + Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_), Compatible connAgentVersion) -> do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) @@ -759,9 +792,13 @@ startJoinInvitation userId connId enableNtfs cReqUri pqSup = maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let rcVs = CR.RatchetVersions {current = v, maxSupported} rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams - q <- lift $ newSndQueue userId "" qInfo + -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out + -- e2ePubKey is always present, it's Maybe historically + (q, e2ePubKey) <- case sq_ of + Just sq@SndQueue {e2ePubKey = Just k} -> pure ((sq :: SndQueue) {dbQueueId = DBNewQueue}, k) + _ -> lift $ newSndQueue userId "" qInfo let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - pure (cData, q, rc, e2eSndParams) + pure (cData, q, e2ePubKey, rc, e2eSndParams) Nothing -> throwE $ AGENT A_VERSION connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport)) @@ -797,7 +834,7 @@ versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && ma joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM ConnId joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = withInvLock c (strEncode inv) "joinConnSrv" $ do - (cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSup + (cData, q, _, rc, e2eSndParams) <- startJoinInvitation userId connId Nothing enableNtfs inv pqSup g <- asks random (connId', sq) <- withStore c $ \db -> runExceptT $ do r@(connId', _) <- @@ -807,7 +844,10 @@ joinConnSrv c userId connId hasNewConn enableNtfs inv@CRInvitationUri {} cInfo p liftIO $ createRatchet db connId' rc pure r let cData' = (cData :: ConnData) {connId = connId'} - tryError (confirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case + -- joinConnSrv is only used on user interaction, and its failure is permanent, + -- otherwise we would need to manage retries here to avoid SndQueue recreated with a different key, + -- similar to how joinConnAsync does that. + tryError (secureConfirmQueue c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case Right _ -> pure connId' Left e -> do -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md @@ -823,17 +863,27 @@ joinConnSrv c userId connId hasNewConn enableNtfs cReqUri@CRContactUri {} cInfo joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM () joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do - (cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqSupport - q' <- withStore c $ \db -> runExceptT $ do - liftIO $ createRatchet db connId rc - ExceptT $ updateNewConnSnd db connId q - confirmQueueAsync c cData q' srv cInfo (Just e2eSndParams) subMode + SomeConn cType conn <- withStore c (`getConn` connId) + case conn of + NewConnection _ -> doJoin Nothing + SndConnection _ sq -> doJoin $ Just sq + _ -> throwE $ CMD PROHIBITED $ "joinConnSrvAsync: bad connection " <> show cType + where + doJoin :: Maybe SndQueue -> AM () + doJoin sq_ = do + (cData, sq, _, rc, e2eSndParams) <- startJoinInvitation userId connId sq_ enableNtfs inv pqSupport + sq' <- withStore c $ \db -> runExceptT $ do + liftIO $ createRatchet db connId rc + maybe (ExceptT $ updateNewConnSnd db connId sq) pure sq_ + secureConfirmQueueAsync c cData sq' srv cInfo (Just e2eSndParams) subMode joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do throwE $ CMD PROHIBITED "joinConnSrvAsync" createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do - (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode + let sndSecure = smpClientVersion >= sndAuthKeySMPClientVersion + (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode sndSecure + atomically $ incSMPServerStat c userId (qServer rq) connCreated let qInfo = toVersionT qUri smpClientVersion rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId @@ -1076,10 +1126,14 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do lift $ waitForWork doWork atomically $ throwWhenInactive c atomically $ beginAgentOperation c AOSndNetwork - withWork c doWork (`getPendingServerCommand` server_) $ processCmd (riFast ri) + withWork c doWork (`getPendingServerCommand` server_) $ runProcessCmd (riFast ri) where - processCmd :: RetryInterval -> PendingCommand -> AM () - processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} = case command of + runProcessCmd ri cmd = do + pending <- newTVarIO [] + processCmd ri cmd pending + mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending + processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM () + processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} pendingCmds = case command of AClientCommand cmd -> case cmd of NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do usedSrvs <- newTVarIO ([] :: [SMPServer]) @@ -1095,7 +1149,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK SWCH -> - noServer . tryCommand . withConnLock c connId "switchConnection" $ + noServer . tryWithLock "switchConnection" $ withStore c (`getConn` connId) >>= \case SomeConn _ conn@(DuplexConnection _ (replaced :| _rqs) _) -> switchDuplexConnection c conn replaced >>= notify . SWITCH QDRcv SPStarted @@ -1110,8 +1164,11 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do withStore c $ \db -> runExceptT $ (,) <$> ExceptT (getConn db connId) <*> ExceptT (getAcceptedConfirmation db connId) case conn of RcvConnection cData rq -> do - secure rq senderKey - mapM_ (connectReplyQueues c cData ownConnInfo) (L.nonEmpty $ smpReplyQueues senderConf) + mapM_ (secure rq) senderKey + mapM_ (connectReplyQueues c cData ownConnInfo Nothing) (L.nonEmpty $ smpReplyQueues senderConf) + -- duplex connection is matched to handle SKEY retries + DuplexConnection cData _ (sq :| _) -> + mapM_ (connectReplyQueues c cData ownConnInfo (Just sq)) (L.nonEmpty $ smpReplyQueues senderConf) _ -> throwE $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd) ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do secure rq senderKey @@ -1129,6 +1186,9 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do case find ((replaceQId ==) . dbQId) rqs of Just rq1 -> when (status == Confirmed) $ do secureQueue c rq' senderKey + -- we may add more statistics special to queue rotation later on, + -- not accounting secure during rotation for now: + -- atomically $ incSMPServerStat c userId server connSecured withStore' c $ \db -> setRcvQueueStatus db rq' Secured void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)] rq1' <- withStore' c $ \db -> setRcvSwitchStatus db rq1 $ Just RSSendingQUSE @@ -1164,8 +1224,9 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do rq <- withStore c $ \db -> getRcvQueue db connId srv rId ackQueueMessage c rq srvMsgId secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM () - secure rq senderKey = do + secure rq@RcvQueue {server} senderKey = do secureQueue c rq senderKey + atomically $ incSMPServerStat c userId server connSecured withStore' c $ \db -> setRcvQueueStatus db rq Secured where withServer a = case server_ of @@ -1190,7 +1251,9 @@ runCommandProcessing c@AgentClient {subQ} 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 = atomically $ writeTBQueue subQ (corrId, connId, AEvt (sAEntity @e) cmd) + notify cmd = + let t = (corrId, connId, AEvt (sAEntity @e) cmd) + in atomically $ ifM (isFullTBQueue subQ) (modifyTVar' pendingCmds (t :)) (writeTBQueue subQ t) -- ^ ^ ^ async command processing / enqueueMessages :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption) @@ -1281,7 +1344,7 @@ submitPendingMsg c cData sq = do void $ getDeliveryWorker True c cData sq runSmpQueueMsgDelivery :: AgentClient -> ConnData -> SndQueue -> (Worker, TMVar ()) -> AM () -runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork}, qLock) = do +runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userId, server, sndSecure} (Worker {doWork}, qLock) = do AgentConfig {messageRetryInterval = ri, messageTimeout, helloTimeout, quotaExceededTimeout} <- asks config forever $ do atomically $ endAgentOperation c AOSndNetwork @@ -1304,36 +1367,39 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork Left e -> do let err = if msgType == AM_A_MSG_ then MERR mId e else ERR e case e of - SMP _ SMP.QUOTA -> case msgType of - AM_CONN_INFO -> connError msgId NOT_AVAILABLE - AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE - _ -> do - expireTs <- addUTCTime (-quotaExceededTimeout) <$> liftIO getCurrentTime - if internalTs < expireTs - then notifyDelMsgs msgId e expireTs - else do - notify $ MWARN (unId msgId) e - retrySndMsg RISlow - SMP _ SMP.AUTH -> case msgType of - AM_CONN_INFO -> connError msgId NOT_AVAILABLE - AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE - AM_RATCHET_INFO -> connError msgId NOT_AVAILABLE - -- in duplexHandshake mode (v2) HELLO is only sent once, without retrying, - -- because the queue must be secured by the time the confirmation or the first HELLO is received - AM_HELLO_ -> case rq_ of - -- party initiating connection - Just _ -> connError msgId NOT_AVAILABLE - -- party joining connection - _ -> connError msgId NOT_ACCEPTED - AM_REPLY_ -> notifyDel msgId err - AM_A_MSG_ -> notifyDel msgId err - AM_A_RCVD_ -> notifyDel msgId err - AM_QCONT_ -> notifyDel msgId err - AM_QADD_ -> qError msgId "QADD: AUTH" - AM_QKEY_ -> qError msgId "QKEY: AUTH" - AM_QUSE_ -> qError msgId "QUSE: AUTH" - AM_QTEST_ -> qError msgId "QTEST: AUTH" - AM_EREADY_ -> notifyDel msgId err + SMP _ SMP.QUOTA -> do + atomically $ incSMPServerStat c userId server sentQuotaErrs + case msgType of + AM_CONN_INFO -> connError msgId NOT_AVAILABLE + AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE + _ -> do + expireTs <- addUTCTime (-quotaExceededTimeout) <$> liftIO getCurrentTime + if internalTs < expireTs + then notifyDelMsgs msgId e expireTs + else do + notify $ MWARN (unId msgId) e + retrySndMsg RISlow + SMP _ SMP.AUTH -> do + atomically $ incSMPServerStat c userId server sentAuthErrs + case msgType of + AM_CONN_INFO -> connError msgId NOT_AVAILABLE + AM_CONN_INFO_REPLY -> connError msgId NOT_AVAILABLE + AM_RATCHET_INFO -> connError msgId NOT_AVAILABLE + -- in duplexHandshake mode (v2) HELLO is only sent once, without retrying, + -- because the queue must be secured by the time the confirmation or the first HELLO is received + AM_HELLO_ -> case rq_ of + -- party initiating connection + Just _ -> connError msgId NOT_AVAILABLE + -- party joining connection + _ -> connError msgId NOT_ACCEPTED + AM_A_MSG_ -> notifyDel msgId err + AM_A_RCVD_ -> notifyDel msgId err + AM_QCONT_ -> notifyDel msgId err + AM_QADD_ -> qError msgId "QADD: AUTH" + AM_QKEY_ -> qError msgId "QKEY: AUTH" + AM_QUSE_ -> qError msgId "QUSE: AUTH" + AM_QTEST_ -> qError msgId "QTEST: AUTH" + AM_EREADY_ -> notifyDel msgId err _ -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server), -- the message sending would be retried @@ -1345,22 +1411,25 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork else do when (serverHostError e) $ notify $ MWARN (unId msgId) e retrySndMsg RIFast - | otherwise -> notifyDel msgId err + | otherwise -> do + atomically $ incSMPServerStat c userId server sentOtherErrs + notifyDel msgId err where retrySndMsg riMode = do withStore' c $ \db -> updatePendingMsgRIState db connId msgId riState retrySndOp c $ loop riMode Right proxySrv_ -> do case msgType of - AM_CONN_INFO -> setConfirmed - AM_CONN_INFO_REPLY -> setConfirmed + AM_CONN_INFO + | sndSecure -> notify (CON pqEncryption) >> setStatus Active + | otherwise -> setStatus Confirmed + AM_CONN_INFO_REPLY -> setStatus Confirmed AM_RATCHET_INFO -> pure () - AM_REPLY_ -> pure () AM_HELLO_ -> do withStore' c $ \db -> setSndQueueStatus db sq Active case rq_ of -- party initiating connection (in v1) - Just RcvQueue {status} -> + Just rq@RcvQueue {status} -> -- it is unclear why subscribeQueue was needed here, -- message delivery can only be enabled for queues that were created in the current session or subscribed -- subscribeQueue c rq connId @@ -1369,7 +1438,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork -- it would lead to the non-deterministic internal ID of the first sent message, at to some other race conditions, -- because it can be sent before HELLO is received -- With `status == Active` condition, CON is sent here only by the accepting party, that previously received HELLO - when (status == Active) $ notify $ CON pqEncryption + when (status == Active) $ do + atomically $ incSMPServerStat c userId (qServer rq) connCompleted + notify $ CON pqEncryption -- this branch should never be reached as receive queue is created before the confirmation, _ -> logError "HELLO sent without receive queue" AM_A_MSG_ -> notify $ SENT mId proxySrv_ @@ -1410,9 +1481,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork AM_EREADY_ -> pure () delMsgKeep (msgType == AM_A_MSG_) msgId where - setConfirmed = do + setStatus status = do withStore' c $ \db -> do - setSndQueueStatus db sq Confirmed + setSndQueueStatus db sq status when (isJust rq_) $ removeConfirmations db connId where notifyDelMsgs :: InternalId -> AgentErrorType -> UTCTime -> AM () @@ -1422,6 +1493,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork forM_ (L.nonEmpty msgIds_) $ \msgIds -> do notify $ MERRS (L.map unId msgIds) err withStore' c $ \db -> forM_ msgIds $ \msgId' -> deleteSndMsgDelivery db connId sq msgId' False `catchAll_` pure () + atomically $ incSMPServerStat' c userId server sentExpiredErrs (length msgIds_ + 1) delMsg :: InternalId -> AM () delMsg = delMsgKeep False delMsgKeep :: Bool -> InternalId -> AM () @@ -1475,7 +1547,7 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do withStore' c $ \db -> deleteDeliveredSndMsg db connId $ InternalId sndMsgId _ -> pure () -getConnectionQueueInfo' :: AgentClient -> ConnId -> AM QueueInfo +getConnectionQueueInfo' :: AgentClient -> ConnId -> AM ServerQueueInfo getConnectionQueueInfo' c connId = do SomeConn _ conn <- withStore c (`getConn` connId) case conn of @@ -1504,7 +1576,7 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s -- try to get the server that is different from all queues, or at least from the primary rcv queue srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth - (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe + (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq' lift $ addNewQueueSubscription c rq'' tSess sessId @@ -1559,10 +1631,14 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni _ -> throwE $ CMD PROHIBITED "synchronizeRatchet: not duplex" ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM () -ackQueueMessage c rq srvMsgId = - sendAck c rq srvMsgId `catchAgentError` \case - SMP _ SMP.NO_MSG -> pure () - e -> throwE e +ackQueueMessage c rq@RcvQueue {userId, server} srvMsgId = do + atomically $ incSMPServerStat c userId server ackAttempts + tryAgentError (sendAck c rq srvMsgId) >>= \case + Right _ -> atomically $ incSMPServerStat c userId server ackMsgs + Left (SMP _ SMP.NO_MSG) -> atomically $ incSMPServerStat c userId server ackNoMsgErrs + Left e -> do + unless (temporaryOrHostError e) $ atomically $ incSMPServerStat c userId server ackOtherErrs + throwE e -- | Suspend SMP agent connection (OFF command) in Reader monad suspendConnection' :: AgentClient -> ConnId -> AM () @@ -1659,11 +1735,15 @@ deleteConnQueues c waitDelivery ntf rqs = do Int -> (RcvQueue, Either AgentErrorType ()) -> IO ((RcvQueue, Either AgentErrorType ()), Maybe (AM' ())) - deleteQueueRec db maxErrs (rq, r) = case r of + deleteQueueRec db maxErrs (rq@RcvQueue {userId, server}, r) = case r of Right _ -> deleteConnRcvQueue db rq $> ((rq, r), Just (notifyRQ rq Nothing)) Left e | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> incRcvDeleteErrors db rq $> ((rq, r), Nothing) - | otherwise -> deleteConnRcvQueue db rq $> ((rq, Right ()), Just (notifyRQ rq (Just e))) + | otherwise -> do + deleteConnRcvQueue db rq + -- attempts and successes are counted in deleteQueues function + atomically $ incSMPServerStat c userId server connDeleted + pure ((rq, Right ()), Just (notifyRQ rq (Just e))) notifyRQ rq e_ = notify ("", qConnId rq, AEvt SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_) notify = when ntf . atomically . writeTBQueue (subQ c) connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) @@ -1940,6 +2020,14 @@ setNtfServers :: AgentClient -> [NtfServer] -> IO () setNtfServers c = atomically . writeTVar (ntfServers c) {-# INLINE setNtfServers #-} +resetAgentServersStats' :: AgentClient -> AM () +resetAgentServersStats' c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt} = do + startedAt <- liftIO getCurrentTime + atomically $ writeTVar srvStatsStartedAt startedAt + atomically $ TM.clear smpServersStats + atomically $ TM.clear xftpServersStats + withStore' c (`resetServersStats` startedAt) + -- | Activate operations foregroundAgent :: AgentClient -> IO () foregroundAgent c = do @@ -2072,12 +2160,12 @@ 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@(_, srv, _), _v, sessId, ts) = do +processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId, ts) = do upConnIds <- newTVarIO [] forM_ ts $ \(entId, t) -> case t of STEvent msgOrErr -> withRcvConn entId $ \rq@RcvQueue {connId} conn -> case msgOrErr of - Right msg -> processSMP rq conn (toConnData conn) msg + Right msg -> runProcessSMP rq conn (toConnData conn) msg Left e -> lift $ notifyErr connId e STResponse (Cmd SRecipient cmd) respOrErr -> withRcvConn entId $ \rq conn -> case cmd of @@ -2085,11 +2173,11 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) Right SMP.OK -> processSubOk rq upConnIds Right msg@SMP.MSG {} -> do processSubOk rq upConnIds -- the connection is UP even when processing this particular message fails - processSMP rq conn (toConnData conn) msg + runProcessSMP rq conn (toConnData conn) msg Right r -> processSubErr rq $ unexpectedResponse r Left e -> unless (temporaryClientError e) $ processSubErr rq e -- timeout/network was already reported SMP.ACK _ -> case respOrErr of - Right msg@SMP.MSG {} -> processSMP rq conn (toConnData conn) msg + Right msg@SMP.MSG {} -> runProcessSMP rq conn (toConnData conn) msg _ -> pure () -- TODO process OK response to ACK _ -> pure () -- TODO process expired response to DEL STResponse {} -> pure () -- TODO process expired responses to sent messages @@ -2097,7 +2185,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) logServer "<--" c srv entId $ "error: " <> bshow e notifyErr "" e connIds <- readTVarIO upConnIds - unless (null connIds) $ notify' "" $ UP srv connIds + unless (null connIds) $ do + notify' "" $ UP srv connIds + atomically $ incSMPServerStat' c userId srv connSubscribed $ length connIds where withRcvConn :: SMP.RecipientId -> (forall c. RcvQueue -> Connection c -> AM ()) -> AM' () withRcvConn rId a = do @@ -2114,21 +2204,32 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) modifyTVar' upConnIds (connId :) processSubErr :: RcvQueue -> SMPClientError -> AM () processSubErr rq@RcvQueue {connId} e = do - atomically . whenM (isPendingSub connId) $ failSubscription c rq e + atomically . whenM (isPendingSub connId) $ + failSubscription c rq e >> incSMPServerStat c userId srv connSubErrs lift $ notifyErr connId e - isPendingSub connId = (&&) <$> hasPendingSubscription c connId <*> activeClientSession c tSess sessId + isPendingSub connId = do + pending <- (&&) <$> hasPendingSubscription c connId <*> activeClientSession c tSess sessId + unless pending $ incSMPServerStat c userId srv connSubIgnored + pure pending notify' :: forall e m. (AEntityI e, MonadIO m) => ConnId -> AEvent e -> m () notify' connId msg = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) msg) notifyErr :: ConnId -> SMPClientError -> AM' () notifyErr connId = notify' connId . ERR . protocolClientError SMP (B.unpack $ strEncode srv) - processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> AM () + 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 + processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> TVar [ATransmission] -> AM () processSMP - rq@RcvQueue {rcvId = rId, e2ePrivKey, e2eDhSecret, status} + rq@RcvQueue {rcvId = rId, sndSecure, e2ePrivKey, e2eDhSecret, status} conn - cData@ConnData {userId, connId, connAgentVersion, ratchetSyncState = rss} - smpMsg = + cData@ConnData {connId, connAgentVersion, ratchetSyncState = rss} + smpMsg + pendingMsgs = withConnLock c connId "processSMP" $ case smpMsg of - SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> + SMP.MSG msg@SMP.RcvMessage {msgId = srvMsgId} -> do + atomically $ incSMPServerStat c userId srv recvMsgs void . handleNotifyAck $ do msg' <- decryptSMPMessage rq msg ack' <- handleNotifyAck $ case msg' of @@ -2151,7 +2252,10 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) let e2eDh = C.dh' e2ePubKey e2ePrivKey decryptClientMessage e2eDh clientMsg >>= \case (SMP.PHConfirmation senderKey, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) -> - smpConfirmation srvMsgId conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + smpConfirmation srvMsgId conn (Just senderKey) e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + (SMP.PHEmpty, AgentConfirmation {e2eEncryption_, encConnInfo, agentVersion}) + | sndSecure -> smpConfirmation srvMsgId conn Nothing e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack + | otherwise -> prohibited "handshake: missing sender key" >> ack (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) -> smpInvitation srvMsgId conn connReq connInfo >> ack _ -> prohibited "handshake: incorrect state" >> ack @@ -2177,7 +2281,6 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) _ -> pure () let encryptedMsgHash = C.sha256Hash encAgentMessage g <- asks random - atomically updateTotalMsgCount tryAgentError (agentClientMsg g encryptedMsgHash) >>= \case Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do conn'' <- resetRatchetSync @@ -2211,7 +2314,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) | otherwise = pure conn' Right Nothing -> prohibited "msg: bad agent msg" >> ack Left e@(AGENT A_DUPLICATE) -> do - atomically updateDupMsgCount + atomically $ incSMPServerStat c userId srv recvDuplicates withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck} | userAck -> ackDel internalId @@ -2224,6 +2327,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) _ -> ack _ -> checkDuplicateHash e encryptedMsgHash >> ack Left (AGENT (A_CRYPTO e)) -> do + atomically $ incSMPServerStat c userId srv recvCryptoErrs exists <- withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash unless exists notifySync ack @@ -2236,26 +2340,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) conn'' = updateConnection cData'' connDuplex notify . RSYNC rss' (Just e) $ connectionStats conn'' withStore' c $ \db -> setConnRatchetSync db connId rss' - Left e -> checkDuplicateHash e encryptedMsgHash >> ack + Left e -> do + atomically $ incSMPServerStat c userId srv recvErrs + checkDuplicateHash e encryptedMsgHash >> ack where checkDuplicateHash :: AgentErrorType -> ByteString -> AM () checkDuplicateHash e encryptedMsgHash = unlessM (withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash) $ throwE e - updateTotalMsgCount :: STM () - updateTotalMsgCount = - TM.lookup connId (msgCounts c) >>= \case - Just v -> modifyTVar' v $ first (+ 1) - Nothing -> addMsgCount 0 - updateDupMsgCount :: STM () - updateDupMsgCount = - TM.lookup connId (msgCounts c) >>= \case - Just v -> modifyTVar' v $ second (+ 1) - Nothing -> addMsgCount 1 - addMsgCount :: Int -> STM () - addMsgCount duplicate = do - counts <- newTVar (1, duplicate) - TM.insert connId counts (msgCounts c) agentClientMsg :: TVar ChaChaDRG -> ByteString -> AM (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448)) agentClientMsg g encryptedMsgHash = withStore c $ \db -> runExceptT $ do rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY @@ -2275,7 +2367,12 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) pure $ Just (internalId, msgMeta, aMessage, rc) _ -> pure Nothing _ -> prohibited "msg: bad client msg" >> ack - _ -> prohibited "msg: no keys" >> ack + (Just e2eDh, Just _) -> + decryptClientMessage e2eDh clientMsg >>= \case + -- this is a repeated confirmation delivery because ack failed to be sent + (_, AgentConfirmation {}) -> ack + _ -> prohibited "msg: public header" >> ack + (Nothing, Nothing) -> prohibited "msg: no keys" >> ack updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c) updateConnVersion conn' cData' msgAgentVersion = do aVRange <- asks $ smpAgentVRange . config @@ -2310,10 +2407,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) r -> unexpected r where notify :: forall e m. (AEntityI e, MonadIO m) => AEvent e -> m () - notify = notify' connId + notify msg = + let t = ("", connId, AEvt (sAEntity @e) msg) + in atomically $ ifM (isFullTBQueue subQ) (modifyTVar' pendingMsgs (t :)) (writeTBQueue subQ t) - prohibited :: String -> AM () - prohibited = notify . ERR . AGENT . A_PROHIBITED + prohibited :: Text -> AM () + prohibited s = do + logError $ "prohibited: " <> s + notify . ERR . AGENT $ A_PROHIBITED $ T.unpack s enqueueCmd :: InternalCommand -> AM () enqueueCmd = enqueueCommand c "" connId (Just srv) . AInternalCommand @@ -2340,7 +2441,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) parseMessage :: Encoding a => ByteString -> AM a parseMessage = liftEither . parse smpP (AGENT A_MESSAGE) - smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () + smpConfirmation :: SMP.MsgId -> Connection c -> Maybe C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> VersionSMPC -> VersionSMPA -> AM () smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config @@ -2363,8 +2464,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) case (agentMsgBody_, skipped) of (Right agentMsgBody, CR.SMDNoChange) -> parseMessage agentMsgBody >>= \case - AgentConnInfoReply smpQueues connInfo -> + AgentConnInfoReply smpQueues connInfo -> do processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion} + withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 where processConf connInfo senderConf = do @@ -2377,14 +2479,21 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) notify $ CONF confId pqSupport' srvs connInfo _ -> prohibited "conf: decrypt error or skipped" -- party accepting connection - (DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do + (DuplexConnection _ (rq'@RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do g <- asks random - withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage . fst >>= \case + (agentMsgBody, pqEncryption) <- withStore c $ \db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo + parseMessage agentMsgBody >>= \case AgentConnInfo connInfo -> do notify $ INFO pqSupport connInfo let dhSecret = C.dh' e2ePubKey e2ePrivKey - withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion - enqueueCmd $ ICDuplexSecure rId senderKey + withStore' c $ \db -> do + setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion + updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) + case senderKey of + Just k -> enqueueCmd $ ICDuplexSecure rId k + Nothing -> do + notify $ CON pqEncryption + withStore' c $ \db -> setRcvQueueStatus db rq' Active _ -> prohibited "conf: not AgentConnInfo" _ -> prohibited "conf: incorrect state" _ -> prohibited "conf: status /= new" @@ -2400,7 +2509,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) -- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO -- this branch is executed by the accepting party in duplexHandshake mode (v2) -- (was executed by initiating party in v1 that is no longer supported) - | sndStatus == Active -> notify $ CON pqEncryption + | sndStatus == Active -> do + atomically $ incSMPServerStat c userId srv connCompleted + notify $ CON pqEncryption | otherwise -> enqueueDuplexHello sq _ -> pure () where @@ -2458,21 +2569,17 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts) let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs case L.nonEmpty keepSqs of Just sqs' -> do - -- move inside case? - sq_@SndQueue {sndPublicKey, e2ePubKey} <- lift $ newSndQueue userId connId qInfo + (sq_@SndQueue {sndPublicKey}, dhPublicKey) <- lift $ newSndQueue userId connId qInfo sq2 <- withStore c $ \db -> do liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} - case (sndPublicKey, e2ePubKey) of - (Just sndPubKey, Just dhPublicKey) -> do - logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) - let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} - void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)] - sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY - let sqs'' = updatedQs sq1 sqs' <> [sq2] - conn' = DuplexConnection cData' rqs sqs'' - notify . SWITCH QDSnd SPStarted $ connectionStats conn' - _ -> qError "absent sender keys" + logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) + let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} + void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPublicKey)] + sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY + let sqs'' = updatedQs sq1 sqs' <> [sq2] + conn' = DuplexConnection cData' rqs sqs'' + notify . SWITCH QDSnd SPStarted $ connectionStats conn' _ -> qError "QADD: won't delete all snd queues in connection" _ -> qError "QADD: replaced queue address is not found in connection" _ -> throwE $ AGENT A_VERSION @@ -2642,23 +2749,30 @@ switchStatusError q expected actual = <> (", expected=" <> show expected) <> (", actual=" <> show actual) -connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> NonEmpty SMPQueueInfo -> AM () -connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = do +connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> Maybe SndQueue -> NonEmpty SMPQueueInfo -> AM () +connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _) = do clientVRange <- asks $ smpClientVRange . config case qInfo `proveCompatible` clientVRange of Nothing -> throwE $ AGENT A_VERSION Just qInfo' -> do - sq <- lift $ newSndQueue userId connId qInfo' - sq' <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq + -- in case of SKEY retry the connection is already duplex + sq' <- maybe upgradeConn pure sq_ + agentSecureSndQueue c sq' enqueueConfirmation c cData sq' ownConnInfo Nothing + where + upgradeConn = do + (sq, _) <- lift $ newSndQueue userId connId qInfo' + withStore c $ \db -> upgradeRcvConnToDuplex db connId sq -confirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () -confirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () +secureConfirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do + agentSecureSndQueue c sq storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation c cData sq srv connInfo subMode lift $ submitPendingMsg c cData sq -confirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () -confirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM () +secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do + agentSecureSndQueue c sq msg <- mkConfirmation =<< mkAgentConfirmation c cData sq srv connInfo subMode void $ sendConfirmation c sq msg withStore' c $ \db -> setSndQueueStatus db sq Confirmed @@ -2667,11 +2781,19 @@ confirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connI mkConfirmation aMessage = do currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config withStore c $ \db -> runExceptT $ do - void . liftIO $ updateSndIds db connId + let agentMsgBody = smpEncode aMessage + (_, internalSndId, _) <- liftIO $ updateSndIds db connId + liftIO $ updateSndMsgHash db connId internalSndId (C.sha256Hash agentMsgBody) let pqEnc = CR.pqSupportToEnc pqSupport - (encConnInfo, _) <- agentRatchetEncrypt db cData (smpEncode aMessage) e2eEncConnInfoLength (Just pqEnc) currentE2EVersion + (encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion pure . smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo} +agentSecureSndQueue :: AgentClient -> SndQueue -> AM () +agentSecureSndQueue c sq@SndQueue {sndSecure, status} = + when (sndSecure && status == New) $ do + secureSndQueue c sq + withStore' c $ \db -> setSndQueueStatus db sq Secured + mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM AgentMessage mkAgentConfirmation c cData sq srv connInfo subMode = do qInfo <- createReplyQueue c cData sq subMode srv @@ -2747,26 +2869,28 @@ agentRatchetDecrypt' g db connId rc encAgentMsg = do liftIO $ updateRatchet db connId rc' skippedDiff liftEither $ bimap (SEAgentError . cryptoError) (,CR.rcRcvKEM rc') agentMsgBody_ -newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' NewSndQueue -newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do +newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' (NewSndQueue, C.PublicKeyX25519) +newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) = do C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g - pure - SndQueue - { userId, - connId, - server = smpServer, - sndId = senderId, - sndPublicKey = Just sndPublicKey, - sndPrivateKey, - e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, - e2ePubKey = Just e2ePubKey, - status = New, - dbQueueId = DBNewQueue, - primary = True, - dbReplaceQueueId = Nothing, - sndSwchStatus = Nothing, - smpClientVersion - } + let sq = + SndQueue + { userId, + connId, + server = smpServer, + sndId = senderId, + sndSecure, + sndPublicKey, + sndPrivateKey, + e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, + e2ePubKey = Just e2ePubKey, + status = New, + dbQueueId = DBNewQueue, + primary = True, + dbReplaceQueueId = Nothing, + sndSwchStatus = Nothing, + smpClientVersion + } + pure (sq, e2ePubKey) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 2ffd6e3a4..0467c31f8 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -52,6 +53,7 @@ module Simplex.Messaging.Agent.Client temporaryOrHostError, serverHostError, secureQueue, + secureSndQueue, enableQueueNotifications, enableQueuesNtfs, disableQueueNotifications, @@ -72,7 +74,6 @@ module Simplex.Messaging.Agent.Client agentXFTPUploadChunk, agentXFTPAddRecipients, agentXFTPDeleteChunk, - agentCbEncrypt, agentCbDecrypt, cryptoError, sendAck, @@ -88,6 +89,11 @@ module Simplex.Messaging.Agent.Client activeClientSession, agentClientStore, agentDRG, + ServerQueueInfo (..), + AgentServersSummary (..), + ServerSessions (..), + SMPServerSubs (..), + getAgentServersSummary, getAgentSubscriptions, slowNetworkConfig, protocolClientError, @@ -99,7 +105,6 @@ module Simplex.Messaging.Agent.Client AgentOpState (..), AgentState (..), AgentLocks (..), - AgentStatsKey (..), getAgentWorker, getAgentWorker', cancelWorker, @@ -135,6 +140,11 @@ module Simplex.Messaging.Agent.Client getNextServer, withUserServers, withNextSrv, + incSMPServerStat, + incSMPServerStat', + incXFTPServerStat, + incXFTPServerStat', + incXFTPServerSizeStat, AgentWorkersDetails (..), getAgentWorkersDetails, AgentWorkersSummary (..), @@ -150,7 +160,7 @@ module Simplex.Messaging.Agent.Client where import Control.Applicative ((<|>)) -import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.Async (Async, uninterruptibleCancel) import Control.Concurrent.STM (retry, throwSTM) import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..)) @@ -164,17 +174,18 @@ import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J import qualified Data.Aeson.TH as J import Data.Bifunctor (bimap, first, second) -import Data.ByteString.Base64 +import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Either (partitionEithers) +import Data.Either (isRight, partitionEithers) import Data.Functor (($>)) +import Data.Int (Int64) import Data.List (deleteFirstsBy, foldl', partition, (\\)) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (isJust, isNothing, listToMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) @@ -196,6 +207,7 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), withTransaction) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -231,6 +243,7 @@ import Simplex.Messaging.Protocol RcvNtfPublicDhKey, SMPMsgMeta (..), SProtocolType (..), + SenderCanSecure, SndPublicAuthKey, SubscriptionMode (..), UserProtocol, @@ -312,10 +325,11 @@ data AgentClient = AgentClient deleteLock :: Lock, -- smpSubWorkers for SMP servers sessions smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())), - agentStats :: TMap AgentStatsKey (TVar Int), - msgCounts :: TMap ConnId (TVar (Int, Int)), -- (total, duplicates) clientId :: Int, - agentEnv :: Env + agentEnv :: Env, + smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats, + xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats, + srvStatsStartedAt :: TVar UTCTime } data SMPConnectedClient = SMPConnectedClient @@ -418,15 +432,6 @@ data AgentLocks = AgentLocks } deriving (Show) -data AgentStatsKey = AgentStatsKey - { userId :: UserId, - host :: ByteString, - clientTs :: ByteString, - cmd :: ByteString, - res :: ByteString - } - deriving (Eq, Ord, Show) - data UserNetworkInfo = UserNetworkInfo { networkType :: UserNetworkType, online :: Bool @@ -443,8 +448,8 @@ 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 -> Env -> STM AgentClient -newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do +newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Env -> STM AgentClient +newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} currentTs agentEnv = do let cfg = config agentEnv qSize = tbqSize cfg acThread <- newTVar Nothing @@ -480,8 +485,9 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = invLocks <- TM.empty deleteLock <- createLock smpSubWorkers <- TM.empty - agentStats <- TM.empty - msgCounts <- TM.empty + smpServersStats <- TM.empty + xftpServersStats <- TM.empty + srvStatsStartedAt <- newTVar currentTs return AgentClient { acThread, @@ -517,10 +523,11 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = invLocks, deleteLock, smpSubWorkers, - agentStats, - msgCounts, clientId, - agentEnv + agentEnv, + smpServersStats, + xftpServersStats, + srvStatsStartedAt } slowNetworkConfig :: NetworkConfig -> NetworkConfig @@ -547,7 +554,6 @@ class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg closeProtocolServerClient :: ProtoClient msg -> IO () clientServer :: ProtoClient msg -> String clientTransportHost :: ProtoClient msg -> TransportHost - clientSessionTs :: ProtoClient msg -> UTCTime instance ProtocolServerClient SMPVersion ErrorType BrokerMsg where type Client BrokerMsg = SMPConnectedClient @@ -558,7 +564,6 @@ instance ProtocolServerClient SMPVersion ErrorType BrokerMsg where closeProtocolServerClient = closeProtocolClient clientServer = protocolClientServer clientTransportHost = transportHost' - clientSessionTs = sessionTs instance ProtocolServerClient NTFVersion ErrorType NtfResponse where type Client NtfResponse = ProtocolClient NTFVersion ErrorType NtfResponse @@ -569,7 +574,6 @@ instance ProtocolServerClient NTFVersion ErrorType NtfResponse where closeProtocolServerClient = closeProtocolClient clientServer = protocolClientServer clientTransportHost = transportHost' - clientSessionTs = sessionTs instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where type Client FileResponse = XFTPClient @@ -580,7 +584,6 @@ instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where closeProtocolServerClient = X.closeXFTPClient clientServer = X.xftpClientServer clientTransportHost = X.xftpTransportHost - clientSessionTs = X.xftpSessionTs getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do @@ -624,14 +627,12 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq >>= either (newProxiedRelay clnt auth) (waitForProxiedRelay tSess) pure (clnt, sess) newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay) - newProxiedRelay clnt@(SMPConnectedClient smp prs) proxyAuth rv = + newProxiedRelay (SMPConnectedClient smp prs) proxyAuth rv = tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp destSrv proxyAuth) >>= \case Right sess -> do atomically $ putTMVar (sessionVar rv) (Right sess) - liftIO $ incClientStat c userId clnt "PROXY" "OK" pure $ Right sess Left e -> do - liftIO $ incClientStat c userId clnt "PROXY" $ bshow e atomically $ do unless (serverHostError e) $ do removeSessVar rv destSrv prs @@ -683,7 +684,6 @@ smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess serverDown :: ([RcvQueue], [ConnId]) -> IO () serverDown (qs, conns) = whenM (readTVarIO active) $ do - incClientStat' c userId client "DISCONNECT" "" notifySub "" $ hostEvent' DISCONNECT client unless (null conns) $ notifySub "" $ DOWN srv conns unless (null qs) $ do @@ -745,7 +745,7 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd) getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient -getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId, srv, _) = do +getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(_, srv, _) = do unlessM (readTVarIO active) $ throwE INACTIVE ts <- liftIO getCurrentTime atomically (getSessVar workerSeq tSess ntfClients ts) @@ -764,12 +764,11 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId, clientDisconnected :: NtfClientVar -> NtfClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess ntfClients - incClientStat c userId client "DISCONNECT" "" atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient -getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId, srv, _) = do +getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(_, srv, _) = do unlessM (readTVarIO active) $ throwE INACTIVE ts <- liftIO getCurrentTime atomically (getSessVar workerSeq tSess xftpClients ts) @@ -788,7 +787,6 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess xftpClients - incClientStat c userId client "DISCONNECT" "" atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv @@ -828,11 +826,9 @@ 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 $ incClientStat c userId client "CLIENT" "OK" atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client) pure client Left e -> do - liftIO $ incServerStat c userId srv "CLIENT" $ bshow e ei <- asks $ persistErrorInterval . config if ei == 0 then atomically $ do @@ -986,46 +982,42 @@ getMapLock locks key = TM.lookup key locks >>= maybe newLock pure where newLock = createLock >>= \l -> TM.insert key l locks $> l -withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> AM a) -> AM a -withClient_ c tSess@(userId, srv, _) statCmd action = do +withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> AM a) -> AM a +withClient_ c tSess@(_, srv, _) action = do cl <- getProtocolServerClient c tSess - (action cl <* stat cl "OK") `catchAgentError` logServerError cl + action cl `catchAgentError` logServerError where - stat cl = liftIO . incClientStat c userId cl statCmd - logServerError :: Client msg -> AgentErrorType -> AM a - logServerError cl e = do + logServerError :: AgentErrorType -> AM a + logServerError e = do logServer "<--" c srv "" $ bshow e - stat cl $ bshow e throwE e withProxySession :: AgentClient -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a -withProxySession c destSess@(userId, destSrv, _) entId cmdStr action = do +withProxySession c destSess@(_, destSrv, _) entId cmdStr action = do (cl, sess_) <- getSMPProxyClient c destSess logServer ("--> " <> proxySrv cl <> " >") c destSrv entId cmdStr case sess_ of Right sess -> do - r <- (action (cl, sess) <* stat cl "OK") `catchAgentError` logServerError cl + r <- action (cl, sess) `catchAgentError` logServerError cl logServer ("<-- " <> proxySrv cl <> " <") c destSrv entId "OK" pure r Left e -> logServerError cl e where - stat cl = liftIO . incClientStat c userId cl cmdStr proxySrv = showServer . protocolClientServer' . protocolClient logServerError :: SMPConnectedClient -> AgentErrorType -> AM a logServerError cl e = do logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e - stat cl $ bshow e throwE e withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do logServer "-->" c srv entId cmdStr - res <- withClient_ c tSess cmdStr action + res <- withClient_ c tSess action logServer "<--" c srv entId "OK" return res -withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a -withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client +withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a +withClient c tSess action = withClient_ c tSess $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client {-# INLINE withClient #-} withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a @@ -1038,7 +1030,27 @@ withSMPClient c q cmdStr action = do withLogClient c tSess (queueId q) cmdStr $ action . connectedClient sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) -sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = do +sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = + sendOrProxySMPCommand c userId destSrv cmdStr senderId sendViaProxy sendDirectly + where + sendViaProxy smp proxySess = do + atomically $ incSMPServerStat c userId destSrv sentViaProxyAttempts + atomically $ incSMPServerStat c userId (protocolClientServer' smp) sentProxiedAttempts + proxySMPMessage smp proxySess spKey_ senderId msgFlags msg + sendDirectly smp = do + atomically $ incSMPServerStat c userId destSrv sentDirectAttempts + sendSMPMessage smp spKey_ senderId msgFlags msg + +sendOrProxySMPCommand :: + AgentClient -> + UserId -> + SMPServer -> + ByteString -> + SMP.SenderId -> + (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) -> + (SMPClient -> ExceptT SMPClientError IO ()) -> + AM (Maybe SMPServer) +sendOrProxySMPCommand c userId destSrv cmdStr senderId sendCmdViaProxy sendCmdDirectly = do sess <- liftIO $ mkTransportSession c userId destSrv senderId ifM (atomically shouldUseProxy) (sendViaProxy sess) (sendDirectly sess $> Nothing) where @@ -1060,7 +1072,8 @@ sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = do unknownServer = maybe True (all ((destSrv /=) . protoServer)) <$> TM.lookup userId (userServers c) sendViaProxy destSess@(_, _, qId) = do r <- tryAgentError . withProxySession c destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess) -> do - liftClient SMP (clientServer smp) (proxySMPMessage smp proxySess spKey_ senderId msgFlags msg) >>= \case + r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess + case r' of Right () -> pure . Just $ protocolClientServer' smp Left proxyErr -> do case proxyErr of @@ -1088,13 +1101,19 @@ sendOrProxySMPMessage c userId destSrv cmdStr spKey_ senderId msgFlags msg = do sameClient smp' = sessionId (thParams smp) == sessionId (thParams smp') sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess' case r of - Right r' -> pure r' + Right r' -> do + atomically $ incSMPServerStat c userId destSrv sentViaProxy + forM_ r' $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied + pure r' Left e | serverHostError e -> ifM (atomically directAllowed) (sendDirectly destSess $> Nothing) (throwE e) | otherwise -> throwE e sendDirectly tSess = - withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> - liftClient SMP (clientServer smp) $ sendSMPMessage smp spKey_ senderId msgFlags msg + withLogClient_ c tSess senderId ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do + r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp + case r of + Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect + Left e -> throwE e ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts _ _) = do @@ -1164,11 +1183,14 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g - (sKey, _) <- atomically $ C.generateAuthKeyPair sa g + (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe - liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey + SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True + liftError (testErr TSSecureQueue) $ + if sndSecure + then secureSndSMPQueue smp spKey sndId sKey + else secureSMPQueue smp rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok @@ -1203,7 +1225,6 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId ok <- tcpTimeout xftpNetworkConfig `timeout` X.closeXFTPClient xftp - incClientStat c userId xftp "XFTP_TEST" "OK" pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1242,7 +1263,6 @@ runNTFServerTest c userId (ProtoServerWithAuth srv _) = do (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf npKey (NewNtfTkn deviceToken nKey dhKey) liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf npKey tknId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient ntf - incClientStat c userId ntf "NTF_TEST" "OK" pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1275,8 +1295,8 @@ getSessionMode :: AgentClient -> IO TransportSessionMode getSessionMode = atomically . fmap sessionMode . getNetworkConfig {-# INLINE getSessionMode #-} -newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) -newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do +newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g @@ -1284,9 +1304,9 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g logServer "-->" c srv "" "NEW" tSess <- liftIO $ mkTransportSession c userId srv connId - (sessId, QIK {rcvId, sndId, rcvPublicDhKey}) <- - withClient c tSess "NEW" $ \(SMPConnectedClient smp _) -> - (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode + (sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <- + withClient c tSess $ \(SMPConnectedClient smp _) -> + (sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure liftIO . logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue @@ -1299,6 +1319,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do e2ePrivKey, e2eDhSecret = Nothing, sndId, + sndSecure, status = New, dbQueueId = DBNewQueue, primary = True, @@ -1308,17 +1329,20 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do clientNtfCreds = Nothing, deleteErrors = 0 } - qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey + qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure pure (rq, qUri, tSess, sessId) processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> STM () -processSubResult c rq@RcvQueue {connId} = \case +processSubResult c rq@RcvQueue {userId, server, connId} = \case Left e -> - unless (temporaryClientError e) $ + unless (temporaryClientError e) $ do + incSMPServerStat c userId server connSubErrs failSubscription c rq e Right () -> - whenM (hasPendingSubscription c connId) $ - addSubscription c rq + ifM + (hasPendingSubscription c connId) + (incSMPServerStat c userId server connSubscribed >> addSubscription c rq) + (incSMPServerStat c userId server connSubIgnored) temporaryAgentError :: AgentErrorType -> Bool temporaryAgentError = \case @@ -1361,7 +1385,7 @@ subscribeQueues c qs = do env <- ask -- only "checked" queues are subscribed session <- newTVarIO Nothing - rs <- sendTSessionBatches "SUB" 90 id (subscribeQueues_ env session) c qs' + rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c qs' (errs <> rs,) <$> readTVarIO session where checkQueue rq = do @@ -1369,13 +1393,15 @@ subscribeQueues c qs = do pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) subscribeQueues_ env session smp qs' = do + let (userId, srv, _) = transportSession' smp + atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs' rs <- sendBatch subscribeSMPQueues smp qs' active <- atomically $ ifM (activeClientSession c tSess sessId) (writeTVar session (Just sessId) >> processSubResults rs $> True) - (pure False) + (incSMPServerStat' c userId srv connSubIgnored (length rs) $> False) if active then when (hasTempErrors rs) resubscribe $> rs else do @@ -1398,9 +1424,8 @@ activeClientSession c tSess sessId = sameSess <$> tryReadSessVar tSess (smpClien type BatchResponses e r = NonEmpty (RcvQueue, Either e r) --- statBatchSize is not used to batch the commands, only for traffic statistics -sendTSessionBatches :: forall q r. ByteString -> Int -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)] -sendTSessionBatches statCmd statBatchSize toRQ action c qs = +sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses SMPClientError r)) -> AgentClient -> [q] -> AM' [(RcvQueue, Either AgentErrorType r)] +sendTSessionBatches statCmd toRQ action c qs = concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues) where batchQueues :: AM' [(SMPTransportSession, NonEmpty q)] @@ -1412,19 +1437,14 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs = let tSess = mkSMPTSession (toRQ q) mode in M.alter (Just . maybe [q] (q <|)) tSess m sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses AgentErrorType r) - sendClientBatch (tSess@(userId, srv, _), qs') = + sendClientBatch (tSess@(_, srv, _), qs') = tryAgentError' (getSMPServerClient c tSess) >>= \case Left e -> pure $ L.map ((,Left e) . toRQ) qs' Right (SMPConnectedClient smp _) -> liftIO $ do logServer "-->" c srv (bshow (length qs') <> " queues") statCmd - rs <- L.map agentError <$> action smp qs' - statBatch - pure rs + L.map agentError <$> action smp qs' where agentError = second . first $ protocolClientError SMP $ clientServer smp - statBatch = - let n = (length qs - 1) `div` statBatchSize + 1 - in incClientStatN c userId smp n statCmd "OK" sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs) @@ -1486,14 +1506,15 @@ showServer ProtocolServer {host, port} = {-# INLINE showServer #-} logSecret :: ByteString -> ByteString -logSecret bs = encode $ B.take 3 bs +logSecret bs = B64.encode $ B.take 3 bs {-# INLINE logSecret #-} sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer) -sendConfirmation c sq@SndQueue {userId, server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do - let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation +sendConfirmation c sq@SndQueue {userId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do + let (privHdr, spKey) = if sndSecure then (SMP.PHEmpty, Just sndPrivateKey) else (SMP.PHConfirmation sndPublicKey, Nothing) + clientMsg = SMP.ClientMessage privHdr agentConfirmation msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg - sendOrProxySMPMessage c userId server "" Nothing sndId (MsgFlags {notification = True}) msg + sendOrProxySMPMessage c userId server "" spKey sndId (MsgFlags {notification = True}) msg sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" sendInvitation :: AgentClient -> UserId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer) @@ -1534,13 +1555,21 @@ secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = withSMPClient c rq "KEY " $ \smp -> secureSMPQueue smp rcvPrivateKey rcvId senderKey +secureSndQueue :: AgentClient -> SndQueue -> AM () +secureSndQueue c SndQueue {userId, server, sndId, sndPrivateKey, sndPublicKey} = + void $ sendOrProxySMPCommand c userId server "SKEY " sndId secureViaProxy secureDirectly + where + -- TODO track statistics + secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey + secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey + enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey) enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = withSMPClient c rq "NKEY " $ \smp -> enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey enableQueuesNtfs :: AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> AM' [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))] -enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_ +enableQueuesNtfs = sendTSessionBatches "NKEY" fst3 enableQueues_ where fst3 (x, _, _) = x enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey))) @@ -1554,7 +1583,7 @@ disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} = disableSMPQueueNotifications smp rcvPrivateKey rcvId disableQueuesNtfs :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())] -disableQueuesNtfs = sendTSessionBatches "NDEL" 90 id $ sendBatch disableSMPQueuesNtfs +disableQueuesNtfs = sendTSessionBatches "NDEL" id $ sendBatch disableSMPQueuesNtfs sendAck :: AgentClient -> RcvQueue -> MsgId -> AM () sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = do @@ -1581,7 +1610,15 @@ deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do deleteSMPQueue smp rcvPrivateKey rcvId deleteQueues :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())] -deleteQueues = sendTSessionBatches "DEL" 90 id $ sendBatch deleteSMPQueues +deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c + where + deleteQueues_ smp rqs = do + let (userId, srv, _) = transportSession' smp + atomically $ incSMPServerStat' c userId srv connDelAttempts $ length rqs + rs <- sendBatch deleteSMPQueues smp rqs + let successes = foldl' (\n (_, r) -> if isRight r then n + 1 else n) 0 rs + atomically $ incSMPServerStat' c userId srv connDeleted successes + pure rs sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer) sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags agentMsg = do @@ -1589,14 +1626,28 @@ sendAgentMessage c sq@SndQueue {userId, server, sndId, sndPrivateKey} msgFlags a msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg sendOrProxySMPMessage c userId server "" (Just sndPrivateKey) sndId msgFlags msg -getQueueInfo :: AgentClient -> RcvQueue -> AM QueueInfo -getQueueInfo c rq@RcvQueue {rcvId, rcvPrivateKey} = - withSMPClient c rq "QUE" $ \smp -> - getSMPQueueInfo smp rcvPrivateKey rcvId +data ServerQueueInfo = ServerQueueInfo + { server :: SMPServer, + rcvId :: Text, + sndId :: Text, + ntfId :: Maybe Text, + status :: Text, + info :: QueueInfo + } + deriving (Show) + +getQueueInfo :: AgentClient -> RcvQueue -> AM ServerQueueInfo +getQueueInfo c rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} = + withSMPClient c rq "QUE" $ \smp -> do + info <- getSMPQueueInfo smp rcvPrivateKey rcvId + let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds + pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info} + where + enc = decodeLatin1 . B64.encode agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519) agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = - withClient c (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) + withClient c (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) agentNtfVerifyToken :: AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> AM () agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code = @@ -1642,7 +1693,7 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv "" "FNEW" tSess <- liftIO $ mkTransportSession c userId srv chunkDigest - (sndId, rIds) <- withClient c tSess "FNEW" $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth + (sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth logServer "<--" c srv "" $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} @@ -1853,33 +1904,6 @@ storeError = \case SEDatabaseBusy e -> CRITICAL True $ B.unpack e e -> INTERNAL $ show e -incStat :: AgentClient -> Int -> AgentStatsKey -> STM () -incStat AgentClient {agentStats} n k = do - TM.lookup k agentStats >>= \case - Just v -> modifyTVar' v (+ n) - _ -> newTVar n >>= \v -> TM.insert k v agentStats - -incClientStat :: ProtocolServerClient v err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO () -incClientStat c userId = incClientStat' c userId . protocolClient -{-# INLINE incClientStat #-} - -incClientStat' :: ProtocolServerClient v err msg => AgentClient -> UserId -> ProtoClient msg -> ByteString -> ByteString -> IO () -incClientStat' c userId pc = incClientStatN c userId pc 1 -{-# INLINE incClientStat' #-} - -incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO () -incServerStat c userId ProtocolServer {host} cmd res = do - threadDelay 100000 - atomically $ incStat c 1 statsKey - where - statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res} - -incClientStatN :: ProtocolServerClient v err msg => AgentClient -> UserId -> ProtoClient msg -> Int -> ByteString -> ByteString -> IO () -incClientStatN c userId pc n cmd res = do - atomically $ incStat c n statsKey - where - statsKey = AgentStatsKey {userId, host = strEncode $ clientTransportHost pc, clientTs = strEncode $ clientSessionTs pc, cmd, res} - userServers :: forall p. (ProtocolTypeI p, UserProtocol p) => AgentClient -> TMap UserId (NonEmpty (ProtoServerWithAuth p)) userServers c = case protocolTypeI @p of SPSMP -> smpServers c @@ -1916,6 +1940,115 @@ withNextSrv c userId usedSrvs initUsed action = do writeTVar usedSrvs $! used' action srvAuth +incSMPServerStat :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> STM () +incSMPServerStat c userId srv sel = incSMPServerStat' c userId srv sel 1 + +incSMPServerStat' :: AgentClient -> UserId -> SMPServer -> (AgentSMPServerStats -> TVar Int) -> Int -> STM () +incSMPServerStat' AgentClient {smpServersStats} userId srv sel n = do + TM.lookup (userId, srv) smpServersStats >>= \case + Just v -> modifyTVar' (sel v) (+ n) + Nothing -> do + newStats <- newAgentSMPServerStats + modifyTVar' (sel newStats) (+ n) + TM.insert (userId, srv) newStats smpServersStats + +incXFTPServerStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> STM () +incXFTPServerStat c userId srv sel = incXFTPServerStat_ c userId srv sel 1 +{-# INLINE incXFTPServerStat #-} + +incXFTPServerStat' :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int) -> Int -> STM () +incXFTPServerStat' = incXFTPServerStat_ +{-# INLINE incXFTPServerStat' #-} + +incXFTPServerSizeStat :: AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar Int64) -> Int64 -> STM () +incXFTPServerSizeStat = incXFTPServerStat_ +{-# INLINE incXFTPServerSizeStat #-} + +incXFTPServerStat_ :: Num n => AgentClient -> UserId -> XFTPServer -> (AgentXFTPServerStats -> TVar n) -> n -> STM () +incXFTPServerStat_ AgentClient {xftpServersStats} userId srv sel n = do + TM.lookup (userId, srv) xftpServersStats >>= \case + Just v -> modifyTVar' (sel v) (+ n) + Nothing -> do + newStats <- newAgentXFTPServerStats + modifyTVar' (sel newStats) (+ n) + TM.insert (userId, srv) newStats xftpServersStats + +data AgentServersSummary = AgentServersSummary + { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData, + xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData, + statsStartedAt :: UTCTime, + smpServersSessions :: Map (UserId, SMPServer) ServerSessions, + smpServersSubs :: Map (UserId, SMPServer) SMPServerSubs, + xftpServersSessions :: Map (UserId, XFTPServer) ServerSessions, + xftpRcvInProgress :: [XFTPServer], + xftpSndInProgress :: [XFTPServer], + xftpDelInProgress :: [XFTPServer] + } + deriving (Show) + +data SMPServerSubs = SMPServerSubs + { ssActive :: Int, -- based on activeSubs + ssPending :: Int -- based on pendingSubs + } + deriving (Show) + +data ServerSessions = ServerSessions + { ssConnected :: Int, + ssErrors :: Int, + ssConnecting :: Int + } + deriving (Show) + +getAgentServersSummary :: AgentClient -> IO AgentServersSummary +getAgentServersSummary c@AgentClient {smpServersStats, xftpServersStats, srvStatsStartedAt, agentEnv} = do + sss <- mapM getAgentSMPServerStats =<< readTVarIO smpServersStats + xss <- mapM getAgentXFTPServerStats =<< readTVarIO xftpServersStats + statsStartedAt <- readTVarIO srvStatsStartedAt + smpServersSessions <- countSessions =<< readTVarIO (smpClients c) + smpServersSubs <- getServerSubs + xftpServersSessions <- countSessions =<< readTVarIO (xftpClients c) + xftpRcvInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpRcvWorkers + xftpSndInProgress <- catMaybes <$> getXFTPWorkerSrvs xftpSndWorkers + xftpDelInProgress <- getXFTPWorkerSrvs xftpDelWorkers + pure + AgentServersSummary + { smpServersStats = sss, + xftpServersStats = xss, + statsStartedAt, + smpServersSessions, + smpServersSubs, + xftpServersSessions, + xftpRcvInProgress, + xftpSndInProgress, + xftpDelInProgress + } + where + getServerSubs = do + subs <- M.foldrWithKey' (addSub incActive) M.empty <$> readTVarIO (getRcvQueues $ activeSubs c) + M.foldrWithKey' (addSub incPending) subs <$> readTVarIO (getRcvQueues $ pendingSubs c) + where + addSub f (userId, srv, _) _ = M.alter (Just . f . fromMaybe SMPServerSubs {ssActive = 0, ssPending = 0}) (userId, srv) + incActive ss = ss {ssActive = ssActive ss + 1} + incPending ss = ss {ssPending = ssPending ss + 1} + Env {xftpAgent = XFTPAgent {xftpRcvWorkers, xftpSndWorkers, xftpDelWorkers}} = agentEnv + getXFTPWorkerSrvs workers = foldM addSrv [] . M.toList =<< readTVarIO workers + where + addSrv acc (srv, Worker {doWork}) = do + hasWork <- atomically $ not <$> isEmptyTMVar doWork + pure $ if hasWork then srv : acc else acc + countSessions :: Map (TransportSession msg) (ClientVar msg) -> IO (Map (UserId, ProtoServer msg) ServerSessions) + countSessions = foldM addClient M.empty . M.toList + where + addClient !acc ((userId, srv, _), SessionVar {sessionVar}) = do + c_ <- atomically $ tryReadTMVar sessionVar + pure $ M.alter (Just . add c_) (userId, srv) acc + where + add c_ = modifySessions c_ . fromMaybe ServerSessions {ssConnected = 0, ssErrors = 0, ssConnecting = 0} + modifySessions c_ ss = case c_ of + Just (Right _) -> ss {ssConnected = ssConnected ss + 1} + Just (Left _) -> ss {ssErrors = ssErrors ss + 1} + Nothing -> ss {ssConnecting = ssConnecting ss + 1} + data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text, subError :: Maybe String} deriving (Show) @@ -2106,6 +2239,12 @@ $(J.deriveJSON (enumJSON $ dropPrefix "TS") ''ProtocolTestStep) $(J.deriveJSON defaultJSON ''ProtocolTestFailure) +$(J.deriveJSON defaultJSON ''ServerSessions) + +$(J.deriveJSON defaultJSON ''SMPServerSubs) + +$(J.deriveJSON defaultJSON ''AgentServersSummary) + $(J.deriveJSON defaultJSON ''SubInfo) $(J.deriveJSON defaultJSON ''SubscriptionsInfo) @@ -2125,3 +2264,5 @@ $(J.deriveJSON defaultJSON ''AgentQueuesInfo) $(J.deriveJSON (enumJSON $ dropPrefix "UN") ''UserNetworkType) $(J.deriveJSON defaultJSON ''UserNetworkInfo) + +$(J.deriveJSON defaultJSON ''ServerQueueInfo) diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index ee2bb16cc..2ae2ad5c0 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -100,6 +100,8 @@ data AgentConfig = AgentConfig persistErrorInterval :: NominalDiffTime, initialCleanupDelay :: Int64, cleanupInterval :: Int64, + initialLogStatsDelay :: Int64, + logStatsInterval :: Int64, cleanupStepInterval :: Int, maxWorkerRestartsPerMin :: Int, storedMsgDataTTL :: NominalDiffTime, @@ -170,6 +172,8 @@ defaultAgentConfig = persistErrorInterval = 3, -- seconds initialCleanupDelay = 30 * 1000000, -- 30 seconds cleanupInterval = 30 * 60 * 1000000, -- 30 minutes + initialLogStatsDelay = 10 * 1000000, -- 10 seconds + logStatsInterval = 10 * 1000000, -- 10 seconds cleanupStepInterval = 200000, -- 200ms maxWorkerRestartsPerMin = 5, storedMsgDataTTL = 21 * nominalDay, diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index d6bbc13ca..b123fc1ec 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Protocol ratchetSyncSMPAgentVersion, deliveryRcptsSMPAgentVersion, pqdrSMPAgentVersion, + sndAuthKeySMPAgentVersion, currentSMPAgentVersion, supportedSMPAgentVRange, e2eEncConnInfoLength, @@ -208,6 +209,7 @@ import Simplex.Messaging.Protocol legacyStrEncodeServer, noAuthSrv, sameSrvAddr, + sndAuthKeySMPClientVersion, srvHostnamesSMPClientVersion, pattern ProtoServerWithAuth, pattern SMPServer, @@ -227,6 +229,7 @@ import UnliftIO.Exception (Exception) -- 3 - support ratchet renegotiation (6/30/2023) -- 4 - delivery receipts (7/13/2023) -- 5 - post-quantum double ratchet (3/14/2024) +-- 6 - secure reply queues with provided keys (6/14/2024) data SMPAgentVersion @@ -251,11 +254,17 @@ deliveryRcptsSMPAgentVersion = VersionSMPA 4 pqdrSMPAgentVersion :: VersionSMPA pqdrSMPAgentVersion = VersionSMPA 5 +sndAuthKeySMPAgentVersion :: VersionSMPA +sndAuthKeySMPAgentVersion = VersionSMPA 6 + +minSupportedSMPAgentVersion :: VersionSMPA +minSupportedSMPAgentVersion = duplexHandshakeSMPAgentVersion + currentSMPAgentVersion :: VersionSMPA -currentSMPAgentVersion = VersionSMPA 5 +currentSMPAgentVersion = VersionSMPA 6 supportedSMPAgentVRange :: VersionRangeSMPA -supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentSMPAgentVersion +supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPAgentVersion -- it is shorter to allow all handshake headers, -- including E2E (double-ratchet) parameters and @@ -685,7 +694,7 @@ data MsgMeta = MsgMeta data SMPConfirmation = SMPConfirmation { -- | sender's public key to use for authentication of sender's commands at the recepient's server - senderKey :: SndPublicAuthKey, + senderKey :: Maybe SndPublicAuthKey, -- | sender's DH public key for simple per-queue e2e encryption e2ePubKey :: C.PublicKeyX25519, -- | sender's information to be associated with the connection, e.g. sender's profile information @@ -775,12 +784,12 @@ instance Encoding AgentMessage where 'M' -> AgentMessage <$> smpP <*> smpP _ -> fail "bad AgentMessage" +-- internal type for storing message type in the database data AgentMessageType = AM_CONN_INFO | AM_CONN_INFO_REPLY | AM_RATCHET_INFO | AM_HELLO_ - | AM_REPLY_ | AM_A_MSG_ | AM_A_RCVD_ | AM_QCONT_ @@ -797,7 +806,6 @@ instance Encoding AgentMessageType where AM_CONN_INFO_REPLY -> "D" AM_RATCHET_INFO -> "S" AM_HELLO_ -> "H" - AM_REPLY_ -> "R" AM_A_MSG_ -> "M" AM_A_RCVD_ -> "V" AM_QCONT_ -> "QC" @@ -812,7 +820,6 @@ instance Encoding AgentMessageType where 'D' -> pure AM_CONN_INFO_REPLY 'S' -> pure AM_RATCHET_INFO 'H' -> pure AM_HELLO_ - 'R' -> pure AM_REPLY_ 'M' -> pure AM_A_MSG_ 'V' -> pure AM_A_RCVD_ 'Q' -> @@ -1004,7 +1011,8 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where where queryStr = strEncode . QSP QEscape $ - [("v", strEncode crAgentVRange), ("smp", strEncode crSmpQueues)] + -- semicolon is used to separate SMP queues because comma is used to separate server address hostnames + [("v", strEncode crAgentVRange), ("smp", B.intercalate ";" $ map strEncode $ L.toList crSmpQueues)] <> maybe [] (\e2e -> [("e2e", strEncode e2e)]) e2eParams <> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData strP = connReqUriP' (Just SSSimplex) @@ -1026,7 +1034,7 @@ connReqUriP overrideScheme = do crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?" query <- strP aVRange <- queryParam "v" query - crSmpQueues <- queryParam "smp" query + crSmpQueues <- queryParamParser queuesP "smp" query let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query crData = ConnReqUriData {crScheme, crAgentVRange = aVRange, crSmpQueues, crClientData} case crMode of @@ -1038,8 +1046,10 @@ connReqUriP overrideScheme = do CMContact -> pure . ACR SCMContact $ CRContactUri crData {crAgentVRange = adjustAgentVRange aVRange} where crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact + -- semicolon is used to separate SMP queues because comma is used to separate server address hostnames + queuesP = L.fromList <$> (strDecode <$?> A.takeTill (== ';')) `A.sepBy1'` A.char ';' adjustAgentVRange vr = - let v = max duplexHandshakeSMPAgentVersion $ minVersion vr + let v = max minSupportedSMPAgentVersion $ minVersion vr in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr) instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where @@ -1117,14 +1127,16 @@ data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress :: deriving (Eq, Show) instance Encoding SMPQueueInfo where - smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey}) + smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) + | clientVersion >= sndAuthKeySMPClientVersion && sndSecure = smpEncode (clientVersion, smpServer, senderId, dhPublicKey, sndSecure) | clientVersion > initialSMPClientVersion = smpEncode (clientVersion, smpServer, senderId, dhPublicKey) | otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey) smpP = do clientVersion <- smpP smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP (senderId, dhPublicKey) <- smpP - pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey} + sndSecure <- fromMaybe False <$> optional smpP + pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} -- This instance seems contrived and there was a temptation to split a common part of both types. -- But this is created to allow backward and forward compatibility where SMPQueueUri @@ -1150,7 +1162,8 @@ data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRangeSMPC, queueAddress : data SMPQueueAddress = SMPQueueAddress { smpServer :: SMPServer, senderId :: SMP.SenderId, - dhPublicKey :: C.PublicKeyX25519 + dhPublicKey :: C.PublicKeyX25519, + sndSecure :: Bool } deriving (Eq, Show) @@ -1177,37 +1190,42 @@ sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId' {-# INLINE sameQAddress #-} instance StrEncoding SMPQueueUri where - strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey}) + strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, sndSecure}) | minVersion vr >= srvHostnamesSMPClientVersion = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams | otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam) where query = strEncode . QSP QEscape - queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] + queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> [("k", "s") | sndSecure] srvParam = [("srv", strEncode $ TransportHosts_ hs) | not (null hs)] hs = L.tail $ host srv strP = do srv@ProtocolServer {host = h :| host} <- strP <* A.char '/' senderId <- strP <* optional (A.char '/') <* A.char '#' - (vr, hs, dhPublicKey) <- unversioned <|> versioned + (vr, hs, dhPublicKey, sndSecure) <- versioned <|> unversioned let srv' = srv {host = h :| host <> hs} smpServer = if maxVersion vr < srvHostnamesSMPClientVersion then updateSMPServerHosts srv' else srv' - pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey} + pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} where - unversioned = (versionToRange initialSMPClientVersion,[],) <$> strP <* A.endOfInput + unversioned = (versionToRange initialSMPClientVersion,[],,False) <$> strP <* A.endOfInput versioned = do dhKey_ <- optional strP query <- optional (A.char '/') *> A.char '?' *> strP vr <- queryParam "v" query dhKey <- maybe (queryParam "dh" query) pure dhKey_ hs_ <- queryParam_ "srv" query - pure (vr, maybe [] thList_ hs_, dhKey) + let sndSecure = queryParamStr "k" query == Just "s" + pure (vr, maybe [] thList_ hs_, dhKey, sndSecure) instance Encoding SMPQueueUri where - smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}) = - smpEncode (clientVRange, smpServer, senderId, dhPublicKey) + smpEncode (SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure}) + | maxVersion clientVRange >= sndAuthKeySMPClientVersion && sndSecure = + smpEncode (clientVRange, smpServer, senderId, dhPublicKey, sndSecure) + | otherwise = + smpEncode (clientVRange, smpServer, senderId, dhPublicKey) smpP = do (clientVRange, smpServer, senderId, dhPublicKey) <- smpP - pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey} + sndSecure <- fromMaybe False <$> optional smpP + pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, sndSecure} data ConnectionRequestUri (m :: ConnectionMode) where CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation diff --git a/src/Simplex/Messaging/Agent/QueryString.hs b/src/Simplex/Messaging/Agent/QueryString.hs index fee552a01..9dc0e94a9 100644 --- a/src/Simplex/Messaging/Agent/QueryString.hs +++ b/src/Simplex/Messaging/Agent/QueryString.hs @@ -24,9 +24,12 @@ instance StrEncoding QueryStringParams where strP = QSP QEscape . Q.parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n') queryParam :: StrEncoding a => ByteString -> QueryStringParams -> Parser a -queryParam name q = +queryParam = queryParamParser strP + +queryParamParser :: Parser a -> ByteString -> QueryStringParams -> Parser a +queryParamParser p name q = case queryParamStr name q of - Just p -> either fail pure $ parseAll strP p + Just s -> either fail pure $ parseAll p s _ -> fail $ "no qs param " <> B.unpack name queryParam_ :: StrEncoding a => ByteString -> QueryStringParams -> Parser (Maybe a) diff --git a/src/Simplex/Messaging/Agent/Stats.hs b/src/Simplex/Messaging/Agent/Stats.hs new file mode 100644 index 000000000..424052d74 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Stats.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Agent.Stats where + +import qualified Data.Aeson.TH as J +import Data.Int (Int64) +import Data.Map (Map) +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import Simplex.Messaging.Agent.Protocol (UserId) +import Simplex.Messaging.Parsers (defaultJSON, fromTextField_) +import Simplex.Messaging.Protocol (SMPServer, XFTPServer) +import Simplex.Messaging.Util (decodeJSON, encodeJSON) +import UnliftIO.STM + +data AgentSMPServerStats = AgentSMPServerStats + { sentDirect :: TVar Int, -- successfully sent messages + sentViaProxy :: TVar Int, -- successfully sent messages via proxy + sentProxied :: TVar Int, -- successfully sent messages to other destination server via this as proxy + sentDirectAttempts :: TVar Int, -- direct sending attempts (min 1 for each sent message) + sentViaProxyAttempts :: TVar Int, -- proxy sending attempts + sentProxiedAttempts :: TVar Int, -- attempts sending to other destination server via this as proxy + sentAuthErrs :: TVar Int, -- send AUTH errors + sentQuotaErrs :: TVar Int, -- send QUOTA permanent errors (message expired) + sentExpiredErrs :: TVar Int, -- send expired errors + sentOtherErrs :: TVar Int, -- other send permanent errors (excluding above) + recvMsgs :: TVar Int, -- total messages received + recvDuplicates :: TVar Int, -- duplicate messages received + recvCryptoErrs :: TVar Int, -- message decryption errors + recvErrs :: TVar Int, -- receive errors + ackMsgs :: TVar Int, -- total messages acknowledged + ackAttempts :: TVar Int, -- acknowledgement attempts + ackNoMsgErrs :: TVar Int, -- NO_MSG ack errors + ackOtherErrs :: TVar Int, -- other permanent ack errors (temporary accounted for in attempts) + -- conn stats are accounted for rcv queue server + connCreated :: TVar Int, -- total connections created + connSecured :: TVar Int, -- connections secured + connCompleted :: TVar Int, -- connections completed + connDeleted :: TVar Int, -- total connections deleted + connDelAttempts :: TVar Int, -- total connection deletion attempts + connDelErrs :: TVar Int, -- permanent connection deletion errors (temporary accounted for in attempts) + connSubscribed :: TVar Int, -- total successful subscription + connSubAttempts :: TVar Int, -- subscription attempts + connSubIgnored :: TVar Int, -- subscription results ignored (client switched to different session or it was not pending) + connSubErrs :: TVar Int -- permanent subscription errors (temporary accounted for in attempts) + } + +data AgentSMPServerStatsData = AgentSMPServerStatsData + { _sentDirect :: Int, + _sentViaProxy :: Int, + _sentProxied :: Int, + _sentDirectAttempts :: Int, + _sentViaProxyAttempts :: Int, + _sentProxiedAttempts :: Int, + _sentAuthErrs :: Int, + _sentQuotaErrs :: Int, + _sentExpiredErrs :: Int, + _sentOtherErrs :: Int, + _recvMsgs :: Int, + _recvDuplicates :: Int, + _recvCryptoErrs :: Int, + _recvErrs :: Int, + _ackMsgs :: Int, + _ackAttempts :: Int, + _ackNoMsgErrs :: Int, + _ackOtherErrs :: Int, + _connCreated :: Int, + _connSecured :: Int, + _connCompleted :: Int, + _connDeleted :: Int, + _connDelAttempts :: Int, + _connDelErrs :: Int, + _connSubscribed :: Int, + _connSubAttempts :: Int, + _connSubIgnored :: Int, + _connSubErrs :: Int + } + deriving (Show) + +newAgentSMPServerStats :: STM AgentSMPServerStats +newAgentSMPServerStats = do + sentDirect <- newTVar 0 + sentViaProxy <- newTVar 0 + sentProxied <- newTVar 0 + sentDirectAttempts <- newTVar 0 + sentViaProxyAttempts <- newTVar 0 + sentProxiedAttempts <- newTVar 0 + sentAuthErrs <- newTVar 0 + sentQuotaErrs <- newTVar 0 + sentExpiredErrs <- newTVar 0 + sentOtherErrs <- newTVar 0 + recvMsgs <- newTVar 0 + recvDuplicates <- newTVar 0 + recvCryptoErrs <- newTVar 0 + recvErrs <- newTVar 0 + ackMsgs <- newTVar 0 + ackAttempts <- newTVar 0 + ackNoMsgErrs <- newTVar 0 + ackOtherErrs <- newTVar 0 + connCreated <- newTVar 0 + connSecured <- newTVar 0 + connCompleted <- newTVar 0 + connDeleted <- newTVar 0 + connDelAttempts <- newTVar 0 + connDelErrs <- newTVar 0 + connSubscribed <- newTVar 0 + connSubAttempts <- newTVar 0 + connSubIgnored <- newTVar 0 + connSubErrs <- newTVar 0 + pure + AgentSMPServerStats + { sentDirect, + sentViaProxy, + sentProxied, + sentDirectAttempts, + sentViaProxyAttempts, + sentProxiedAttempts, + sentAuthErrs, + sentQuotaErrs, + sentExpiredErrs, + sentOtherErrs, + recvMsgs, + recvDuplicates, + recvCryptoErrs, + recvErrs, + ackMsgs, + ackAttempts, + ackNoMsgErrs, + ackOtherErrs, + connCreated, + connSecured, + connCompleted, + connDeleted, + connDelAttempts, + connDelErrs, + connSubscribed, + connSubAttempts, + connSubIgnored, + connSubErrs + } + +newAgentSMPServerStatsData :: AgentSMPServerStatsData +newAgentSMPServerStatsData = + AgentSMPServerStatsData + { _sentDirect = 0, + _sentViaProxy = 0, + _sentProxied = 0, + _sentDirectAttempts = 0, + _sentViaProxyAttempts = 0, + _sentProxiedAttempts = 0, + _sentAuthErrs = 0, + _sentQuotaErrs = 0, + _sentExpiredErrs = 0, + _sentOtherErrs = 0, + _recvMsgs = 0, + _recvDuplicates = 0, + _recvCryptoErrs = 0, + _recvErrs = 0, + _ackMsgs = 0, + _ackAttempts = 0, + _ackNoMsgErrs = 0, + _ackOtherErrs = 0, + _connCreated = 0, + _connSecured = 0, + _connCompleted = 0, + _connDeleted = 0, + _connDelAttempts = 0, + _connDelErrs = 0, + _connSubscribed = 0, + _connSubAttempts = 0, + _connSubIgnored = 0, + _connSubErrs = 0 + } + +newAgentSMPServerStats' :: AgentSMPServerStatsData -> STM AgentSMPServerStats +newAgentSMPServerStats' s = do + sentDirect <- newTVar $ _sentDirect s + sentViaProxy <- newTVar $ _sentViaProxy s + sentProxied <- newTVar $ _sentProxied s + sentDirectAttempts <- newTVar $ _sentDirectAttempts s + sentViaProxyAttempts <- newTVar $ _sentViaProxyAttempts s + sentProxiedAttempts <- newTVar $ _sentProxiedAttempts s + sentAuthErrs <- newTVar $ _sentAuthErrs s + sentQuotaErrs <- newTVar $ _sentQuotaErrs s + sentExpiredErrs <- newTVar $ _sentExpiredErrs s + sentOtherErrs <- newTVar $ _sentOtherErrs s + recvMsgs <- newTVar $ _recvMsgs s + recvDuplicates <- newTVar $ _recvDuplicates s + recvCryptoErrs <- newTVar $ _recvCryptoErrs s + recvErrs <- newTVar $ _recvErrs s + ackMsgs <- newTVar $ _ackMsgs s + ackAttempts <- newTVar $ _ackAttempts s + ackNoMsgErrs <- newTVar $ _ackNoMsgErrs s + ackOtherErrs <- newTVar $ _ackOtherErrs s + connCreated <- newTVar $ _connCreated s + connSecured <- newTVar $ _connSecured s + connCompleted <- newTVar $ _connCompleted s + connDeleted <- newTVar $ _connDeleted s + connDelAttempts <- newTVar $ _connDelAttempts s + connDelErrs <- newTVar $ _connDelErrs s + connSubscribed <- newTVar $ _connSubscribed s + connSubAttempts <- newTVar $ _connSubAttempts s + connSubIgnored <- newTVar $ _connSubIgnored s + connSubErrs <- newTVar $ _connSubErrs s + pure + AgentSMPServerStats + { sentDirect, + sentViaProxy, + sentProxied, + sentDirectAttempts, + sentViaProxyAttempts, + sentProxiedAttempts, + sentAuthErrs, + sentQuotaErrs, + sentExpiredErrs, + sentOtherErrs, + recvMsgs, + recvDuplicates, + recvCryptoErrs, + recvErrs, + ackMsgs, + ackAttempts, + ackNoMsgErrs, + ackOtherErrs, + connCreated, + connSecured, + connCompleted, + connDeleted, + connDelAttempts, + connDelErrs, + connSubscribed, + connSubAttempts, + connSubIgnored, + connSubErrs + } + +-- as this is used to periodically update stats in db, +-- this is not STM to decrease contention with stats updates +getAgentSMPServerStats :: AgentSMPServerStats -> IO AgentSMPServerStatsData +getAgentSMPServerStats s = do + _sentDirect <- readTVarIO $ sentDirect s + _sentViaProxy <- readTVarIO $ sentViaProxy s + _sentProxied <- readTVarIO $ sentProxied s + _sentDirectAttempts <- readTVarIO $ sentDirectAttempts s + _sentViaProxyAttempts <- readTVarIO $ sentViaProxyAttempts s + _sentProxiedAttempts <- readTVarIO $ sentProxiedAttempts s + _sentAuthErrs <- readTVarIO $ sentAuthErrs s + _sentQuotaErrs <- readTVarIO $ sentQuotaErrs s + _sentExpiredErrs <- readTVarIO $ sentExpiredErrs s + _sentOtherErrs <- readTVarIO $ sentOtherErrs s + _recvMsgs <- readTVarIO $ recvMsgs s + _recvDuplicates <- readTVarIO $ recvDuplicates s + _recvCryptoErrs <- readTVarIO $ recvCryptoErrs s + _recvErrs <- readTVarIO $ recvErrs s + _ackMsgs <- readTVarIO $ ackMsgs s + _ackAttempts <- readTVarIO $ ackAttempts s + _ackNoMsgErrs <- readTVarIO $ ackNoMsgErrs s + _ackOtherErrs <- readTVarIO $ ackOtherErrs s + _connCreated <- readTVarIO $ connCreated s + _connSecured <- readTVarIO $ connSecured s + _connCompleted <- readTVarIO $ connCompleted s + _connDeleted <- readTVarIO $ connDeleted s + _connDelAttempts <- readTVarIO $ connDelAttempts s + _connDelErrs <- readTVarIO $ connDelErrs s + _connSubscribed <- readTVarIO $ connSubscribed s + _connSubAttempts <- readTVarIO $ connSubAttempts s + _connSubIgnored <- readTVarIO $ connSubIgnored s + _connSubErrs <- readTVarIO $ connSubErrs s + pure + AgentSMPServerStatsData + { _sentDirect, + _sentViaProxy, + _sentProxied, + _sentDirectAttempts, + _sentViaProxyAttempts, + _sentProxiedAttempts, + _sentAuthErrs, + _sentQuotaErrs, + _sentExpiredErrs, + _sentOtherErrs, + _recvMsgs, + _recvDuplicates, + _recvCryptoErrs, + _recvErrs, + _ackMsgs, + _ackAttempts, + _ackNoMsgErrs, + _ackOtherErrs, + _connCreated, + _connSecured, + _connCompleted, + _connDeleted, + _connDelAttempts, + _connDelErrs, + _connSubscribed, + _connSubAttempts, + _connSubIgnored, + _connSubErrs + } + +addSMPStatsData :: AgentSMPServerStatsData -> AgentSMPServerStatsData -> AgentSMPServerStatsData +addSMPStatsData sd1 sd2 = + AgentSMPServerStatsData + { _sentDirect = _sentDirect sd1 + _sentDirect sd2, + _sentViaProxy = _sentViaProxy sd1 + _sentViaProxy sd2, + _sentProxied = _sentProxied sd1 + _sentProxied sd2, + _sentDirectAttempts = _sentDirectAttempts sd1 + _sentDirectAttempts sd2, + _sentViaProxyAttempts = _sentViaProxyAttempts sd1 + _sentViaProxyAttempts sd2, + _sentProxiedAttempts = _sentProxiedAttempts sd1 + _sentProxiedAttempts sd2, + _sentAuthErrs = _sentAuthErrs sd1 + _sentAuthErrs sd2, + _sentQuotaErrs = _sentQuotaErrs sd1 + _sentQuotaErrs sd2, + _sentExpiredErrs = _sentExpiredErrs sd1 + _sentExpiredErrs sd2, + _sentOtherErrs = _sentOtherErrs sd1 + _sentOtherErrs sd2, + _recvMsgs = _recvMsgs sd1 + _recvMsgs sd2, + _recvDuplicates = _recvDuplicates sd1 + _recvDuplicates sd2, + _recvCryptoErrs = _recvCryptoErrs sd1 + _recvCryptoErrs sd2, + _recvErrs = _recvErrs sd1 + _recvErrs sd2, + _ackMsgs = _ackMsgs sd1 + _ackMsgs sd2, + _ackAttempts = _ackAttempts sd1 + _ackAttempts sd2, + _ackNoMsgErrs = _ackNoMsgErrs sd1 + _ackNoMsgErrs sd2, + _ackOtherErrs = _ackOtherErrs sd1 + _ackOtherErrs sd2, + _connCreated = _connCreated sd1 + _connCreated sd2, + _connSecured = _connSecured sd1 + _connSecured sd2, + _connCompleted = _connCompleted sd1 + _connCompleted sd2, + _connDeleted = _connDeleted sd1 + _connDeleted sd2, + _connDelAttempts = _connDelAttempts sd1 + _connDelAttempts sd2, + _connDelErrs = _connDelErrs sd1 + _connDelErrs sd2, + _connSubscribed = _connSubscribed sd1 + _connSubscribed sd2, + _connSubAttempts = _connSubAttempts sd1 + _connSubAttempts sd2, + _connSubIgnored = _connSubIgnored sd1 + _connSubIgnored sd2, + _connSubErrs = _connSubErrs sd1 + _connSubErrs sd2 + } + +data AgentXFTPServerStats = AgentXFTPServerStats + { uploads :: TVar Int, -- total replicas uploaded to server + uploadsSize :: TVar Int64, -- total size of uploaded replicas in KB + uploadAttempts :: TVar Int, -- upload attempts + uploadErrs :: TVar Int, -- upload errors + downloads :: TVar Int, -- total replicas downloaded from server + downloadsSize :: TVar Int64, -- total size of downloaded replicas in KB + downloadAttempts :: TVar Int, -- download attempts + downloadAuthErrs :: TVar Int, -- download AUTH errors + downloadErrs :: TVar Int, -- other download errors (excluding above) + deletions :: TVar Int, -- total replicas deleted from server + deleteAttempts :: TVar Int, -- delete attempts + deleteErrs :: TVar Int -- delete errors + } + +data AgentXFTPServerStatsData = AgentXFTPServerStatsData + { _uploads :: Int, + _uploadsSize :: Int64, + _uploadAttempts :: Int, + _uploadErrs :: Int, + _downloads :: Int, + _downloadsSize :: Int64, + _downloadAttempts :: Int, + _downloadAuthErrs :: Int, + _downloadErrs :: Int, + _deletions :: Int, + _deleteAttempts :: Int, + _deleteErrs :: Int + } + deriving (Show) + +newAgentXFTPServerStats :: STM AgentXFTPServerStats +newAgentXFTPServerStats = do + uploads <- newTVar 0 + uploadsSize <- newTVar 0 + uploadAttempts <- newTVar 0 + uploadErrs <- newTVar 0 + downloads <- newTVar 0 + downloadsSize <- newTVar 0 + downloadAttempts <- newTVar 0 + downloadAuthErrs <- newTVar 0 + downloadErrs <- newTVar 0 + deletions <- newTVar 0 + deleteAttempts <- newTVar 0 + deleteErrs <- newTVar 0 + pure + AgentXFTPServerStats + { uploads, + uploadsSize, + uploadAttempts, + uploadErrs, + downloads, + downloadsSize, + downloadAttempts, + downloadAuthErrs, + downloadErrs, + deletions, + deleteAttempts, + deleteErrs + } + +newAgentXFTPServerStatsData :: AgentXFTPServerStatsData +newAgentXFTPServerStatsData = + AgentXFTPServerStatsData + { _uploads = 0, + _uploadsSize = 0, + _uploadAttempts = 0, + _uploadErrs = 0, + _downloads = 0, + _downloadsSize = 0, + _downloadAttempts = 0, + _downloadAuthErrs = 0, + _downloadErrs = 0, + _deletions = 0, + _deleteAttempts = 0, + _deleteErrs = 0 + } + +newAgentXFTPServerStats' :: AgentXFTPServerStatsData -> STM AgentXFTPServerStats +newAgentXFTPServerStats' s = do + uploads <- newTVar $ _uploads s + uploadsSize <- newTVar $ _uploadsSize s + uploadAttempts <- newTVar $ _uploadAttempts s + uploadErrs <- newTVar $ _uploadErrs s + downloads <- newTVar $ _downloads s + downloadsSize <- newTVar $ _downloadsSize s + downloadAttempts <- newTVar $ _downloadAttempts s + downloadAuthErrs <- newTVar $ _downloadAuthErrs s + downloadErrs <- newTVar $ _downloadErrs s + deletions <- newTVar $ _deletions s + deleteAttempts <- newTVar $ _deleteAttempts s + deleteErrs <- newTVar $ _deleteErrs s + pure + AgentXFTPServerStats + { uploads, + uploadsSize, + uploadAttempts, + uploadErrs, + downloads, + downloadsSize, + downloadAttempts, + downloadAuthErrs, + downloadErrs, + deletions, + deleteAttempts, + deleteErrs + } + +-- as this is used to periodically update stats in db, +-- this is not STM to decrease contention with stats updates +getAgentXFTPServerStats :: AgentXFTPServerStats -> IO AgentXFTPServerStatsData +getAgentXFTPServerStats s = do + _uploads <- readTVarIO $ uploads s + _uploadsSize <- readTVarIO $ uploadsSize s + _uploadAttempts <- readTVarIO $ uploadAttempts s + _uploadErrs <- readTVarIO $ uploadErrs s + _downloads <- readTVarIO $ downloads s + _downloadsSize <- readTVarIO $ downloadsSize s + _downloadAttempts <- readTVarIO $ downloadAttempts s + _downloadAuthErrs <- readTVarIO $ downloadAuthErrs s + _downloadErrs <- readTVarIO $ downloadErrs s + _deletions <- readTVarIO $ deletions s + _deleteAttempts <- readTVarIO $ deleteAttempts s + _deleteErrs <- readTVarIO $ deleteErrs s + pure + AgentXFTPServerStatsData + { _uploads, + _uploadsSize, + _uploadAttempts, + _uploadErrs, + _downloads, + _downloadsSize, + _downloadAttempts, + _downloadAuthErrs, + _downloadErrs, + _deletions, + _deleteAttempts, + _deleteErrs + } + +addXFTPStatsData :: AgentXFTPServerStatsData -> AgentXFTPServerStatsData -> AgentXFTPServerStatsData +addXFTPStatsData sd1 sd2 = + AgentXFTPServerStatsData + { _uploads = _uploads sd1 + _uploads sd2, + _uploadsSize = _uploadsSize sd1 + _uploadsSize sd2, + _uploadAttempts = _uploadAttempts sd1 + _uploadAttempts sd2, + _uploadErrs = _uploadErrs sd1 + _uploadErrs sd2, + _downloads = _downloads sd1 + _downloads sd2, + _downloadsSize = _downloadsSize sd1 + _downloadsSize sd2, + _downloadAttempts = _downloadAttempts sd1 + _downloadAttempts sd2, + _downloadAuthErrs = _downloadAuthErrs sd1 + _downloadAuthErrs sd2, + _downloadErrs = _downloadErrs sd1 + _downloadErrs sd2, + _deletions = _deletions sd1 + _deletions sd2, + _deleteAttempts = _deleteAttempts sd1 + _deleteAttempts sd2, + _deleteErrs = _deleteErrs sd1 + _deleteErrs sd2 + } + +-- Type for gathering both smp and xftp stats across all users and servers, +-- to then be persisted to db as a single json. +data AgentPersistedServerStats = AgentPersistedServerStats + { smpServersStats :: Map (UserId, SMPServer) AgentSMPServerStatsData, + xftpServersStats :: Map (UserId, XFTPServer) AgentXFTPServerStatsData + } + deriving (Show) + +$(J.deriveJSON defaultJSON ''AgentSMPServerStatsData) + +$(J.deriveJSON defaultJSON ''AgentXFTPServerStatsData) + +$(J.deriveJSON defaultJSON ''AgentPersistedServerStats) + +instance ToField AgentPersistedServerStats where + toField = toField . encodeJSON + +instance FromField AgentPersistedServerStats where + fromField = fromTextField_ decodeJSON diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 807ca223a..ae010a884 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -44,6 +44,7 @@ import Simplex.Messaging.Protocol RcvPrivateAuthKey, SndPrivateAuthKey, SndPublicAuthKey, + SenderCanSecure, VersionSMPC, ) import qualified Simplex.Messaging.Protocol as SMP @@ -83,6 +84,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue e2eDhSecret :: Maybe C.DhSecretX25519, -- | sender queue ID sndId :: SMP.SenderId, + -- | sender can secure the queue + sndSecure :: SenderCanSecure, -- | queue status status :: QueueStatus, -- | database queue ID (within connection) @@ -138,9 +141,11 @@ data StoredSndQueue (q :: QueueStored) = SndQueue server :: SMPServer, -- | sender queue ID sndId :: SMP.SenderId, + -- | sender can secure the queue + sndSecure :: SenderCanSecure, -- | key pair used by the sender to authorize transmissions -- TODO combine keys to key pair so that types match - sndPublicKey :: Maybe SndPublicAuthKey, + sndPublicKey :: SndPublicAuthKey, sndPrivateKey :: SndPrivateAuthKey, -- | DH public key used to negotiate per-queue e2e encryption e2ePubKey :: Maybe C.PublicKeyX25519, @@ -170,6 +175,12 @@ instance SMPQueue RcvQueue where queueId RcvQueue {rcvId} = rcvId {-# INLINE queueId #-} +instance SMPQueue NewRcvQueue where + qServer RcvQueue {server} = server + {-# INLINE qServer #-} + queueId RcvQueue {rcvId} = rcvId + {-# INLINE queueId #-} + instance SMPQueue SndQueue where qServer SndQueue {server} = server {-# INLINE qServer #-} @@ -372,7 +383,7 @@ instance StrEncoding AgentCommandTag where data InternalCommand = ICAck SMP.RecipientId MsgId | ICAckDel SMP.RecipientId MsgId InternalId - | ICAllowSecure SMP.RecipientId SMP.SndPublicAuthKey + | ICAllowSecure SMP.RecipientId (Maybe SMP.SndPublicAuthKey) | ICDuplexSecure SMP.RecipientId SMP.SndPublicAuthKey | ICDeleteConn | ICDeleteRcvQueue SMP.RecipientId @@ -635,4 +646,6 @@ data StoreError SEDeletedSndChunkReplicaNotFound | -- | Error when reading work item that suspends worker - do not use! SEWorkItemError ByteString + | -- | Servers stats not found. + SEServersStatsNotFound deriving (Eq, Show, Exception) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index a8b18c5b7..0727343e7 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -102,8 +102,10 @@ module Simplex.Messaging.Agent.Store.SQLite -- Messages updateRcvIds, createRcvMsg, + updateRcvMsgHash, updateSndIds, createSndMsg, + updateSndMsgHash, createSndMsgDelivery, getSndMsgViaRcpt, updateSndMsgRcpt, @@ -210,6 +212,10 @@ module Simplex.Messaging.Agent.Store.SQLite deleteDeletedSndChunkReplica, getPendingDelFilesServers, deleteDeletedSndChunkReplicasExpired, + -- Stats + updateServersStats, + getServersStats, + resetServersStats, -- * utilities withConnection, @@ -263,6 +269,7 @@ import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) import Simplex.FileTransfer.Types import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) +import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite.Common import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -806,7 +813,7 @@ setRcvQueueNtfCreds db connId clientNtfCreds = Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) Nothing -> (Nothing, Nothing, Nothing, Nothing) -type SMPConfirmationRow = (SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) +type SMPConfirmationRow = (Maybe SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe VersionSMPC) smpConfirmation :: SMPConfirmationRow -> SMPConfirmation smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) = @@ -953,10 +960,10 @@ updateRcvIds db connId = do pure (internalId, internalRcvId, lastExternalSndId, lastRcvHash) createRcvMsg :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO () -createRcvMsg db connId rq rcvMsgData = do +createRcvMsg db connId rq rcvMsgData@RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalRcvId, internalHash} = do insertRcvMsgBase_ db connId rcvMsgData insertRcvMsgDetails_ db connId rq rcvMsgData - updateHashRcv_ db connId rcvMsgData + updateRcvMsgHash db connId sndMsgId internalRcvId internalHash updateSndIds :: DB.Connection -> ConnId -> IO (InternalId, InternalSndId, PrevSndMsgHash) updateSndIds db connId = do @@ -967,10 +974,10 @@ updateSndIds db connId = do pure (internalId, internalSndId, prevSndHash) createSndMsg :: DB.Connection -> ConnId -> SndMsgData -> IO () -createSndMsg db connId sndMsgData = do +createSndMsg db connId sndMsgData@SndMsgData {internalSndId, internalHash} = do insertSndMsgBase_ db connId sndMsgData insertSndMsgDetails_ db connId sndMsgData - updateHashSnd_ db connId sndMsgData + updateSndMsgHash db connId internalSndId internalHash createSndMsgDelivery :: DB.Connection -> ConnId -> SndQueue -> InternalId -> IO () createSndMsgDelivery db connId SndQueue {dbQueueId} msgId = @@ -1861,28 +1868,34 @@ upsertNtfServer_ db ProtocolServer {host, port, keyHash} = do insertRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> Maybe C.KeyHash -> IO RcvQueue insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do - qId <- newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId') + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT rcv_queue_id FROM rcv_queues WHERE conn_id = ? ORDER BY rcv_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ DB.execute db [sql| INSERT INTO rcv_queues - (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); + (host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, sndSecure, status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId} -- * createSndConn helpers insertSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> Maybe C.KeyHash -> IO SndQueue insertSndQueue_ db connId' sq@SndQueue {..} serverKeyHash_ = do - qId <- newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId') + -- to preserve ID if the queue already exists. + -- possibly, it can be done in one query. + currQId_ <- maybeFirstRow fromOnly $ DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? AND host = ? AND port = ? AND snd_id = ?" (connId', host server, port server, sndId) + qId <- maybe (newQueueId_ <$> DB.query db "SELECT snd_queue_id FROM snd_queues WHERE conn_id = ? ORDER BY snd_queue_id DESC LIMIT 1" (Only connId')) pure currQId_ DB.execute db [sql| INSERT OR REPLACE INTO snd_queues - (host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?); + (host, port, snd_id, snd_secure, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status, snd_queue_id, snd_primary, replace_snd_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); |] - ((host server, port server, sndId, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) + ((host server, port server, sndId, sndSecure, connId', sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret) :. (status, qId, primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)) pure (sq :: NewSndQueue) {connId = connId', dbQueueId = qId} newQueueId_ :: [Only Int64] -> DBQueueId 'QSStored @@ -2004,7 +2017,7 @@ rcvQueueQuery :: Query rcvQueueQuery = [sql| SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, - q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.status, + q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status, q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret FROM rcv_queues q @@ -2013,17 +2026,17 @@ rcvQueueQuery = |] toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) - :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, SenderCanSecure) + :. (QueueStatus, DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int) :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue -toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = +toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure) :. (status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_ clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} _ -> Nothing - in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} + in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors} getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue) getRcvQueueById db connId dbRcvId = @@ -2044,7 +2057,7 @@ sndQueueQuery :: Query sndQueueQuery = [sql| SELECT - c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, + c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.snd_id, q.snd_secure, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status, q.snd_queue_id, q.snd_primary, q.replace_snd_queue_id, q.switch_status, q.smp_client_version FROM snd_queues q @@ -2053,17 +2066,18 @@ sndQueueQuery = |] toSndQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId, SenderCanSecure) :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, VersionSMPC) -> SndQueue toSndQueue - ( (userId, keyHash, connId, host, port, sndId) - :. (sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status) + ( (userId, keyHash, connId, host, port, sndId, sndSecure) + :. (sndPubKey, sndPrivateKey@(C.APrivateAuthKey a pk), e2ePubKey, e2eDhSecret, status) :. (dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion) ) = let server = SMPServer host port keyHash - in SndQueue {userId, connId, server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} + sndPublicKey = fromMaybe (C.APublicAuthKey a (C.publicKey pk)) sndPubKey + in SndQueue {userId, connId, server, sndId, sndSecure, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status, dbQueueId, primary, dbReplaceQueueId, sndSwchStatus, smpClientVersion} getSndQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError SndQueue) getSndQueueById db connId dbSndId = @@ -2142,10 +2156,10 @@ insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, interna ] DB.execute db "INSERT INTO encrypted_rcv_message_hashes (conn_id, hash) VALUES (?,?)" (connId, encryptedMsgHash) -updateHashRcv_ :: DB.Connection -> ConnId -> RcvMsgData -> IO () -updateHashRcv_ dbConn connId RcvMsgData {msgMeta = MsgMeta {sndMsgId}, internalHash, internalRcvId} = +updateRcvMsgHash :: DB.Connection -> ConnId -> AgentMsgId -> InternalRcvId -> MsgHash -> IO () +updateRcvMsgHash db connId sndMsgId internalRcvId internalHash = DB.executeNamed - dbConn + db -- last_internal_rcv_msg_id equality check prevents race condition in case next id was reserved [sql| UPDATE connections @@ -2221,10 +2235,10 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} = ":previous_msg_hash" := prevMsgHash ] -updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO () -updateHashSnd_ dbConn connId SndMsgData {..} = +updateSndMsgHash :: DB.Connection -> ConnId -> InternalSndId -> MsgHash -> IO () +updateSndMsgHash db connId internalSndId internalHash = DB.executeNamed - dbConn + db -- last_internal_snd_msg_id equality check prevents race condition in case next id was reserved [sql| UPDATE connections @@ -3017,6 +3031,20 @@ deleteDeletedSndChunkReplicasExpired db ttl = do cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE created_at < ?" (Only cutoffTs) +updateServersStats :: DB.Connection -> AgentPersistedServerStats -> IO () +updateServersStats db stats = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE servers_stats SET servers_stats = ?, updated_at = ? WHERE servers_stats_id = 1" (stats, updatedAt) + +getServersStats :: DB.Connection -> IO (Either StoreError (UTCTime, Maybe AgentPersistedServerStats)) +getServersStats db = + firstRow id SEServersStatsNotFound $ + DB.query_ db "SELECT started_at, servers_stats FROM servers_stats WHERE servers_stats_id = 1" + +resetServersStats :: DB.Connection -> UTCTime -> IO () +resetServersStats db startedAt = + DB.execute db "UPDATE servers_stats SET servers_stats = NULL, started_at = ?, updated_at = ? WHERE servers_stats_id = 1" (startedAt, startedAt) + $(J.deriveJSON defaultJSON ''UpMigration) $(J.deriveToJSON (sumTypeJSON $ dropPrefix "ME") ''MigrationError) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 5a5ed5b5b..131561f4d 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -72,6 +72,8 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Transport.Client (TransportHost) @@ -112,7 +114,9 @@ schemaMigrations = ("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect), ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery), ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem), - ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays) + ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays), + ("m20240624_snd_secure", m20240624_snd_secure, Just down_m20240624_snd_secure), + ("m20240702_servers_stats", m20240702_servers_stats, Just down_m20240702_servers_stats) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs new file mode 100644 index 000000000..7f82d4ecf --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240624_snd_secure.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240624_snd_secure where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240624_snd_secure :: Query +m20240624_snd_secure = + [sql| +ALTER TABLE rcv_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; +ALTER TABLE snd_queues ADD COLUMN snd_secure INTEGER NOT NULL DEFAULT 0; + +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace(sql, 'sender_key BLOB NOT NULL,', 'sender_key BLOB,') +WHERE name = 'conn_confirmations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] + +down_m20240624_snd_secure :: Query +down_m20240624_snd_secure = + [sql| +ALTER TABLE rcv_queues DROP COLUMN snd_secure; +ALTER TABLE snd_queues DROP COLUMN snd_secure; + +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace(sql, 'sender_key BLOB,', 'sender_key BLOB NOT NULL,') +WHERE name = 'conn_confirmations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240702_servers_stats.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240702_servers_stats.hs new file mode 100644 index 000000000..5e283d8b1 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240702_servers_stats.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240702_servers_stats where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- servers_stats_id: dummy id, there should always only be one record with servers_stats_id = 1 +-- servers_stats: overall accumulated stats, past and session, reset to null on stats reset +-- started_at: starting point of tracking stats, reset on stats reset +m20240702_servers_stats :: Query +m20240702_servers_stats = + [sql| +CREATE TABLE servers_stats( + servers_stats_id INTEGER PRIMARY KEY, + servers_stats TEXT, + started_at TEXT NOT NULL DEFAULT(datetime('now')), + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); + +INSERT INTO servers_stats (servers_stats_id) VALUES (1); +|] + +down_m20240702_servers_stats :: Query +down_m20240702_servers_stats = + [sql| +DROP TABLE servers_stats; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index caf94418a..80af08989 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -55,6 +55,7 @@ CREATE TABLE rcv_queues( server_key_hash BLOB, switch_status TEXT, deleted INTEGER NOT NULL DEFAULT 0, + snd_secure INTEGER NOT NULL DEFAULT 0, PRIMARY KEY(host, port, rcv_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -77,6 +78,7 @@ CREATE TABLE snd_queues( replace_snd_queue_id INTEGER NULL, server_key_hash BLOB, switch_status TEXT, + snd_secure INTEGER NOT NULL DEFAULT 0, PRIMARY KEY(host, port, snd_id), FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE @@ -132,7 +134,7 @@ CREATE TABLE conn_confirmations( confirmation_id BLOB NOT NULL PRIMARY KEY, conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, e2e_snd_pub_key BLOB NOT NULL, - sender_key BLOB NOT NULL, + sender_key BLOB, ratchet_state BLOB NOT NULL, sender_conn_info BLOB NOT NULL, accepted INTEGER NOT NULL, @@ -394,6 +396,13 @@ CREATE TABLE processed_ratchet_key_hashes( created_at TEXT NOT NULL DEFAULT(datetime('now')), updated_at TEXT NOT NULL DEFAULT(datetime('now')) ); +CREATE TABLE servers_stats( + servers_stats_id INTEGER PRIMARY KEY, + servers_stats TEXT, + started_at TEXT NOT NULL DEFAULT(datetime('now')), + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id); CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id); diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index de178e368..e20b00039 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -47,6 +47,8 @@ module Simplex.Messaging.Client subscribeSMPQueueNotifications, subscribeSMPQueuesNtfs, secureSMPQueue, + secureSndSMPQueue, + proxySecureSndSMPQueue, enableSMPQueueNotifications, disableSMPQueueNotifications, enableSMPQueuesNtfs, @@ -58,7 +60,7 @@ module Simplex.Messaging.Client deleteSMPQueues, connectSMPProxiedRelay, proxySMPMessage, - forwardSMPMessage, + forwardSMPTransmission, getSMPQueueInfo, sendProtocolCommand, @@ -655,9 +657,10 @@ createSMPQueue :: RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> + Bool -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c (rKey, rpKey) dhKey auth subMode = - sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case +createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure = + sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode sndSecure) >>= \case IDS qik -> pure qik r -> throwE $ unexpectedResponse r @@ -729,6 +732,15 @@ secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuth secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId {-# INLINE secureSMPQueue #-} +-- | Secure the SMP queue via sender queue ID. +secureSndSMPQueue :: SMPClient -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO () +secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey sId +{-# INLINE secureSndSMPQueue #-} + +proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey) +{-# INLINE proxySecureSndSMPQueue #-} + -- | Enable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command @@ -769,6 +781,9 @@ sendSMPMessage c spKey sId flags msg = OK -> pure () r -> throwE $ unexpectedResponse r +proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg) + -- | Acknowledge message delivery (server deletes the message). -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery @@ -870,24 +885,24 @@ instance StrEncoding ProxyClientError where -- 8) PFWD(SEND) -> WTF -> ProxyUnexpectedResponse - client/proxy protocol logic -- 9) PFWD(SEND) -> ??? -> ProxyResponseError - client/proxy syntax -- --- We report as proxySMPMessage error (ExceptT error) the errors of two kinds: +-- We report as proxySMPCommand error (ExceptT error) the errors of two kinds: -- - protocol errors from the destination relay wrapped in PRES - to simplify processing of AUTH and QUOTA errors, in this case proxy is "transparent" for such errors (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError) -- - other response/transport/connection errors from the client connected to proxy itself -- Other errors are reported in the function result as `Either ProxiedRelayError ()`, including -- - protocol errors from the client connected to proxy in ProxyClientError (PCEProtocolError, PCEUnexpectedResponse, PCEResponseError) -- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError -proxySMPMessage :: +-- This function proxies Sender commands that return OK or ERR +proxySMPCommand :: SMPClient -> -- proxy session from PKEY ProxiedRelay -> -- message to deliver Maybe SndPrivateAuthKey -> SenderId -> - MsgFlags -> - MsgBody -> + Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ()) -proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v serverKey) spKey sId flags msg = do +proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v serverKey) spKey sId command = do -- prepare params let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth} @@ -895,14 +910,14 @@ proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c let cmdSecret = C.dh' serverKey cmdPrivKey nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g -- encode - let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender (SEND flags msg)) + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command) auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of [] -> throwE $ PCETransportError TELargeMsg TBError e _ : _ -> throwE $ PCETransportError e TBTransmission s _ : _ -> pure s TBTransmissions s _ _ : _ -> pure s - et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedMsgLength + et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret nonce b paddedProxiedTLength -- proxy interaction errors are wrapped let tOut = Just $ 2 * tcpTimeout tryE (sendProtocolCommand_ c (Just nonce) tOut Nothing sessionId (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case @@ -930,8 +945,8 @@ proxySMPMessage c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c -- sends RFWD :: EncFwdTransmission -> Command Sender -- receives RRES :: EncFwdResponse -> BrokerMsg -- proxy should send PRES to the client with EncResponse -forwardSMPMessage :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse -forwardSMPMessage c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do +forwardSMPTransmission :: SMPClient -> CorrId -> VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> ExceptT SMPClientError IO EncResponse +forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} fwdCorrId fwdVersion fwdKey fwdTransmission = do -- prepare params sessSecret <- case thAuth thParams of Nothing -> throwE $ PCETransportError TENoServerAuth diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index e7c22eec2..99c77f67c 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -20,17 +20,15 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) -import Data.Bifunctor (bimap, first) +import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Either (partitionEithers) -import Data.List (partition) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (listToMaybe) import Data.Set (Set) +import qualified Data.Set as S import Data.Text.Encoding import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Tuple (swap) @@ -55,8 +53,8 @@ type SMPClientVar = SessionVar (Either (SMPClientError, Maybe UTCTime) (OwnServe data SMPClientAgentEvent = CAConnected SMPServer | CADisconnected SMPServer (Set SMPSub) - | CAResubscribed SMPServer (NonEmpty SMPSub) - | CASubError SMPServer (NonEmpty (SMPSub, SMPClientError)) + | CASubscribed SMPServer SMPSubParty (NonEmpty QueueId) + | CASubError SMPServer SMPSubParty (NonEmpty (QueueId, SMPClientError)) data SMPSubParty = SPRecipient | SPNotifier deriving (Eq, Ord, Show) @@ -86,9 +84,9 @@ defaultSMPClientAgentConfig = maxInterval = 10 * second }, persistErrorInterval = 30, -- seconds - msgQSize = 256, - agentQSize = 256, - agentSubsBatchSize = 900, + msgQSize = 1024, + agentQSize = 1024, + agentSubsBatchSize = 1360, ownServerDomains = [] } where @@ -192,7 +190,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke isOwnServer :: SMPClientAgent -> SMPServer -> OwnServer isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} = let srv = strEncode $ L.head host - in any (\s -> s == srv || (B.cons '.' s) `B.isSuffixOf` srv) (ownServerDomains agentCfg) + in any (\s -> s == srv || B.cons '.' s `B.isSuffixOf` srv) (ownServerDomains agentCfg) -- | Run an SMP client for SMPClientVar connectClient :: SMPClientAgent -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient) @@ -212,15 +210,9 @@ connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, random where updateSubs sVar = do ss <- readTVar sVar - addPendingSubs sVar ss + addSubs_ (pendingSrvSubs ca) srv ss pure ss - addPendingSubs sVar ss = do - let ps = pendingSrvSubs ca - TM.lookup srv ps >>= \case - Just ss' -> TM.union ss ss' - _ -> TM.insert srv sVar ps - serverDown :: Map SMPSub C.APrivateAuthKey -> IO () serverDown ss = unless (M.null ss) $ do notify ca . CADisconnected srv $ M.keysSet ss @@ -244,11 +236,11 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s runSubWorker = withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do pending <- atomically getPending - forM_ pending $ \cs -> whenM (readTVarIO active) $ do - void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv cs) + unless (null pending) $ whenM (readTVarIO active) $ do + void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv pending) loop ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg - getPending = mapM readTVar =<< TM.lookup srv (pendingSrvSubs ca) + getPending = maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca) cleanup :: SessionVar (Async ()) -> STM () cleanup v = do -- Here we wait until TMVar is not empty to prevent worker cleanup happening before worker is added to TMVar. @@ -258,32 +250,22 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s reconnectSMPClient :: SMPClientAgent -> SMPServer -> Map SMPSub C.APrivateAuthKey -> ExceptT SMPClientError IO () reconnectSMPClient ca@SMPClientAgent {agentCfg} srv cs = - withSMP ca srv $ \smp -> do - subs' <- filterM (fmap not . atomically . hasSub (srvSubs ca) srv . fst) $ M.assocs cs - let (nSubs, rSubs) = partition (isNotifier . fst . fst) subs' + withSMP ca srv $ \smp -> liftIO $ do + currSubs <- atomically $ maybe (pure M.empty) readTVar =<< TM.lookup srv (srvSubs ca) + let (nSubs, rSubs) = foldr (groupSub currSubs) ([], []) $ M.assocs cs subscribe_ smp SPNotifier nSubs subscribe_ smp SPRecipient rSubs where - isNotifier = \case - SPNotifier -> True - SPRecipient -> False - subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO () - subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg) + groupSub :: Map SMPSub C.APrivateAuthKey -> (SMPSub, C.APrivateAuthKey) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) -> ([(QueueId, C.APrivateAuthKey)], [(QueueId, C.APrivateAuthKey)]) + groupSub currSubs (s@(party, qId), k) (nSubs, rSubs) + | M.member s currSubs = (nSubs, rSubs) + | otherwise = case party of + SPNotifier -> (s' : nSubs, rSubs) + SPRecipient -> (nSubs, s' : rSubs) where - subscribeBatch subs' = do - let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs' - rs <- liftIO $ smpSubscribeQueues party ca smp srv subs'' - let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) = - L.zipWith (first . const) subs' rs - rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] = - map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs' - (errs, oks) = partitionEithers rs'' - (tempErrs, finalErrs) = partition (temporaryClientError . snd) errs - mapM_ (atomically . addSubscription ca srv) oks - mapM_ (notify ca . CAResubscribed srv) $ L.nonEmpty $ map fst oks - mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs - mapM_ (notify ca . CASubError srv) $ L.nonEmpty finalErrs - mapM_ (throwE . snd) $ listToMaybe tempErrs + s' = (qId, k) + subscribe_ :: SMPClient -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> IO () + subscribe_ smp party = mapM_ (smpSubscribeQueues party ca smp srv) . toChunks (agentSubsBatchSize agentCfg) notify :: MonadIO m => SMPClientAgent -> SMPClientAgentEvent -> m () notify ca evt = atomically $ writeTBQueue (agentQ ca) evt @@ -297,7 +279,8 @@ getConnectedSMPServerClient SMPClientAgent {smpClients} srv = $>>= \case (_, Right r) -> pure $ Just $ Right r (v, Left (e, ts_)) -> - pure ts_ $>>= \ts -> -- proxy will create a new connection if ts_ is Nothing + pure ts_ $>>= \ts -> + -- proxy will create a new connection if ts_ is Nothing ifM ((ts <) <$> liftIO getCurrentTime) -- error persistence interval period expired? (Nothing <$ atomically (removeSessVar v srv smpClients)) -- proxy will create a new connection @@ -334,86 +317,99 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e throwE e -subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () -subscribeQueue ca srv sub = do - atomically $ addPendingSubscription ca srv sub - withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleErr - where - subscribe_ smp = do - smpSubscribe smp sub - atomically $ addSubscription ca srv sub - - handleErr e = do - atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $ - removePendingSubscription ca srv (fst sub) - throwE e - -subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ())) +subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO () subscribeQueuesSMP = subscribeQueues_ SPRecipient -subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ())) +subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO () subscribeQueuesNtfs = subscribeQueues_ SPNotifier -subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO () subscribeQueues_ party ca srv subs = do - atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,) + atomically $ addPendingSubs ca srv party $ L.toList subs runExceptT (getSMPServerClient' ca srv) >>= \case - Left e -> pure $ L.map ((,Left e) . fst) subs Right smp -> smpSubscribeQueues party ca smp srv subs + Left _ -> pure () -- no call to reconnectClient - failing getSMPServerClient' does that -smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO () smpSubscribeQueues party ca smp srv subs = do - rs <- L.zip subs <$> subscribe smp (L.map swap subs) - atomically $ forM rs $ \(sub, r) -> - (fst sub,) <$> case r of - Right () -> do - addSubscription ca srv $ first (party,) sub - pure $ Right () - Left e -> do - when (e /= PCENetworkError && e /= PCEResponseTimeout) $ - removePendingSubscription ca srv (party, fst sub) - pure $ Left e + rs <- subscribe smp $ L.map swap subs + rs' <- + atomically $ + ifM + (activeClientSession ca smp srv) + (Just <$> processSubscriptions rs) + (pure Nothing) + case rs' of + Just (tempErrs, finalErrs, oks, _) -> do + notify_ CASubscribed $ map fst oks + notify_ CASubError finalErrs + when tempErrs $ reconnectClient ca srv + Nothing -> reconnectClient ca srv where + processSubscriptions :: NonEmpty (Either SMPClientError ()) -> STM (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) + processSubscriptions rs = do + pending <- maybe (pure M.empty) readTVar =<< TM.lookup srv (pendingSrvSubs ca) + let acc@(_, _, oks, notPending) = foldr (groupSub pending) (False, [], [], []) (L.zip subs rs) + unless (null oks) $ addSubscriptions ca srv party oks + unless (null notPending) $ removePendingSubs ca srv party notPending + pure acc + groupSub :: Map SMPSub C.APrivateAuthKey -> ((QueueId, C.APrivateAuthKey), Either SMPClientError ()) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) -> (Bool, [(QueueId, SMPClientError)], [(QueueId, C.APrivateAuthKey)], [QueueId]) + groupSub pending (s@(qId, _), r) acc@(!tempErrs, finalErrs, oks, notPending) = case r of + Right () + | M.member (party, qId) pending -> (tempErrs, finalErrs, s : oks, qId : notPending) + | otherwise -> acc + Left e + | temporaryClientError e -> (True, finalErrs, oks, notPending) + | otherwise -> (tempErrs, (qId, e) : finalErrs, oks, qId : notPending) subscribe = case party of SPRecipient -> subscribeSMPQueues SPNotifier -> subscribeSMPQueuesNtfs + notify_ :: (SMPServer -> SMPSubParty -> NonEmpty a -> SMPClientAgentEvent) -> [a] -> IO () + notify_ evt qs = mapM_ (notify ca . evt srv party) $ L.nonEmpty qs + +activeClientSession :: SMPClientAgent -> SMPClient -> SMPServer -> STM Bool +activeClientSession ca smp srv = sameSess <$> tryReadSessVar srv (smpClients ca) + where + sessId = sessionId . thParams + sameSess = \case + Just (Right (_, smp')) -> sessId smp == sessId smp' + _ -> False showServer :: SMPServer -> ByteString showServer ProtocolServer {host, port} = strEncode host <> B.pack (if null port then "" else ':' : port) -smpSubscribe :: SMPClient -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () -smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId +addSubscriptions :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM () +addSubscriptions = addSubsList_ . srvSubs +{-# INLINE addSubscriptions #-} + +addPendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM () +addPendingSubs = addSubsList_ . pendingSrvSubs +{-# INLINE addPendingSubs #-} + +addSubsList_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [(QueueId, C.APrivateAuthKey)] -> STM () +addSubsList_ subs srv party ss = addSubs_ subs srv ss' where - subscribe_ = case party of - SPRecipient -> subscribeSMPQueue - SPNotifier -> subscribeSMPQueueNotifications + ss' = M.fromList $ map (first (party,)) ss -addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () -addSubscription ca srv sub = do - addSub_ (srvSubs ca) srv sub - removePendingSubscription ca srv $ fst sub - -addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () -addPendingSubscription = addSub_ . pendingSrvSubs - -addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () -addSub_ subs srv (s, key) = +addSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> Map SMPSub C.APrivateAuthKey -> STM () +addSubs_ subs srv ss = TM.lookup srv subs >>= \case - Just m -> TM.insert s key m - _ -> TM.singleton s key >>= \v -> TM.insert srv v subs + Just m -> TM.union ss m + _ -> newTVar ss >>= \v -> TM.insert srv v subs removeSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM () removeSubscription = removeSub_ . srvSubs - -removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM () -removePendingSubscription = removeSub_ . pendingSrvSubs +{-# INLINE removeSubscription #-} removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM () removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s) -getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateAuthKey) -getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s +removePendingSubs :: SMPClientAgent -> SMPServer -> SMPSubParty -> [QueueId] -> STM () +removePendingSubs = removeSubs_ . pendingSrvSubs +{-# INLINE removePendingSubs #-} -hasSub :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM Bool -hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs +removeSubs_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSubParty -> [QueueId] -> STM () +removeSubs_ subs srv party qs = TM.lookup srv subs >>= mapM_ (`modifyTVar'` (`M.withoutKeys` ss)) + where + ss = S.fromList $ map (party,) qs diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 5d3b4d806..2bf8dbcbf 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -188,33 +188,16 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge runSMPSubscriber :: SMPSubscriber -> M () runSMPSubscriber SMPSubscriber {newSubQ = subscriberSubQ} = forever $ do - subs <- atomically (peekTQueue subscriberSubQ) + subs <- atomically $ readTQueue subscriberSubQ let subs' = L.map (\(NtfSub sub) -> sub) subs srv = server $ L.head subs logSubStatus srv "subscribing" $ length subs mapM_ (\NtfSubData {smpQueue} -> updateSubStatus smpQueue NSPending) subs' - rs <- liftIO $ subscribeQueues srv subs' - (subs'', oks, errs) <- foldM process ([], 0, []) rs - atomically $ do - void $ readTQueue subscriberSubQ - mapM_ (writeTQueue subscriberSubQ . L.map NtfSub) $ L.nonEmpty subs'' - logSubStatus srv "retrying" $ length subs'' - logSubStatus srv "subscribed" oks - logSubErrors srv errs - where - process :: ([NtfSubData], Int, [NtfSubStatus]) -> (NtfSubData, Either SMPClientError ()) -> M ([NtfSubData], Int, [NtfSubStatus]) - process (subs, oks, errs) (sub@NtfSubData {smpQueue}, r) = case r of - Right _ -> updateSubStatus smpQueue NSActive $> (subs, oks + 1, errs) - Left e -> update <$> handleSubError smpQueue e - where - update = \case - Just err -> (subs, oks, err : errs) -- permanent error, log and don't retry subscription - Nothing -> (sub : subs, oks, errs) -- temporary error, retry subscription + liftIO $ subscribeQueues srv subs' -- \| Subscribe to queues. The list of results can have a different order. - subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ())) - subscribeQueues srv subs = - L.zipWith (\s r -> (s, snd r)) subs <$> subscribeQueuesNtfs ca srv (L.map sub subs) + subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO () + subscribeQueues srv subs = subscribeQueuesNtfs ca srv (L.map sub subs) where sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey) @@ -239,7 +222,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge incNtfStat ntfReceived Right SMP.END -> updateSubStatus smpQueue NSEnd Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e - Right _ -> logError $ "SMP server unexpected response" + Right _ -> logError "SMP server unexpected response" Left e -> logError $ "SMP client error: " <> tshow e receiveAgent = @@ -252,11 +235,11 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge forM_ subs $ \(_, ntfId) -> do let smpQueue = SMPQueueNtf srv ntfId updateSubStatus smpQueue NSInactive - CAResubscribed srv subs -> do - forM_ subs $ \(_, ntfId) -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive - logSubStatus srv "resubscribed" $ length subs - CASubError srv errs -> - forM errs (\((_, ntfId), err) -> handleSubError (SMPQueueNtf srv ntfId) err) + CASubscribed srv _ subs -> do + forM_ subs $ \ntfId -> updateSubStatus (SMPQueueNtf srv ntfId) NSActive + logSubStatus srv "subscribed" $ length subs + CASubError srv _ errs -> + forM errs (\(ntfId, err) -> handleSubError (SMPQueueNtf srv ntfId) err) >>= logSubErrors srv . catMaybes . L.toList logSubStatus srv event n = diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 5edea1719..63e3e4d98 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -43,7 +43,7 @@ module Simplex.Messaging.Protocol ( -- * SMP protocol parameters supportedSMPClientVRange, maxMessageLength, - paddedProxiedMsgLength, + paddedProxiedTLength, e2eEncConfirmationLength, e2eEncMessageLength, @@ -55,6 +55,7 @@ module Simplex.Messaging.Protocol ProtocolEncoding (..), Command (..), SubscriptionMode (..), + SenderCanSecure, Party (..), Cmd (..), DirectParty, @@ -133,6 +134,7 @@ module Simplex.Messaging.Protocol FwdTransmission (..), MsgFlags (..), initialSMPClientVersion, + currentSMPClientVersion, userProtocol, rcvMessageMeta, noMsgFlags, @@ -153,6 +155,7 @@ module Simplex.Messaging.Protocol legacyServerP, legacyStrEncodeServer, srvHostnamesSMPClientVersion, + sndAuthKeySMPClientVersion, sameSrvAddr, sameSrvAddr', noAuthSrv, @@ -240,8 +243,11 @@ initialSMPClientVersion = VersionSMPC 1 srvHostnamesSMPClientVersion :: VersionSMPC srvHostnamesSMPClientVersion = VersionSMPC 2 +sndAuthKeySMPClientVersion :: VersionSMPC +sndAuthKeySMPClientVersion = VersionSMPC 3 + currentSMPClientVersion :: VersionSMPC -currentSMPClientVersion = VersionSMPC 2 +currentSMPClientVersion = VersionSMPC 3 supportedSMPClientVRange :: VersionRangeSMPC supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion @@ -252,8 +258,8 @@ maxMessageLength v | v >= sendingProxySMPVersion = 16064 -- max 16067 | otherwise = 16088 -- 16064 - always use this size to determine allowed ranges -paddedProxiedMsgLength :: Int -paddedProxiedMsgLength = 16242 -- 16241 .. 16243 +paddedProxiedTLength :: Int +paddedProxiedTLength = 16242 -- 16241 .. 16243 -- TODO v6.0 change to 16064 type MaxMessageLen = 16088 @@ -377,7 +383,7 @@ data Command (p :: Party) where -- v6 of SMP servers only support signature algorithm for command authorization. -- v7 of SMP servers additionally support additional layer of authenticated encryption. -- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys. - NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient + NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient SUB :: Command Recipient KEY :: SndPublicAuthKey -> Command Recipient NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient @@ -390,6 +396,7 @@ data Command (p :: Party) where DEL :: Command Recipient QUE :: Command Recipient -- SMP sender commands + SKEY :: SndPublicAuthKey -> Command Sender -- SEND v1 has to be supported for encoding/decoding -- SEND :: MsgBody -> Command Sender SEND :: MsgFlags -> MsgBody -> Command Sender @@ -432,6 +439,8 @@ instance Encoding SubscriptionMode where 'C' -> pure SMOnlyCreate _ -> fail "bad SubscriptionMode" +type SenderCanSecure = Bool + newtype EncTransmission = EncTransmission ByteString deriving (Show) @@ -664,6 +673,7 @@ data CommandTag (p :: Party) where OFF_ :: CommandTag Recipient DEL_ :: CommandTag Recipient QUE_ :: CommandTag Recipient + SKEY_ :: CommandTag Sender SEND_ :: CommandTag Sender PING_ :: CommandTag Sender PRXY_ :: CommandTag ProxiedClient @@ -712,6 +722,7 @@ instance PartyI p => Encoding (CommandTag p) where OFF_ -> "OFF" DEL_ -> "DEL" QUE_ -> "QUE" + SKEY_ -> "SKEY" SEND_ -> "SEND" PING_ -> "PING" PRXY_ -> "PRXY" @@ -732,6 +743,7 @@ instance ProtocolMsgTag CmdTag where "OFF" -> Just $ CT SRecipient OFF_ "DEL" -> Just $ CT SRecipient DEL_ "QUE" -> Just $ CT SRecipient QUE_ + "SKEY" -> Just $ CT SSender SKEY_ "SEND" -> Just $ CT SSender SEND_ "PING" -> Just $ CT SSender PING_ "PRXY" -> Just $ CT SProxiedClient PRXY_ @@ -1106,7 +1118,8 @@ instance FromJSON CorrId where data QueueIdsKeys = QIK { rcvId :: RecipientId, sndId :: SenderId, - rcvPublicDhKey :: RcvPublicDhKey + rcvPublicDhKey :: RcvPublicDhKey, + sndSecure :: SenderCanSecure } deriving (Eq, Show) @@ -1277,7 +1290,8 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg - instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where type Tag (Command p) = CommandTag p encodeProtocol v = \case - NEW rKey dhKey auth_ subMode + NEW rKey dhKey auth_ subMode sndSecure + | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure) | v >= subModeSMPVersion -> new <> auth <> e subMode | v == basicAuthSMPVersion -> new <> auth | otherwise -> new @@ -1293,6 +1307,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where OFF -> e OFF_ DEL -> e DEL_ QUE -> e QUE_ + SKEY k -> e (SKEY_, ' ', k) SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg) PING -> e PING_ NSUB -> e NSUB_ @@ -1318,6 +1333,9 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where SEND {} | B.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd + SKEY _ + | isNothing auth || B.null entId -> Left $ CMD NO_AUTH + | otherwise -> Right cmd PING -> noAuthCmd PRXY {} -> noAuthCmd PFWD {} @@ -1344,9 +1362,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= subModeSMPVersion -> new <*> auth <*> smpP - | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe - | otherwise -> new <*> pure Nothing <*> pure SMSubscribe + | v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP + | v >= subModeSMPVersion -> new <*> auth <*> smpP <*> pure False + | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe <*> pure False + | otherwise -> new <*> pure Nothing <*> pure SMSubscribe <*> pure False where new = NEW <$> _smpP <*> smpP auth = optional (A.char 'A' *> smpP) @@ -1361,6 +1380,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where QUE_ -> pure QUE CT SSender tag -> Cmd SSender <$> case tag of + SKEY_ -> SKEY <$> _smpP SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP) PING_ -> pure PING RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP) @@ -1377,8 +1397,12 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where type Tag BrokerMsg = BrokerMsgTag - encodeProtocol _v = \case - IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh) + encodeProtocol v = \case + IDS (QIK rcvId sndId srvDh sndSecure) + | v >= sndAuthKeySMPVersion -> ids <> e sndSecure + | otherwise -> ids + where + ids = e (IDS_, ' ', rcvId, sndId, srvDh) MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -> e (MSG_, ' ', msgId, Tail body) NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh) @@ -1395,13 +1419,17 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where e :: Encoding a => a -> ByteString e = smpEncode - protocolP _v = \case + protocolP v = \case MSG_ -> do msgId <- _smpP MSG . RcvMessage msgId <$> bodyP where bodyP = EncRcvMsgBody . unTail <$> smpP - IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP) + IDS_ + | v >= sndAuthKeySMPVersion -> ids smpP + | otherwise -> ids $ pure False + where + ids p = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p) NID_ -> NID <$> _smpP <*> smpP NMSG_ -> NMSG <$> _smpP <*> smpP PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP)) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 5c8d13a5e..014bcd366 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -70,7 +70,7 @@ import GHC.Stats (getRTSStats) import GHC.TypeLits (KnownNat) import Network.Socket (ServiceName, Socket, socketToHandle) import Simplex.Messaging.Agent.Lock -import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPMessage, smpProxyError, temporaryClientError) +import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, forwardSMPTransmission, smpProxyError, temporaryClientError) import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -193,8 +193,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do CAConnected srv -> logInfo $ "SMP server connected " <> showServer' srv CADisconnected srv [] -> logInfo $ "SMP server disconnected " <> showServer' srv CADisconnected srv subs -> logError $ "SMP server disconnected " <> showServer' srv <> " / subscriptions: " <> tshow (length subs) - CAResubscribed srv subs -> logError $ "SMP server resubscribed " <> showServer' srv <> " / subscriptions: " <> tshow (length subs) - CASubError srv errs -> logError $ "SMP server subscription errors " <> showServer' srv <> " / errors: " <> tshow (length errs) + CASubscribed srv _ subs -> logError $ "SMP server subscribed " <> showServer' srv <> " / subscriptions: " <> tshow (length subs) + CASubError srv _ errs -> logError $ "SMP server subscription errors " <> showServer' srv <> " / errors: " <> tshow (length errs) where showServer' = decodeLatin1 . strEncode . host @@ -514,11 +514,11 @@ clientDisconnected c@Client {clientId, subscriptions, connected, sessionId, endT sameClientId :: Client -> Client -> Bool sameClientId Client {clientId} Client {clientId = cId'} = clientId == cId' -cancelSub :: TVar Sub -> IO () -cancelSub sub = - readTVarIO sub >>= \case - Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread - _ -> return () +cancelSub :: Sub -> IO () +cancelSub s = + readTVarIO (subThread s) >>= \case + SubThread t -> liftIO $ deRefWeak t >>= mapM_ killThread + _ -> pure () receive :: Transport c => THandleSMP c 'TServer -> Client -> M () receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do @@ -607,9 +607,10 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed verifyTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult verifyTransmission auth_ tAuth authorized queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k + Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient - -- SEND will be accepted without authorization before the queue is secured with KEY command + -- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command + Cmd SSender (SKEY k) -> verifyQueue (\q -> Just q `verifiedWith` k) <$> get SSender Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing Cmd SSender RFWD {} -> pure $ VRVerified Nothing @@ -682,7 +683,7 @@ forkClient Client {endThreads, endThreadSeq} label action = do mkWeakThreadId t >>= atomically . modifyTVar' endThreads . IM.insert tId client :: THandleParams SMPVersion 'TServer -> Client -> Server -> M () -client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, notifiers} = do +client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId, procThreads} Server {subscribedQ, ntfSubscribedQ, subscribers, notifiers} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" forever $ atomically (readTBQueue rcvQ) @@ -741,7 +742,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi inc own pRequests if v >= sendingProxySMPVersion then forkProxiedCmd $ do - liftIO (runExceptT (forwardSMPMessage smp corrId fwdV pubKey encBlock) `catch` (pure . Left . PCEIOError)) >>= \case + liftIO (runExceptT (forwardSMPTransmission smp corrId fwdV pubKey encBlock) `catch` (pure . Left . PCEIOError)) >>= \case Right r -> PRES r <$ inc own pSuccesses Left e -> ERR (smpProxyError e) <$ case e of PCEProtocolError {} -> inc own pSuccesses @@ -768,13 +769,18 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi transportErr :: TransportError -> ErrorType transportErr = PROXY . BROKER . TRANSPORT mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> TVar Int) -> m () - mkIncProxyStats ps psOwn = \own sel -> do + mkIncProxyStats ps psOwn own sel = do atomically $ modifyTVar' (sel ps) (+ 1) when own $ atomically $ modifyTVar' (sel psOwn) (+ 1) processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Maybe (Transmission BrokerMsg)) processCommand (qr_, (corrId, queueId, cmd)) = case cmd of Cmd SProxiedClient command -> processProxiedCmd (corrId, queueId, command) Cmd SSender command -> Just <$> case command of + SKEY sKey -> (corrId,queueId,) <$> case qr_ of + Just QueueRec {sndSecure, recipientId} + | sndSecure -> secureQueue_ "SKEY" recipientId sKey + | otherwise -> pure $ ERR AUTH + Nothing -> pure $ ERR INTERNAL SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody PING -> pure (corrId, "", PONG) RFWD encBlock -> (corrId, "",) <$> processForwardedCommand encBlock @@ -782,10 +788,10 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi Cmd SRecipient command -> do st <- asks queueStore Just <$> case command of - NEW rKey dhKey auth subMode -> + NEW rKey dhKey auth subMode sndSecure -> ifM allowNew - (createQueue st rKey dhKey subMode) + (createQueue st rKey dhKey subMode sndSecure) (pure (corrId, queueId, ERR AUTH)) where allowNew = do @@ -794,18 +800,20 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi SUB -> withQueue (`subscribeQueue` queueId) GET -> withQueue getMessage ACK msgId -> withQueue (`acknowledgeMsg` msgId) - KEY sKey -> secureQueue_ st sKey + KEY sKey -> (corrId,queueId,) <$> case qr_ of + Just QueueRec {recipientId} -> secureQueue_ "KEY" recipientId sKey + Nothing -> pure $ ERR INTERNAL NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey NDEL -> deleteQueueNotifier_ st OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st QUE -> withQueue getQueueInfo where - createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> M (Transmission BrokerMsg) - createQueue st recipientKey dhKey subMode = time "NEW" $ do + createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg) + createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvDhSecret = C.dh' dhKey privDhKey - qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey} + qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure} qRec (recipientId, senderId) = QueueRec { recipientId, @@ -814,7 +822,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi rcvDhSecret, senderKey = Nothing, notifier = Nothing, - status = QueueActive + status = QueueActive, + sndSecure } (corrId,queueId,) <$> addQueueRetry 3 qik qRec where @@ -849,12 +858,13 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi n <- asks $ queueIdBytes . config liftM2 (,) (randomId n) (randomId n) - secureQueue_ :: QueueStore -> SndPublicAuthKey -> M (Transmission BrokerMsg) - secureQueue_ st sKey = time "KEY" $ do - withLog $ \s -> logSecureQueue s queueId sKey + secureQueue_ :: T.Text -> RecipientId -> SndPublicAuthKey -> M BrokerMsg + secureQueue_ name rId sKey = time name $ do + withLog $ \s -> logSecureQueue s rId sKey + st <- asks queueStore stats <- asks serverStats atomically $ modifyTVar' (qSecured stats) (+ 1) - atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey + atomically $ either ERR (const OK) <$> secureQueue st rId sKey addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do @@ -891,36 +901,36 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi Nothing -> do atomically $ modifyTVar' (qSub stats) (+ 1) newSub >>= deliver - Just sub -> - readTVarIO sub >>= \case - Sub {subThread = ProhibitSub} -> do + Just s@Sub {subThread} -> + readTVarIO subThread >>= \case + ProhibitSub -> do -- cannot use SUB in the same connection where GET was used atomically $ modifyTVar' (qSubProhibited stats) (+ 1) pure (corrId, rId, ERR $ CMD PROHIBITED) - s -> do + _ -> do atomically $ modifyTVar' (qSubDuplicate stats) (+ 1) - atomically (tryTakeTMVar $ delivered s) >> deliver sub + atomically (tryTakeTMVar $ delivered s) >> deliver s where - newSub :: M (TVar Sub) + newSub :: M Sub newSub = time "SUB newSub" . atomically $ do writeTQueue subscribedQ (rId, clnt) - sub <- newTVar =<< newSubscription NoSub + sub <- newSubscription NoSub TM.insert rId sub subscriptions pure sub - deliver :: TVar Sub -> M (Transmission BrokerMsg) + deliver :: Sub -> M (Transmission BrokerMsg) deliver sub = do q <- getStoreMsgQueue "SUB" rId msg_ <- atomically $ tryPeekMsg q - deliverMessage "SUB" qr rId sub q msg_ + deliverMessage "SUB" qr rId sub msg_ getMessage :: QueueRec -> M (Transmission BrokerMsg) getMessage qr = time "GET" $ do atomically (TM.lookup queueId subscriptions) >>= \case Nothing -> atomically newSub >>= getMessage_ - Just sub -> - readTVarIO sub >>= \case - s@Sub {subThread = ProhibitSub} -> + Just s@Sub {subThread} -> + readTVarIO subThread >>= \case + ProhibitSub -> atomically (tryTakeTMVar $ delivered s) >> getMessage_ s -- cannot use GET in the same connection where there is an active subscription @@ -929,8 +939,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi newSub :: STM Sub newSub = do s <- newSubscription ProhibitSub - sub <- newTVar s - TM.insert queueId sub subscriptions + TM.insert queueId s subscriptions pure s getMessage_ :: Sub -> M (Transmission BrokerMsg) getMessage_ s = do @@ -958,25 +967,24 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi Nothing -> pure $ err NO_MSG Just sub -> atomically (getDelivered sub) >>= \case - Just s -> do + Just st -> do q <- getStoreMsgQueue "ACK" queueId - case s of - Sub {subThread = ProhibitSub} -> do + case st of + ProhibitSub -> do deletedMsg_ <- atomically $ tryDelMsg q msgId mapM_ updateStats deletedMsg_ pure ok _ -> do (deletedMsg_, msg_) <- atomically $ tryDelPeekMsg q msgId mapM_ updateStats deletedMsg_ - deliverMessage "ACK" qr queueId sub q msg_ + deliverMessage "ACK" qr queueId sub msg_ _ -> pure $ err NO_MSG where - getDelivered :: TVar Sub -> STM (Maybe Sub) - getDelivered sub = do - s@Sub {delivered} <- readTVar sub + getDelivered :: Sub -> STM (Maybe SubscriptionThread) + getDelivered Sub {delivered, subThread} = do tryTakeTMVar delivered $>>= \msgId' -> if msgId == msgId' || B.null msgId - then pure $ Just s + then Just <$> readTVar subThread else putTMVar delivered msgId' $> Nothing updateStats :: Message -> M () updateStats = \case @@ -1014,7 +1022,8 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi Nothing -> do atomically $ modifyTVar' (msgSentQuota stats) (+ 1) pure $ err QUOTA - Just msg -> time "SEND ok" $ do + Just (msg, wasEmpty) -> time "SEND ok" $ do + when wasEmpty $ tryDeliverMessage msg when (notification msgFlags) $ do forM_ (notifier qr) $ \ntf -> do asks random >>= atomically . trySendNotification ntf msg >>= \case @@ -1048,6 +1057,52 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi stats <- asks serverStats atomically $ modifyTVar' (msgExpired stats) (+ deleted) + -- The condition for delivery of the message is: + -- - the queue was empty when the message was sent, + -- - there is subscribed recipient, + -- - no message was "delivered" that was not acknowledged. + -- If the send queue of the subscribed client is not full the message is put there in the same transaction. + -- If the queue is not full, then the thread is created where these checks are made: + -- - it is the same subscribed client (in case it was reconnected it would receive message via SUB command) + -- - nothing was delivered to this subscription (to avoid race conditions with the recipient). + tryDeliverMessage :: Message -> M () + tryDeliverMessage msg = atomically deliverToSub >>= mapM_ forkDeliver + where + rId = recipientId qr + deliverToSub = + TM.lookup rId subscribers + $>>= \rc@Client {subscriptions = subs, sndQ = q} -> TM.lookup rId subs + $>>= \s@Sub {subThread, delivered} -> readTVar subThread >>= \case + NoSub -> + tryTakeTMVar delivered >>= \case + Just _ -> pure Nothing -- if a message was already delivered, should not deliver more + Nothing -> + ifM + (isFullTBQueue q) + (writeTVar subThread SubPending $> Just (rc, s)) + (deliver q s $> Nothing) + _ -> pure Nothing + deliver q s = do + let encMsg = encryptMsg qr msg + writeTBQueue q [(CorrId "", rId, MSG encMsg)] + void $ setDelivered s msg + forkDeliver (rc@Client {sndQ = q}, s@Sub {subThread, delivered}) = do + t <- mkWeakThreadId =<< forkIO deliverThread + atomically . modifyTVar' subThread $ \case + -- this case is needed because deliverThread can exit before it + SubPending -> SubThread t + st -> st + where + deliverThread = do + labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " deliver/SEND" + time "deliver" . atomically $ + whenM (maybe False (sameClientId rc) <$> TM.lookup rId subscribers) $ do + tryTakeTMVar delivered >>= \case + Just _ -> pure () -- if a message was already delivered, should not deliver more + Nothing -> do + deliver q s + writeTVar subThread NoSub + trySendNotification :: NtfCreds -> Message -> TVar ChaChaDRG -> STM (Maybe Bool) trySendNotification NtfCreds {notifierId, rcvNtfDhSecret} msg ntfNonceDrg = mapM (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers @@ -1085,16 +1140,13 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi t :| [] -> pure $ tDecodeParseValidate clntTHParams t _ -> throwE BLOCK let clntThAuth = Just $ THAuthServer {serverPrivKey, sessSecret' = Just clientSecret} - -- process forwarded SEND + -- process forwarded command r <- lift (rejectOrVerify clntThAuth t') >>= \case Left r -> pure r - Right t''@(_, (corrId', entId', cmd')) -> case cmd' of - Cmd SSender SEND {} -> - -- Left will not be returned by processCommand, as only SEND command is allowed - fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'') - _ -> - pure (corrId', entId', ERR $ CMD PROHIBITED) + -- rejectOrVerify filters allowed commands, no need to repeat it here. + -- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types). + Right t''@(_, (corrId', entId', _)) -> fromMaybe (corrId', entId', ERR INTERNAL) <$> lift (processCommand t'') -- encode response r' <- case batchTransmissions (batch clntTHParams) (blockSize clntTHParams) [Right (Nothing, encodeTransmission clntTHParams r)] of [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right @@ -1102,7 +1154,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi TBTransmission b' _ : _ -> pure b' TBTransmissions b' _ _ : _ -> pure b' -- encrypt to client - r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedMsgLength + r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedTLength -- encrypt to proxy let fr = FwdResponse {fwdCorrId, fwdResponse = r2} r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr) @@ -1114,42 +1166,28 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) = case cmdOrError of Left e -> pure $ Left (corrId', entId', ERR e) - Right cmd'@(Cmd SSender SEND {}) -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId')) <$> clntThAuth) tAuth authorized entId' cmd' + Right cmd' + | allowed -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId')) <$> clntThAuth) tAuth authorized entId' cmd' + | otherwise -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED) where + allowed = case cmd' of + Cmd SSender SEND {} -> True + Cmd SSender (SKEY _) -> True + _ -> False verified = \case VRVerified qr -> Right (qr, (corrId', entId', cmd')) VRFailed -> Left (corrId', entId', ERR AUTH) - Right _ -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED) - - deliverMessage :: T.Text -> QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> M (Transmission BrokerMsg) - deliverMessage name qr rId sub q msg_ = time (name <> " deliver") $ do - readTVarIO sub >>= \case - s@Sub {subThread = NoSub} -> - case msg_ of - Just msg -> - let encMsg = encryptMsg qr msg - in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg) - _ -> forkSub $> resp - _ -> pure resp + deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> M (Transmission BrokerMsg) + deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") . atomically $ + readTVar subThread >>= \case + ProhibitSub -> pure resp + _ -> case msg_ of + Just msg -> + let encMsg = encryptMsg qr msg + in setDelivered s msg $> (corrId, rId, MSG encMsg) + _ -> pure resp where resp = (corrId, rId, OK) - forkSub :: M () - forkSub = do - atomically . modifyTVar' sub $ \s -> s {subThread = SubPending} - t <- mkWeakThreadId =<< forkIO subscriber - atomically . modifyTVar' sub $ \case - s@Sub {subThread = SubPending} -> s {subThread = SubThread t} - s -> s - where - subscriber = do - labelMyThread $ B.unpack ("client $" <> encode sessionId) <> " subscriber/" <> T.unpack name - msg <- atomically $ peekMsg q - time "subscriber" . atomically $ do - let encMsg = encryptMsg qr msg - writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)] - s <- readTVar sub - void $ setDelivered s msg - writeTVar sub $! s {subThread = NoSub} time :: T.Text -> M a -> M a time name = timed name queueId @@ -1191,9 +1229,9 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi pure QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} pure (corrId, queueId, INFO info) where - mkQSub sub = do - Sub {subThread, delivered} <- readTVar sub - let qSubThread = case subThread of + mkQSub Sub {subThread, delivered} = do + st <- readTVar subThread + let qSubThread = case st of NoSub -> QNoSub SubPending -> QSubPending SubThread _ -> QSubThread diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 4217ea9b9..b40e9fc16 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -47,7 +47,6 @@ data ServerConfig = ServerConfig { transports :: [(ServiceName, ATransport)], smpHandshakeTimeout :: Int, tbqSize :: Natural, - -- serverTbqSize :: Natural, msgQueueQuota :: Int, queueIdBytes :: Int, msgIdBytes :: Int, @@ -145,7 +144,7 @@ type ClientId = Int data Client = Client { clientId :: ClientId, - subscriptions :: TMap RecipientId (TVar Sub), + subscriptions :: TMap RecipientId Sub, ntfSubscriptions :: TMap NotifierId (), rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)), sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)), @@ -164,7 +163,7 @@ data Client = Client data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) | ProhibitSub data Sub = Sub - { subThread :: SubscriptionThread, + { subThread :: TVar SubscriptionThread, delivered :: TMVar MsgId } @@ -194,8 +193,9 @@ newClient nextClientId qSize thVersion sessionId createdAt = do return Client {clientId, subscriptions, ntfSubscriptions, rcvQ, sndQ, msgQ, procThreads, endThreads, endThreadSeq, thVersion, sessionId, connected, createdAt, rcvActiveAt, sndActiveAt} newSubscription :: SubscriptionThread -> STM Sub -newSubscription subThread = do +newSubscription st = do delivered <- newEmptyTMVar + subThread <- newTVar st return Sub {subThread, delivered} newEnv :: ServerConfig -> IO Env diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 7af57ba25..04e14544c 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -255,7 +255,6 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath = { transports = iniTransports ini, smpHandshakeTimeout = 120000000, tbqSize = 64, - -- serverTbqSize = 1024, msgQueueQuota = 128, queueIdBytes = 24, msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20 diff --git a/src/Simplex/Messaging/Server/MsgStore/STM.hs b/src/Simplex/Messaging/Server/MsgStore/STM.hs index e315c4fe5..c8f78e2fb 100644 --- a/src/Simplex/Messaging/Server/MsgStore/STM.hs +++ b/src/Simplex/Messaging/Server/MsgStore/STM.hs @@ -75,7 +75,7 @@ snapshotMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue . mapM_ (writeTQueue q) msgs pure msgs -writeMsg :: MsgQueue -> Message -> STM (Maybe Message) +writeMsg :: MsgQueue -> Message -> STM (Maybe (Message, Bool)) writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do canWrt <- readTVar canWrite empty <- isEmptyTQueue q @@ -85,7 +85,7 @@ writeMsg MsgQueue {msgQueue = q, quota, canWrite, size} !msg = do writeTVar canWrite $! canWrt' modifyTVar' size (+ 1) if canWrt' - then writeTQueue q msg $> Just msg + then writeTQueue q msg $> Just (msg, empty) else (writeTQueue q $! msgQuota) $> Nothing else pure Nothing where diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index cd1b94215..8d5bd8fff 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -14,6 +14,7 @@ data QueueRec = QueueRec rcvDhSecret :: !RcvDhSecret, senderId :: !SenderId, senderKey :: !(Maybe SndPublicAuthKey), + sndSecure :: !SenderCanSecure, notifier :: !(Maybe NtfCreds), status :: !ServerQueueStatus } diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index b1011c404..d1ce15ed6 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -53,7 +54,7 @@ data StoreLogRecord | DeleteNotifier QueueId instance StrEncoding QueueRec where - strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} = + strEncode QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier} = B.unwords [ "rid=" <> strEncode recipientId, "rk=" <> strEncode recipientKey, @@ -61,6 +62,7 @@ instance StrEncoding QueueRec where "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey ] + <> if sndSecure then " sndSecure=" <> strEncode sndSecure else "" <> maybe "" notifierStr notifier where notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds @@ -71,8 +73,9 @@ instance StrEncoding QueueRec where rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ senderKey <- "sk=" *> strP + sndSecure <- (" sndSecure=" *> strP) <|> pure False notifier <- optional $ " notifier=" *> strP - pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive} + pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status = QueueActive} instance StrEncoding StoreLogRecord where strEncode = \case diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index ad0564e46..16bff693a 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -46,6 +46,7 @@ module Simplex.Messaging.Transport subModeSMPVersion, authCmdsSMPVersion, sendingProxySMPVersion, + sndAuthKeySMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -157,14 +158,17 @@ authCmdsSMPVersion = VersionSMP 7 sendingProxySMPVersion :: VersionSMP sendingProxySMPVersion = VersionSMP 8 +sndAuthKeySMPVersion :: VersionSMP +sndAuthKeySMPVersion = VersionSMP 9 + currentClientSMPRelayVersion :: VersionSMP -currentClientSMPRelayVersion = VersionSMP 8 +currentClientSMPRelayVersion = VersionSMP 9 legacyServerSMPRelayVersion :: VersionSMP legacyServerSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 8 +currentServerSMPRelayVersion = VersionSMP 9 -- Max SMP protocol version to be used in e2e encrypted -- connection between client and server, as defined by SMP proxy. @@ -172,7 +176,7 @@ currentServerSMPRelayVersion = VersionSMP 8 -- to prevent client version fingerprinting by the -- destination relays when clients upgrade at different times. proxiedSMPRelayVersion :: VersionSMP -proxiedSMPRelayVersion = VersionSMP 8 +proxiedSMPRelayVersion = VersionSMP 9 -- minimal supported protocol version is 4 -- TODO remove code that supports sending commands without batching diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 37557cd23..b023f460a 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -8,16 +8,19 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as J import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.List (groupBy, sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Time (NominalDiffTime) import GHC.Conc (labelThread, myThreadId, threadDelay) import UnliftIO @@ -170,3 +173,9 @@ diffToMilliseconds diff = fromIntegral ((truncate $ diff * 1000) :: Integer) labelMyThread :: MonadIO m => String -> m () labelMyThread label = liftIO $ myThreadId >>= (`labelThread` label) + +encodeJSON :: ToJSON a => a -> Text +encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode + +decodeJSON :: FromJSON a => Text -> Maybe a +decodeJSON = J.decode . LB.fromStrict . encodeUtf8 diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 20480f84c..8684c787c 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -7,7 +7,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} -module AgentTests.ConnectionRequestTests where +module AgentTests.ConnectionRequestTests + ( connectionRequestTests, + connReqData, + queueAddr, + testE2ERatchetParams12, + ) where import Data.ByteString (ByteString) import Network.HTTP.Types (urlEncode) @@ -15,179 +20,228 @@ import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (ProtocolServer (..), pattern VersionSMPC, supportedSMPClientVRange) +import Simplex.Messaging.Protocol (ProtocolServer (..), currentSMPClientVersion, supportedSMPClientVRange, pattern VersionSMPC) import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import Simplex.Messaging.Version import Test.Hspec -uri :: String -uri = "smp.simplex.im" - srv :: SMPServer -srv = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251") +srv = SMPServer "smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "5223" (C.KeyHash "\215m\248\251") + +srv1 :: SMPServer +srv1 = SMPServer "smp.simplex.im" "5223" (C.KeyHash "\215m\248\251") queueAddr :: SMPQueueAddress queueAddr = SMPQueueAddress { smpServer = srv, senderId = "\223\142z\251", - dhPublicKey = testDhKey + dhPublicKey = testDhKey, + sndSecure = False } +queueAddrSK :: SMPQueueAddress +queueAddrSK = queueAddr {sndSecure = True} + +queueAddr1 :: SMPQueueAddress +queueAddr1 = queueAddr {smpServer = srv1} + queueAddrNoPort :: SMPQueueAddress queueAddrNoPort = queueAddr {smpServer = srv {port = ""}} +queueAddrNoPort1 :: SMPQueueAddress +queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}} + +-- current version range includes version 1 and it uses legacy encoding queue :: SMPQueueUri queue = SMPQueueUri supportedSMPClientVRange queueAddr +queueSK :: SMPQueueUri +queueSK = SMPQueueUri supportedSMPClientVRange queueAddrSK + +queueStr :: ByteString +queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queueStrSK :: ByteString +queueStrSK = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr <> "&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queue1 :: SMPQueueUri +queue1 = SMPQueueUri supportedSMPClientVRange queueAddr1 + +queue1Str :: ByteString +queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-3&dh=" <> url testDhKeyStr + queueV1 :: SMPQueueUri queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr +queueV1NoPort :: SMPQueueUri +queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} + +-- version range 2-3 uses new encoding +-- it is fixed/changed in v5.8.2. +queueNew :: SMPQueueUri +queueNew = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr + +queueNewStr :: ByteString +queueNewStr = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr + +queueNewStr' :: ByteString +queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-3&dh=" <> testDhKeyStr + +queueNewNoPort :: SMPQueueUri +queueNewNoPort = (queueNew :: SMPQueueUri) {queueAddress = queueAddrNoPort} + +queueNew1 :: SMPQueueUri +queueNew1 = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr1 + +queueNew1Str :: ByteString +queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr + +queueNew1NoPort :: SMPQueueUri +queueNew1NoPort = (queueNew1 :: SMPQueueUri) {queueAddress = queueAddrNoPort1} + testDhKey :: C.PublicKeyX25519 testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o=" testDhKeyStr :: ByteString testDhKeyStr = strEncode testDhKey -testDhKeyStrUri :: ByteString -testDhKeyStrUri = urlEncode True testDhKeyStr - connReqData :: ConnReqUriData connReqData = ConnReqUriData { crScheme = SSSimplex, - crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2), - crSmpQueues = [queueV1], + crAgentVRange = supportedSMPAgentVRange, + crSmpQueues = [queue], crClientData = Nothing } +connReqDataSK :: ConnReqUriData +connReqDataSK = connReqData {crSmpQueues = [queueSK]} + +connReqData1 :: ConnReqUriData +connReqData1 = connReqData {crSmpQueues = [queue1]} + +connReqDataV1 :: ConnReqUriData +connReqDataV1 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 1) (VersionSMPA 1)} + +connReqDataV2 :: ConnReqUriData +connReqDataV2 = connReqData {crAgentVRange = mkVersionRange (VersionSMPA 2) (VersionSMPA 2)} + +connReqDataNew :: ConnReqUriData +connReqDataNew = connReqData {crSmpQueues = [queueNew]} + +connReqDataNew1 :: ConnReqUriData +connReqDataNew1 = connReqData {crSmpQueues = [queueNew1]} + testDhPubKey :: C.PublicKeyX448 testDhPubKey = "MEIwBQYDK2VvAzkAmKuSYeQ/m0SixPDS8Wq8VBaTS1cW+Lp0n0h4Diu+kUpR+qXx4SDJ32YGEFoGFGSbGPry5Ychr6U=" testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing +testE2ERatchetParamsStrUri :: ByteString +testE2ERatchetParamsStrUri = "v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" + testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing connectionRequest :: AConnectionRequestUri -connectionRequest = - ACR SCMInvitation $ - CRInvitationUri connReqData testE2ERatchetParams +connectionRequest = ACR SCMInvitation $ CRInvitationUri connReqData testE2ERatchetParams + +connectionRequestSK :: AConnectionRequestUri +connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams + +connectionRequestV1 :: AConnectionRequestUri +connectionRequestV1 = ACR SCMInvitation $ CRInvitationUri connReqDataV1 testE2ERatchetParams + +connectionRequest1 :: AConnectionRequestUri +connectionRequest1 = ACR SCMInvitation $ CRInvitationUri connReqData1 testE2ERatchetParams + +connectionRequestNew :: AConnectionRequestUri +connectionRequestNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew testE2ERatchetParams + +connectionRequestNew1 :: AConnectionRequestUri +connectionRequestNew1 = ACR SCMInvitation $ CRInvitationUri connReqDataNew1 testE2ERatchetParams contactAddress :: AConnectionRequestUri contactAddress = ACR SCMContact $ CRContactUri connReqData -connectionRequestCurrentRange :: AConnectionRequestUri -connectionRequestCurrentRange = - ACR SCMInvitation $ - CRInvitationUri - connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]} - testE2ERatchetParams12 +contactAddressV2 :: AConnectionRequestUri +contactAddressV2 = ACR SCMContact $ CRContactUri connReqDataV2 + +contactAddressNew :: AConnectionRequestUri +contactAddressNew = ACR SCMContact $ CRContactUri connReqDataNew + +connectionRequest2queues :: AConnectionRequestUri +connectionRequest2queues = ACR SCMInvitation $ CRInvitationUri connReqData {crSmpQueues = [queue, queue]} testE2ERatchetParams + +connectionRequest2queuesNew :: AConnectionRequestUri +connectionRequest2queuesNew = ACR SCMInvitation $ CRInvitationUri connReqDataNew {crSmpQueues = [queueNew, queueNew]} testE2ERatchetParams + +contactAddress2queues :: AConnectionRequestUri +contactAddress2queues = ACR SCMContact $ CRContactUri connReqData {crSmpQueues = [queue, queue]} + +contactAddress2queuesNew :: AConnectionRequestUri +contactAddress2queuesNew = ACR SCMContact $ CRContactUri connReqDataNew {crSmpQueues = [queueNew, queueNew]} connectionRequestClientDataEmpty :: AConnectionRequestUri -connectionRequestClientDataEmpty = - ACR SCMInvitation $ - CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams +connectionRequestClientDataEmpty = ACR SCMInvitation $ CRInvitationUri connReqData {crClientData = Just "{}"} testE2ERatchetParams -connectionRequestClientData :: AConnectionRequestUri -connectionRequestClientData = - ACR SCMInvitation $ - CRInvitationUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} testE2ERatchetParams +contactAddressClientData :: AConnectionRequestUri +contactAddressClientData = ACR SCMContact $ CRContactUri connReqData {crClientData = Just "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}"} + +url :: ByteString -> ByteString +url = urlEncode True + +(==#) :: (StrEncoding a, HasCallStack) => a -> ByteString -> Expectation +a ==# s = strEncode a `shouldBe` s + +(#==) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation +a #== s = strDecode s `shouldBe` Right a + +(#==#) :: (StrEncoding a, Eq a, Show a, HasCallStack) => a -> ByteString -> Expectation +a #==# s = do + a ==# s + a #== s connectionRequestTests :: Spec connectionRequestTests = describe "connection request parsing / serializing" $ do - it "should serialize SMP queue URIs" $ do - strEncode (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort} - `shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri - strEncode queue {clientVRange = mkVersionRange (VersionSMPC 1) (VersionSMPC 2)} - `shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-2&dh=" <> testDhKeyStrUri - it "should parse SMP queue URIs" $ do - strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-2&dh=" <> testDhKeyStr) - `shouldBe` Right (queue :: SMPQueueUri) {queueAddress = queueAddrNoPort} - strDecode ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr) - `shouldBe` Right (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr) - `shouldBe` Right queueV1 - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-2&extra_param=abc") - `shouldBe` Right queue - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr) - `shouldBe` Right queueV1 - strDecode ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc") - `shouldBe` Right queueV1 - it "should serialize connection requests" $ do - strEncode connectionRequest - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - strEncode connectionRequestCurrentRange - `shouldBe` "simplex:/invitation#/?v=2-5&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - strEncode connectionRequestClientDataEmpty - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%7D" - strEncode connectionRequestClientData - `shouldBe` "simplex:/invitation#/?v=2&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> urlEncode True testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D" - it "should parse connection requests" $ do - strDecode - ( "https://simplex.chat/contact#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23" - <> testDhKeyStrUri - <> "&v=1" -- adjusted to v2 - ) - `shouldBe` Right contactAddress - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1-1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&v=2-2" - ) - `shouldBe` Right connectionRequest - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26extra_param%3Dabc%26dh%3D" - <> testDhKeyStrUri - <> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=extra_key%3Dnew%26v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&some_new_param=abc" - <> "&v=2-5" - ) - `shouldBe` Right connectionRequestCurrentRange - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%7D" - <> "&v=2-2" - ) - `shouldBe` Right connectionRequestClientDataEmpty - strDecode - ( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D" - <> testDhKeyStrUri - <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D" - <> "&v=2" - ) - `shouldBe` Right connectionRequestClientData + it "should serialize and parse SMP queue URIs" $ do + queue #==# queueStr + queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-3&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueSK #==# queueStrSK + queue1 #==# queue1Str + queueNew #==# queueNewStr + queueNew #== queueNewStr' + queueNew1 #==# queueNew1Str + queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr) + queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-3&dh=" <> url testDhKeyStr) + queueV1 #==# ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1 #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#" <> testDhKeyStr) + queueV1 #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1 #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #== ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=1-1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") + queueV1NoPort #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#" <> testDhKeyStr) + it "should serialize and parse connection invitations and contact addresses" $ do + connectionRequest #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest #== ("https://simplex.chat/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestSK #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest2queues #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNew1 #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueNew1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequest2queuesNew #==# ("simplex:/invitation#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestV1 #== ("https://simplex.chat/invitation#/?v=1&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestClientDataEmpty #==# ("simplex:/invitation#/?v=2-6&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri <> "&data=" <> url "{}") + contactAddress #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr) + contactAddress #== ("https://simplex.chat/contact#/?v=2-6&smp=" <> url queueStr) + contactAddress2queues #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueStr <> ";" <> queueStr)) + contactAddressNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueNewStr) + contactAddress2queuesNew #==# ("simplex:/contact#/?v=2-6&smp=" <> url (queueNewStr <> ";" <> queueNewStr)) + contactAddressV2 #==# ("simplex:/contact#/?v=2&smp=" <> url queueStr) + contactAddressV2 #== ("https://simplex.chat/contact#/?v=1&smp=" <> url queueStr) -- adjusted to v2 + contactAddressV2 #== ("https://simplex.chat/contact#/?v=1-2&smp=" <> url queueStr) -- adjusted to v2 + contactAddressV2 #== ("https://simplex.chat/contact#/?v=2-2&smp=" <> url queueStr) + contactAddressClientData #==# ("simplex:/contact#/?v=2-6&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}") diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index d52c12877..ab78d2ee9 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -25,7 +25,7 @@ module AgentTests.FunctionalAPITests withAgentClients2, withAgentClients3, makeConnection, - exchangeGreetingsMsgId, + exchangeGreetings, switchComplete, createConnection, joinConnection, @@ -47,7 +47,7 @@ module AgentTests.FunctionalAPITests pattern Msg, pattern Msg', pattern SENT, - agentCfgV7, + agentCfgVPrevPQ, ) where @@ -75,10 +75,10 @@ import Data.Word (Word16) import qualified Database.SQLite.Simple as SQL import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn, withSmpServerV7) +import SMPClient (cfg, prevRange, prevVersion, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerProxy, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A -import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) +import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ, SENT) import qualified Simplex.Messaging.Agent.Protocol as A @@ -89,13 +89,13 @@ 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.String -import Simplex.Messaging.Notifications.Transport (NTFVersion, authBatchCmdsNTFVersion, pattern VersionNTF) +import Simplex.Messaging.Notifications.Transport (NTFVersion, pattern VersionNTF) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, supportedSMPHandshakes) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -195,46 +195,25 @@ pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMs smpCfgVPrev :: ProtocolClientConfig SMPVersion smpCfgVPrev = (smpCfg agentCfg) {clientALPN = Nothing, serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} -smpCfgV7 :: ProtocolClientConfig SMPVersion -smpCfgV7 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion} - ntfCfgVPrev :: ProtocolClientConfig NTFVersion ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)} -ntfCfgV2 :: ProtocolClientConfig NTFVersion -ntfCfgV2 = (ntfCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion} - agentCfgVPrev :: AgentConfig -agentCfgVPrev = +agentCfgVPrev = agentCfgVPrevPQ {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} + +agentCfgVPrevPQ :: AgentConfig +agentCfgVPrevPQ = agentCfg { sndAuthAlg = C.AuthAlg C.SEd25519, smpAgentVRange = prevRange $ smpAgentVRange agentCfg, smpClientVRange = prevRange $ smpClientVRange agentCfg, - e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg, smpCfg = smpCfgVPrev, ntfCfg = ntfCfgVPrev } --- agent config for the next client version -agentCfgV7 :: AgentConfig -agentCfgV7 = - agentCfg - { sndAuthAlg = C.AuthAlg C.SX25519, - smpAgentVRange = V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion, - e2eEncryptVRange = V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion, - smpCfg = smpCfgV7, - ntfCfg = ntfCfgV2 - } - agentCfgRatchetVPrev :: AgentConfig agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} -prevRange :: VersionRange v -> VersionRange v -prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} - -prevVersion :: Version v -> Version v -prevVersion (Version v) = Version (v - 1) - mkVersionRange :: Word16 -> Word16 -> VersionRange v mkVersionRange v1 v2 = V.mkVersionRange (Version v1) (Version v2) @@ -284,6 +263,11 @@ functionalAPITests t = do withSmpServer t testAgentClient3 it "should establish connection without PQ encryption and enable it" $ withSmpServer t testEnablePQEncryption + describe "Duplex connection - delivery stress test" $ do + describe "one way (50)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 50 + xdescribe "one way (1000)" $ testMatrix2Stress t $ runAgentClientStressTestOneWay 1000 + describe "two way concurrently (50)" $ testMatrix2Stress t $ runAgentClientStressTestConc 25 + xdescribe "two way concurrently (1000)" $ testMatrix2Stress t $ runAgentClientStressTestConc 500 describe "Establishing duplex connection, different PQ settings" $ do testPQMatrix2 t $ runAgentClientTestPQ True describe "Establishing duplex connection v2, different Ratchet versions" $ @@ -345,6 +329,8 @@ functionalAPITests t = do it "should synchronize ratchets when clients start synchronization simultaneously" $ testRatchetSyncSimultaneous t describe "Subscription mode OnlyCreate" $ do + it "messages delivered only when polled (v8 - slow handshake)" $ + withSmpServer t testOnlyCreatePullSlowHandshake it "messages delivered only when polled" $ withSmpServer t testOnlyCreatePull describe "Inactive client disconnection" $ do @@ -371,14 +357,16 @@ functionalAPITests t = do withSmpServer t $ testBatchedPendingMessages 10 5 describe "Async agent commands" $ do - it "should connect using async agent commands" $ - withSmpServer t testAsyncCommands + describe "connect using async agent commands" $ + testBasicMatrix2 t testAsyncCommands it "should restore and complete async commands on restart" $ testAsyncCommandsRestore t - it "should accept connection using async command" $ - withSmpServer t testAcceptContactAsync + describe "accept connection using async command" $ + testBasicMatrix2 t testAcceptContactAsync it "should delete connections using async command when server connection fails" $ testDeleteConnectionAsync t + it "join connection when reply queue creation fails (v8 - slow handshake)" $ + testJoinConnectionAsyncReplyErrorV8 t it "join connection when reply queue creation fails" $ testJoinConnectionAsyncReplyError t describe "delete connection waiting for delivery" $ do @@ -421,29 +409,30 @@ functionalAPITests t = do describe "SMP basic auth" $ do let v4 = prevVersion basicAuthSMPVersion forM_ (nub [prevVersion authCmdsSMPVersion, authCmdsSMPVersion, currentServerSMPRelayVersion]) $ \v -> do + let baseId = if v >= sndAuthKeySMPVersion then 1 else 3 describe ("v" <> show v <> ": with server auth") $ do -- allow NEW | server auth, v | clnt1 auth, v | clnt2 auth, v | 2 - success, 1 - JOIN fail, 0 - NEW fail - it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 2 - it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) `shouldReturn` 0 - it "NEW fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) `shouldReturn` 0 - it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) `shouldReturn` 1 - it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) `shouldReturn` 1 - it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) `shouldReturn` 1 + it "success " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2 + it "disabled " $ testBasicAuth t False (Just "abcd", v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "wrong", v) (Just "abcd", v) baseId `shouldReturn` 0 + it "NEW fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v4) (Just "abcd", v) baseId `shouldReturn` 0 + it "JOIN fail, no auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 1 + it "JOIN fail, bad auth " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "wrong", v) baseId `shouldReturn` 1 + it "JOIN fail, version " $ testBasicAuth t True (Just "abcd", v) (Just "abcd", v) (Just "abcd", v4) baseId `shouldReturn` 1 describe ("v" <> show v <> ": no server auth") $ do - it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) `shouldReturn` 2 - it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) `shouldReturn` 0 - it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) `shouldReturn` 2 - it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) `shouldReturn` 2 - it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) `shouldReturn` 2 - it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) `shouldReturn` 2 - it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) `shouldReturn` 2 - it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) `shouldReturn` 2 - it "auth fst 2 " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) `shouldReturn` 2 - it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) `shouldReturn` 2 - it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 2 - it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) `shouldReturn` 0 + it "success " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 2 + it "srv disabled" $ testBasicAuth t False (Nothing, v) (Nothing, v) (Nothing, v) baseId `shouldReturn` 0 + it "version srv " $ testBasicAuth t True (Nothing, v4) (Nothing, v) (Nothing, v) 3 `shouldReturn` 2 + it "version fst " $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v) baseId `shouldReturn` 2 + it "version snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Nothing, v4) 3 `shouldReturn` 2 + it "version both" $ testBasicAuth t True (Nothing, v) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2 + it "version all " $ testBasicAuth t True (Nothing, v4) (Nothing, v4) (Nothing, v4) 3 `shouldReturn` 2 + it "auth fst " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Nothing, v) baseId `shouldReturn` 2 + it "auth fst 2 " $ testBasicAuth t True (Nothing, v4) (Just "abcd", v) (Nothing, v) 3 `shouldReturn` 2 + it "auth snd " $ testBasicAuth t True (Nothing, v) (Nothing, v) (Just "abcd", v) baseId `shouldReturn` 2 + it "auth both " $ testBasicAuth t True (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 2 + it "auth, disabled" $ testBasicAuth t False (Nothing, v) (Just "abcd", v) (Just "abcd", v) baseId `shouldReturn` 0 describe "SMP server test via agent API" $ do it "should pass without basic auth" $ testSMPServerConnectionTest t Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing let srv1 = testSMPServer2 {keyHash = "1234"} @@ -471,8 +460,8 @@ functionalAPITests t = do it "server should respond with queue and subscription information" $ withSmpServer t testServerQueueInfo -testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int -testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do +testBasicAuth :: ATransport -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int +testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 baseId = do let testCfg = cfg {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange batchCmdsSMPVersion srvVersion} canCreate1 = canCreateQueue allowNewQueues srv clnt1 canCreate2 = canCreateQueue allowNewQueues srv clnt2 @@ -480,7 +469,7 @@ testBasicAuth t allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 = do | canCreate1 && canCreate2 = 2 | canCreate1 = 1 | otherwise = 0 - created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 + created <- withSmpServerConfigOn t testCfg testPort $ \_ -> testCreateQueueAuth srvVersion clnt1 clnt2 baseId created `shouldBe` expected pure created @@ -491,26 +480,41 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True - it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False - it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn False - it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn False - it "current with v7 server" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False - it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 $ runTest PQSupportOff False it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False +testMatrix2Stress :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2Stress t runTest = do + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aCfg aCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "current" $ withSmpServer t $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn False + it "prev" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfgVPrev 3 $ runTest PQSupportOff False + it "prev to current" $ withSmpServer t $ runTestCfg2 aCfgVPrev aCfg 3 $ runTest PQSupportOff False + it "current to prev" $ withSmpServer t $ runTestCfg2 aCfg aCfgVPrev 3 $ runTest PQSupportOff False + where + aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} + aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval} + aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval} + +testBasicMatrix2 :: HasCallStack => ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testBasicMatrix2 t runTest = do + it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest + it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 3 $ runTest + it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrevPQ agentCfg 3 $ runTest + it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrevPQ 3 $ runTest + testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 t runTest = do - it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True - it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False - it "ratchet next to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 $ runTest PQSupportOn False - it "ratchet current to next" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 $ runTest PQSupportOn False - it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 $ runTest PQSupportOn False - it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 3 $ runTest PQSupportOff False - it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff False - it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff False + it "current, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentCfg agentCfg (initAgentServersProxy SPMAlways SPFProhibit) 1 $ runTest PQSupportOn True + it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True + it "ratchet current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn False + it "ratchet prev" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfgRatchetVPrev 1 $ runTest PQSupportOff False + it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff False + it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff False testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec testServerMatrix2 t runTest = do @@ -533,7 +537,7 @@ pqMatrix2_ pqInv t test = do it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff) it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn) where - runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 + runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 (initAgentServersProxy SPMAlways SPFProhibit) 3 testPQMatrix3 :: HasCallStack => @@ -552,8 +556,8 @@ testPQMatrix3 t test = do where runTest test' = withSmpServerProxy t $ - runTestCfgServers2 agentProxyCfg agentProxyCfg servers 3 $ \a b baseMsgId -> - withAgent 3 agentProxyCfg servers testDB3 $ \c -> test' a b c baseMsgId + runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 servers 3 $ \a b baseMsgId -> + withAgent 3 agentProxyCfgV8 servers testDB3 $ \c -> test' a b c baseMsgId servers = initAgentServersProxy SPMAlways SPFProhibit runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () @@ -630,6 +634,71 @@ runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId = pqConnectionMode :: InitialKeys -> PQSupport -> Bool pqConnectionMode pqMode1 pqMode2 = supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2 +runAgentClientStressTestOneWay :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientStressTestOneWay n pqSupport viaProxy alice bob baseId = runRight_ $ do + let pqEnc = PQEncryption $ supportPQ pqSupport + (aliceId, bobId) <- makeConnection_ pqSupport alice bob + let proxySrv = if viaProxy then Just testSMPServer else Nothing + message i = "message " <> bshow i + concurrently_ + ( forM_ ([1 .. n] :: [Int64]) $ \i -> do + mId <- msgId <$> A.sendMessage alice bobId pqEnc SMP.noMsgFlags (message i) + liftIO $ do + mId >= i `shouldBe` True + let getEvent = + get alice >>= \case + ("", c, A.SENT mId' srv) -> c == bobId && mId' >= baseId + i && srv == proxySrv `shouldBe` True + ("", c, QCONT) -> do + c == bobId `shouldBe` True + getEvent + r -> expectationFailure $ "wrong message: " <> show r + getEvent + ) + ( forM_ ([1 .. n] :: [Int64]) $ \i -> do + get bob >>= \case + ("", c, Msg' mId pq msg) -> do + liftIO $ c == aliceId && mId >= baseId + i && pq == pqEnc && msg == message i `shouldBe` True + ackMessage bob aliceId mId Nothing + r -> liftIO $ expectationFailure $ "wrong message: " <> show r + ) + liftIO $ noMessagesIngoreQCONT alice "nothing else should be delivered to alice" + liftIO $ noMessagesIngoreQCONT bob "nothing else should be delivered to bob" + where + msgId = subtract baseId . fst + +runAgentClientStressTestConc :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientStressTestConc n pqSupport viaProxy alice bob baseId = runRight_ $ do + let pqEnc = PQEncryption $ supportPQ pqSupport + (aliceId, bobId) <- makeConnection_ pqSupport alice bob + let proxySrv = if viaProxy then Just testSMPServer else Nothing + message i = "message " <> bshow i + loop a bId mIdVar i = do + when (i <= n) $ do + mId <- msgId <$> A.sendMessage a bId pqEnc SMP.noMsgFlags (message i) + liftIO $ mId >= i `shouldBe` True + let getEvent = do + get a >>= \case + ("", c, A.SENT _ srv) -> liftIO $ c == bId && srv == proxySrv `shouldBe` True + ("", c, QCONT) -> do + liftIO $ c == bId `shouldBe` True + getEvent + ("", c, Msg' mId pq msg) -> do + -- tests that mId increases + liftIO $ (mId >) <$> atomically (swapTVar mIdVar mId) `shouldReturn` True + liftIO $ c == bId && pq == pqEnc && ("message " `B.isPrefixOf` msg) `shouldBe` True + ackMessage a bId mId Nothing + r -> liftIO $ expectationFailure $ "wrong message: " <> show r + getEvent + amId <- newTVarIO 0 + bmId <- newTVarIO 0 + concurrently_ + (forM_ ([1 .. n * 2] :: [Int64]) $ loop alice bobId amId) + (forM_ ([1 .. n * 2] :: [Int64]) $ loop bob aliceId bmId) + liftIO $ noMessagesIngoreQCONT alice "nothing else should be delivered to alice" + liftIO $ noMessagesIngoreQCONT bob "nothing else should be delivered to bob" + where + msgId = subtract baseId . fst + testEnablePQEncryption :: HasCallStack => IO () testEnablePQEncryption = withAgentClients2 $ \ca cb -> runRight_ $ do @@ -637,48 +706,48 @@ testEnablePQEncryption = (aId, bId) <- makeConnection_ PQSupportOff ca cb let a = (ca, aId) b = (cb, bId) - (a, 4, "msg 1") \#>\ b - (b, 5, "msg 2") \#>\ a + (a, 2, "msg 1") \#>\ b + (b, 3, "msg 2") \#>\ a -- 45 bytes is used by agent message envelope inside double ratchet message envelope let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g' lrg <- largeMsg g PQSupportOff - (a, 6, lrg) \#>\ b - (b, 7, lrg) \#>\ a + (a, 4, lrg) \#>\ b + (b, 5, lrg) \#>\ a -- switched to smaller envelopes (before reporting PQ encryption enabled) sml <- largeMsg g PQSupportOn -- fail because of message size Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg - (9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml - get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False - get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False - ackMessage cb aId 8 Nothing + (7, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml + get ca =##> \case ("", connId, SENT 7) -> connId == bId; _ -> False + get cb =##> \case ("", connId, MsgErr' 6 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False + ackMessage cb aId 6 Nothing -- -- fail in reply to sync IDss Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg - (10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml - get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False - get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False - ackMessage ca bId 10 Nothing - (a, 11, sml) \#>! b + (8, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml + get cb =##> \case ("", connId, SENT 8) -> connId == aId; _ -> False + get ca =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False + ackMessage ca bId 8 Nothing + (a, 9, sml) \#>! b -- PQ encryption now enabled + (b, 10, sml) !#>! a + (a, 11, sml) !#>! b (b, 12, sml) !#>! a - (a, 13, sml) !#>! b - (b, 14, sml) !#>! a -- disabling PQ encryption - (a, 15, sml) !#>\ b - (b, 16, sml) !#>\ a - (a, 17, sml) \#>\ b - (b, 18, sml) \#>\ a + (a, 13, sml) !#>\ b + (b, 14, sml) !#>\ a + (a, 15, sml) \#>\ b + (b, 16, sml) \#>\ a -- enabling PQ encryption again + (a, 17, sml) \#>! b + (b, 18, sml) \#>! a (a, 19, sml) \#>! b - (b, 20, sml) \#>! a - (a, 21, sml) \#>! b - (b, 22, sml) !#>! a - (a, 23, sml) !#>! b + (b, 20, sml) !#>! a + (a, 21, sml) !#>! b -- disabling PQ encryption again - (b, 24, sml) !#>\ a - (a, 25, sml) !#>\ b - (b, 26, sml) \#>\ a - (a, 27, sml) \#>\ b + (b, 22, sml) !#>\ a + (a, 23, sml) !#>\ b + (b, 24, sml) \#>\ a + (a, 25, sml) \#>\ b -- PQ encryption is now disabled, but support remained enabled, so we still cannot send larger messages Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456") Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456") @@ -703,22 +772,22 @@ testAgentClient3 = (aIdForB, bId) <- makeConnection a b (aIdForC, cId) <- makeConnection a c - 4 <- sendMessage a bId SMP.noMsgFlags "b4" - 4 <- sendMessage a cId SMP.noMsgFlags "c4" - 5 <- sendMessage a bId SMP.noMsgFlags "b5" - 5 <- sendMessage a cId SMP.noMsgFlags "c5" - get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 4) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False - get a =##> \case ("", connId, SENT 5) -> connId == bId || connId == cId; _ -> False + 2 <- sendMessage a bId SMP.noMsgFlags "b4" + 2 <- sendMessage a cId SMP.noMsgFlags "c4" + 3 <- sendMessage a bId SMP.noMsgFlags "b5" + 3 <- sendMessage a cId SMP.noMsgFlags "c5" + get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 2) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False + get a =##> \case ("", connId, SENT 3) -> connId == bId || connId == cId; _ -> False get b =##> \case ("", connId, Msg "b4") -> connId == aIdForB; _ -> False - ackMessage b aIdForB 4 Nothing + ackMessage b aIdForB 2 Nothing get b =##> \case ("", connId, Msg "b5") -> connId == aIdForB; _ -> False - ackMessage b aIdForB 5 Nothing + ackMessage b aIdForB 3 Nothing get c =##> \case ("", connId, Msg "c4") -> connId == aIdForC; _ -> False - ackMessage c aIdForC 4 Nothing + ackMessage c aIdForC 2 Nothing get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False - ackMessage c aIdForC 5 Nothing + ackMessage c aIdForC 3 Nothing runAgentClientContactTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientContactTest pqSupport viaProxy alice bob baseId = @@ -803,10 +872,17 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId ackMessage a bId (baseId + 2) Nothing noMessages :: HasCallStack => AgentClient -> String -> Expectation -noMessages c err = tryGet `shouldReturn` () +noMessages = noMessages_ False + +noMessagesIngoreQCONT :: AgentClient -> String -> Expectation +noMessagesIngoreQCONT = noMessages_ True + +noMessages_ :: Bool -> HasCallStack => AgentClient -> String -> Expectation +noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () where tryGet = 10000 `timeout` get c >>= \case + Just (_, _, QCONT) | ingoreQCONT -> noMessages_ ingoreQCONT c err Just msg -> error $ err <> ": " <> show msg _ -> return () @@ -920,11 +996,12 @@ testAllowConnectionClientRestart t = do runRight_ $ do allowConnectionAsync alice "1" bobId confId "alice's connInfo" - get alice =##> \case ("1", _, OK) -> True; _ -> False + get alice ##> ("1", bobId, OK) pure () threadDelay 100000 -- give time to enqueue confirmation (enqueueConfirmation) disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB @@ -937,8 +1014,7 @@ testAllowConnectionClientRestart t = do get alice2 ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") get bob ##> ("", aliceId, CON) - - exchangeGreetingsMsgId 4 alice2 bobId bob aliceId + exchangeGreetings alice2 bobId bob aliceId disposeAgentClient alice2 disposeAgentClient bob @@ -949,7 +1025,7 @@ testIncreaseConnAgentVersion t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -957,42 +1033,46 @@ testIncreaseConnAgentVersion t = do -- version doesn't increase if incompatible disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB runRight_ $ do subscribeConnection alice2 bobId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId checkVersion alice2 bobId 2 checkVersion bob aliceId 2 -- version increases if compatible disposeAgentClient bob + threadDelay 250000 bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 runRight_ $ do subscribeConnection bob2 aliceId - exchangeGreetingsMsgId_ PQEncOff 8 alice2 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob2 aliceId checkVersion alice2 bobId 3 checkVersion bob2 aliceId 3 -- version doesn't decrease, even if incompatible disposeAgentClient alice2 + threadDelay 250000 alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB runRight_ $ do subscribeConnection alice3 bobId - exchangeGreetingsMsgId_ PQEncOff 10 alice3 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 8 alice3 bobId bob2 aliceId checkVersion alice3 bobId 3 checkVersion bob2 aliceId 3 disposeAgentClient bob2 + threadDelay 250000 bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2 runRight_ $ do subscribeConnection bob3 aliceId - exchangeGreetingsMsgId_ PQEncOff 12 alice3 bobId bob3 aliceId + exchangeGreetingsMsgId_ PQEncOff 10 alice3 bobId bob3 aliceId checkVersion alice3 bobId 3 checkVersion bob3 aliceId 3 disposeAgentClient alice3 @@ -1010,7 +1090,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -1018,14 +1098,16 @@ testIncreaseConnAgentVersionMaxCompatible t = do -- version increases to max compatible disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB disposeAgentClient bob + threadDelay 250000 bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB2 runRight_ $ do subscribeConnection alice2 bobId subscribeConnection bob2 aliceId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob2 aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob2 aliceId checkVersion alice2 bobId 3 checkVersion bob2 aliceId 3 disposeAgentClient alice2 @@ -1038,7 +1120,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob - exchangeGreetingsMsgId_ PQEncOff 4 alice bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 2 alice bobId bob aliceId checkVersion alice bobId 2 checkVersion bob aliceId 2 pure (aliceId, bobId) @@ -1046,11 +1128,12 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do -- version increases to max compatible disposeAgentClient alice + threadDelay 250000 alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB runRight_ $ do subscribeConnection alice2 bobId - exchangeGreetingsMsgId_ PQEncOff 6 alice2 bobId bob aliceId + exchangeGreetingsMsgId_ PQEncOff 4 alice2 bobId bob aliceId checkVersion alice2 bobId 3 checkVersion bob aliceId 3 disposeAgentClient alice2 @@ -1064,13 +1147,13 @@ testDeliverClientRestart t = do (aliceId, bobId) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do runRight $ do (aliceId, bobId) <- makeConnection alice bob - exchangeGreetingsMsgId 4 alice bobId bob aliceId + exchangeGreetings alice bobId bob aliceId pure (aliceId, bobId) ("", "", DOWN _ _) <- nGet alice ("", "", DOWN _ _) <- nGet bob - 6 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello" + 4 <- runRight $ sendMessage bob aliceId SMP.noMsgFlags "hello" disposeAgentClient bob @@ -1082,7 +1165,7 @@ testDeliverClientRestart t = do subscribeConnection bob2 aliceId - get bob2 ##> ("", aliceId, SENT 6) + get bob2 ##> ("", aliceId, SENT 4) get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False disposeAgentClient alice disposeAgentClient bob2 @@ -1094,19 +1177,20 @@ testDuplicateMessage t = do (aliceId, bobId, bob1) <- withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False disposeAgentClient bob + threadDelay 250000 -- if the agent user did not send ACK, the message will be delivered again bob1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2 runRight_ $ do subscribeConnection bob1 aliceId get bob1 =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob1 aliceId 4 Nothing - 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" - get alice ##> ("", bobId, SENT 5) + ackMessage bob1 aliceId 2 Nothing + 3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + get alice ##> ("", bobId, SENT 3) get bob1 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False pure (aliceId, bobId, bob1) @@ -1116,10 +1200,11 @@ testDuplicateMessage t = do -- commenting two lines below and uncommenting further two lines would also runRight_, -- it is the scenario tested above, when the message was not acknowledged by the user threadDelay 200000 - Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 5 Nothing + Left (BROKER _ NETWORK) <- runExceptT $ ackMessage bob1 aliceId 3 Nothing disposeAgentClient alice disposeAgentClient bob1 + threadDelay 250000 alice2 <- getSMPAgentClient' 4 agentCfg initAgentServers testDB bob2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB2 @@ -1131,8 +1216,8 @@ testDuplicateMessage t = do -- get bob2 =##> \case ("", c, Msg "hello 2") -> c == aliceId; _ -> False -- ackMessage bob2 aliceId 5 Nothing -- message 2 is not delivered again, even though it was delivered to the agent - 6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3" - get alice2 ##> ("", bobId, SENT 6) + 4 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 3" + get alice2 ##> ("", bobId, SENT 4) get bob2 =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False disposeAgentClient alice2 disposeAgentClient bob2 @@ -1144,20 +1229,20 @@ testSkippedMessages t = do (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId 4 Nothing + ackMessage bob aliceId 2 Nothing disposeAgentClient bob runRight_ $ do - 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + 3 <- sendMessage alice bobId SMP.noMsgFlags "hello 2" + get alice ##> ("", bobId, SENT 3) + 4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" + get alice ##> ("", bobId, SENT 4) + 5 <- sendMessage alice bobId SMP.noMsgFlags "hello 4" get alice ##> ("", bobId, SENT 5) - 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" - get alice ##> ("", bobId, SENT 6) - 7 <- sendMessage alice bobId SMP.noMsgFlags "hello 4" - get alice ##> ("", bobId, SENT 7) pure (aliceId, bobId) @@ -1174,15 +1259,15 @@ testSkippedMessages t = do subscribeConnection bob2 aliceId subscribeConnection alice2 bobId - 8 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5" - get alice2 ##> ("", bobId, SENT 8) - get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 4, toMsgId = 6}}} _ "hello 5") -> c == aliceId; _ -> False - ackMessage bob2 aliceId 5 Nothing + 6 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 5" + get alice2 ##> ("", bobId, SENT 6) + get bob2 =##> \case ("", c, MSG MsgMeta {integrity = MsgError {errorInfo = MsgSkipped {fromMsgId = 3, toMsgId = 5}}} _ "hello 5") -> c == aliceId; _ -> False + ackMessage bob2 aliceId 3 Nothing - 9 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6" - get alice2 ##> ("", bobId, SENT 9) + 7 <- sendMessage alice2 bobId SMP.noMsgFlags "hello 6" + get alice2 ##> ("", bobId, SENT 7) get bob2 =##> \case ("", c, Msg "hello 6") -> c == aliceId; _ -> False - ackMessage bob2 aliceId 6 Nothing + ackMessage bob2 aliceId 4 Nothing disposeAgentClient alice2 disposeAgentClient bob2 @@ -1192,18 +1277,17 @@ testDeliveryAfterSubscriptionError t = do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello" + 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello" liftIO $ noMessages b "not delivered" pure (aId, bId) withAgentClients2 $ \a b -> do Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection a bId Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId - pure () withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - withUP a bId $ \case ("", c, SENT 4) -> c == bId; _ -> False + withUP a bId $ \case ("", c, SENT 2) -> c == bId; _ -> False withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing testMsgDeliveryQuotaExceeded :: HasCallStack => ATransport -> IO () testMsgDeliveryQuotaExceeded t = @@ -1213,74 +1297,74 @@ testMsgDeliveryQuotaExceeded t = forM_ ([1 .. 4] :: [Int]) $ \i -> do mId <- sendMessage a bId SMP.noMsgFlags $ "message " <> bshow i get a =##> \case ("", c, SENT mId') -> bId == c && mId == mId'; _ -> False - 8 <- sendMessage a bId SMP.noMsgFlags "over quota" - pGet' a False =##> \case ("", c, AEvt _ (MWARN 8 (SMP _ QUOTA))) -> bId == c; _ -> False - 4 <- sendMessage a bId' SMP.noMsgFlags "hello" - get a =##> \case ("", c, SENT 4) -> bId' == c; _ -> False + 6 <- sendMessage a bId SMP.noMsgFlags "over quota" + pGet' a False =##> \case ("", c, AEvt _ (MWARN 6 (SMP _ QUOTA))) -> bId == c; _ -> False + 2 <- sendMessage a bId' SMP.noMsgFlags "hello" + get a =##> \case ("", c, SENT 2) -> bId' == c; _ -> False get b =##> \case ("", c, Msg "message 1") -> aId == c; _ -> False get b =##> \case ("", c, Msg "hello") -> aId' == c; _ -> False - ackMessage b aId' 4 Nothing - ackMessage b aId 4 Nothing + ackMessage b aId' 2 Nothing + ackMessage b aId 2 Nothing get b =##> \case ("", c, Msg "message 2") -> aId == c; _ -> False - ackMessage b aId 5 Nothing + ackMessage b aId 3 Nothing get b =##> \case ("", c, Msg "message 3") -> aId == c; _ -> False - ackMessage b aId 6 Nothing + ackMessage b aId 4 Nothing get b =##> \case ("", c, Msg "message 4") -> aId == c; _ -> False - ackMessage b aId 7 Nothing + ackMessage b aId 5 Nothing get a =##> \case ("", c, QCONT) -> bId == c; _ -> False get b =##> \case ("", c, Msg "over quota") -> aId == c; _ -> False - ackMessage b aId 9 Nothing -- msg 8 was QCONT - get a =##> \case ("", c, SENT 8) -> bId == c; _ -> False + ackMessage b aId 7 Nothing -- msg 8 was QCONT + get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events") testExpireMessage :: HasCallStack => ATransport -> IO () testExpireMessage t = - withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" - threadDelay 1000000 - 5 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + 2 <- runRight $ sendMessage a bId SMP.noMsgFlags "1" + threadDelay 1500000 + 3 <- runRight $ sendMessage a bId SMP.noMsgFlags "2" -- this won't expire + get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 3) "2") -> True; _ -> False - ackMessage b aId 4 Nothing + withUP a bId $ \case ("", _, SENT 3) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False + ackMessage b aId 2 Nothing testExpireManyMessages :: HasCallStack => ATransport -> IO () testExpireManyMessages t = - withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> + withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b runRight_ $ do nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False - 4 <- sendMessage a bId SMP.noMsgFlags "1" - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" - liftIO $ threadDelay 1000000 - 7 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire - get a =##> \case ("", c, MERR 4 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False + 2 <- sendMessage a bId SMP.noMsgFlags "1" + 3 <- sendMessage a bId SMP.noMsgFlags "2" + 4 <- sendMessage a bId SMP.noMsgFlags "3" + liftIO $ threadDelay 1500000 + 5 <- sendMessage a bId SMP.noMsgFlags "4" -- this won't expire + get a =##> \case ("", c, MERR 2 (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False -- get a =##> \case ("", c, MERRS [5, 6] (BROKER _ e)) -> bId == c && (e == TIMEOUT || e == NETWORK); _ -> False let expected c e = bId == c && (e == TIMEOUT || e == NETWORK) get a >>= \case - ("", c, MERR 5 (BROKER _ e)) -> do + ("", c, MERR 3 (BROKER _ e)) -> do liftIO $ expected c e `shouldBe` True - get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [6] (BROKER _ e')) -> expected c' e'; _ -> False - ("", c, MERRS [5] (BROKER _ e)) -> do + get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; ("", c', MERRS [6] (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [3] (BROKER _ e)) -> do liftIO $ expected c e `shouldBe` True - get a =##> \case ("", c', MERR 6 (BROKER _ e')) -> expected c' e'; _ -> False - ("", c, MERRS [5, 6] (BROKER _ e)) -> + get a =##> \case ("", c', MERR 4 (BROKER _ e')) -> expected c' e'; _ -> False + ("", c, MERRS [3, 4] (BROKER _ e)) -> liftIO $ expected c e `shouldBe` True r -> error $ show r withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - withUP a bId $ \case ("", _, SENT 7) -> True; _ -> False - withUP b aId $ \case ("", _, MsgErr 4 (MsgSkipped 3 5) "4") -> True; _ -> False - ackMessage b aId 4 Nothing + withUP a bId $ \case ("", _, SENT 5) -> True; _ -> False + withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 4) "4") -> True; _ -> False + ackMessage b aId 2 Nothing -withUP :: AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO () +withUP :: HasCallStack => AgentClient -> ConnId -> (AEntityTransmission 'AEConn -> Bool) -> ExceptT AgentErrorType IO () withUP a bId p = liftIO $ getInAnyOrder @@ -1296,23 +1380,23 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP (aId, bId) <- runRight $ do (aId, bId) <- makeConnection a b liftIO $ threadDelay 500000 >> disposeAgentClient b - 4 <- sendMessage a bId SMP.noMsgFlags "1" - get a ##> ("", bId, SENT 4) - 5 <- sendMessage a bId SMP.noMsgFlags "2" + 2 <- sendMessage a bId SMP.noMsgFlags "1" + get a ##> ("", bId, SENT 2) + 3 <- sendMessage a bId SMP.noMsgFlags "2" liftIO $ threadDelay 1000000 - 6 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire - get a =##> \case ("", c, MERR 5 (SMP _ QUOTA)) -> bId == c; _ -> False + 4 <- sendMessage a bId SMP.noMsgFlags "3" -- this won't expire + get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False pure (aId, bId) withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False - ackMessage b' aId 4 Nothing + ackMessage b' aId 2 Nothing liftIO . getInAnyOrder a $ - [ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False, + [ \case ("", c, AEvt SAEConn (SENT 4)) -> c == bId; _ -> False, \case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False ] - get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False - ackMessage b' aId 6 Nothing + get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 3) "3") -> c == aId; _ -> False + ackMessage b' aId 4 Nothing disposeAgentClient a testExpireManyMessagesQuota :: ATransport -> IO () @@ -1322,34 +1406,34 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} (aId, bId) <- runRight $ do (aId, bId) <- makeConnection a b liftIO $ threadDelay 500000 >> disposeAgentClient b - 4 <- sendMessage a bId SMP.noMsgFlags "1" - get a ##> ("", bId, SENT 4) - 5 <- sendMessage a bId SMP.noMsgFlags "2" - 6 <- sendMessage a bId SMP.noMsgFlags "3" - 7 <- sendMessage a bId SMP.noMsgFlags "4" + 2 <- sendMessage a bId SMP.noMsgFlags "1" + get a ##> ("", bId, SENT 2) + 3 <- sendMessage a bId SMP.noMsgFlags "2" + 4 <- sendMessage a bId SMP.noMsgFlags "3" + 5 <- sendMessage a bId SMP.noMsgFlags "4" liftIO $ threadDelay 1000000 - 8 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire - get a =##> \case ("", c, MERR 5 (SMP _ QUOTA)) -> bId == c; _ -> False + 6 <- sendMessage a bId SMP.noMsgFlags "5" -- this won't expire + get a =##> \case ("", c, MERR 3 (SMP _ QUOTA)) -> bId == c; _ -> False get a >>= \case - ("", c, MERR 6 (SMP _ QUOTA)) -> do + ("", c, MERR 4 (SMP _ QUOTA)) -> do liftIO $ bId `shouldBe` c - get a =##> \case ("", c', MERR 7 (SMP _ QUOTA)) -> bId == c'; ("", c', MERRS [7] (SMP _ QUOTA)) -> bId == c'; _ -> False - ("", c, MERRS [6] (SMP _ QUOTA)) -> do + get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; ("", c', MERRS [5] (SMP _ QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [4] (SMP _ QUOTA)) -> do liftIO $ bId `shouldBe` c - get a =##> \case ("", c', MERR 7 (SMP _ QUOTA)) -> bId == c'; _ -> False - ("", c, MERRS [6, 7] (SMP _ QUOTA)) -> liftIO $ bId `shouldBe` c + get a =##> \case ("", c', MERR 5 (SMP _ QUOTA)) -> bId == c'; _ -> False + ("", c, MERRS [4, 5] (SMP _ QUOTA)) -> liftIO $ bId `shouldBe` c r -> error $ show r pure (aId, bId) withAgent 3 agentCfg initAgentServers testDB2 $ \b' -> runRight_ $ do subscribeConnection b' aId get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False - ackMessage b' aId 4 Nothing + ackMessage b' aId 2 Nothing liftIO . getInAnyOrder a $ - [ \case ("", c, AEvt SAEConn (SENT 8)) -> c == bId; _ -> False, + [ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False, \case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False ] - get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False - ackMessage b' aId 6 Nothing + get b' =##> \case ("", c, MsgErr 4 (MsgSkipped 3 5) "5") -> c == aId; _ -> False + ackMessage b' aId 4 Nothing disposeAgentClient a testRatchetSync :: HasCallStack => ATransport -> IO () @@ -1363,36 +1447,37 @@ testRatchetSync t = withAgentClients2 $ \alice bob -> get bob2 =##> ratchetSyncP aliceId RSAgreed get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) setupDesynchronizedRatchet alice bob = do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do - 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" - get alice ##> ("", bobId, SENT 4) + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False - ackMessage bob aliceId 4 Nothing + ackMessage bob aliceId 2 Nothing - 5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId SMP.noMsgFlags "hello 2" + get bob ##> ("", aliceId, SENT 3) get alice =##> \case ("", c, Msg "hello 2") -> c == bobId; _ -> False - ackMessage alice bobId 5 Nothing + ackMessage alice bobId 3 Nothing liftIO $ copyFile testDB2 (testDB2 <> ".bak") - 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" - get alice ##> ("", bobId, SENT 6) + 4 <- sendMessage alice bobId SMP.noMsgFlags "hello 3" + get alice ##> ("", bobId, SENT 4) get bob =##> \case ("", c, Msg "hello 3") -> c == aliceId; _ -> False - ackMessage bob aliceId 6 Nothing + ackMessage bob aliceId 4 Nothing - 7 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4" - get bob ##> ("", aliceId, SENT 7) + 5 <- sendMessage bob aliceId SMP.noMsgFlags "hello 4" + get bob ##> ("", aliceId, SENT 5) get alice =##> \case ("", c, Msg "hello 4") -> c == bobId; _ -> False - ackMessage alice bobId 7 Nothing + ackMessage alice bobId 5 Nothing disposeAgentClient bob + threadDelay 250000 -- importing database backup after progressing ratchet de-synchronizes ratchet liftIO $ renameFile (testDB2 <> ".bak") testDB2 @@ -1404,8 +1489,8 @@ setupDesynchronizedRatchet alice bob = do Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ synchronizeRatchet bob2 aliceId PQSupportOn False - 8 <- sendMessage alice bobId SMP.noMsgFlags "hello 5" - get alice ##> ("", bobId, SENT 8) + 6 <- sendMessage alice bobId SMP.noMsgFlags "hello 5" + get alice ##> ("", bobId, SENT 6) get bob2 =##> ratchetSyncP aliceId RSRequired Left A.CMD {cmdErr = PROHIBITED} <- liftIO . runExceptT $ sendMessage bob2 aliceId SMP.noMsgFlags "hello 6" @@ -1443,7 +1528,7 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do runRight_ $ do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 serverUpP :: ATransmission -> Bool @@ -1471,7 +1556,7 @@ testRatchetSyncClientRestart t = do get bob3 =##> ratchetSyncP aliceId RSAgreed get alice =##> ratchetSyncP bobId RSOk get bob3 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob3 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob3 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob3 @@ -1500,7 +1585,7 @@ testRatchetSyncSuspendForeground t = do runRight_ $ do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob2 @@ -1528,13 +1613,13 @@ testRatchetSyncSimultaneous t = do runRight_ $ do get alice =##> ratchetSyncP bobId RSOk get bob2 =##> ratchetSyncP aliceId RSOk - exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9 + exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient alice disposeAgentClient bob disposeAgentClient bob2 -testOnlyCreatePull :: IO () -testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do +testOnlyCreatePullSlowHandshake :: IO () +testOnlyCreatePullSlowHandshake = withAgentClientsCfg2 agentProxyCfgV8 agentProxyCfgV8 $ \alice bob -> runRight_ $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice @@ -1558,14 +1643,38 @@ testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do getMsg alice bobId $ get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False ackMessage alice bobId 5 Nothing - where - getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a - getMsg c cId action = do - liftIO $ noMessages c "nothing should be delivered before GET" - Just _ <- getConnectionMessage c cId - r <- action - get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False - pure r + +getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO a -> ExceptT AgentErrorType IO a +getMsg c cId action = do + liftIO $ noMessages c "nothing should be delivered before GET" + Just _ <- getConnectionMessage c cId + r <- action + get c =##> \case ("", cId', MSGNTF _) -> cId == cId'; _ -> False + pure r + +testOnlyCreatePull :: IO () +testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate + Just ("", _, CONF confId _ "bob's connInfo") <- getMsg alice bobId $ timeout 5_000000 $ get alice + allowConnection alice bobId confId "alice's connInfo" + liftIO $ threadDelay 1_000000 + getMsg bob aliceId $ do + get bob ##> ("", aliceId, INFO "alice's connInfo") + get bob ##> ("", aliceId, CON) + liftIO $ threadDelay 1_000000 + get alice ##> ("", bobId, CON) -- sent to initiating party after sending confirmation + -- exchange messages + 2 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 2) + getMsg bob aliceId $ + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId 2 Nothing + 3 <- sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT 3) + getMsg alice bobId $ + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId 3 Nothing makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnection = makeConnection_ PQSupportOn @@ -1643,14 +1752,14 @@ testSuspendingAgent :: IO () testSuspendingAgent = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing liftIO $ suspendAgent b 1000000 get' b ##> ("", "", SUSPENDED) - 5 <- sendMessage a bId SMP.noMsgFlags "hello 2" - get a ##> ("", bId, SENT 5) + 3 <- sendMessage a bId SMP.noMsgFlags "hello 2" + get a ##> ("", bId, SENT 3) Nothing <- 100000 `timeout` get b liftIO $ foregroundAgent b get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False @@ -1659,47 +1768,47 @@ testSuspendingAgentCompleteSending :: ATransport -> IO () testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing pure (aId, bId) runRight_ $ do ("", "", DOWN {}) <- nGet a ("", "", DOWN {}) <- nGet b - 5 <- sendMessage b aId SMP.noMsgFlags "hello too" - 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" + 3 <- sendMessage b aId SMP.noMsgFlags "hello too" + 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ threadDelay 100000 liftIO $ suspendAgent b 5000000 withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do - pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False - pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False - pGet b =##> \case ("", c, AEvt SAEConn (SENT 6)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 3)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, AEvt SAEConn (SENT 4)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False ("", "", SUSPENDED) <- nGet b pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False - ackMessage a bId 5 Nothing + ackMessage a bId 3 Nothing get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False - ackMessage a bId 6 Nothing + ackMessage a bId 4 Nothing testSuspendingAgentTimeout :: ATransport -> IO () testSuspendingAgentTimeout t = withAgentClients2 $ \a b -> do (aId, _) <- withSmpServer t . runRight $ do (aId, bId) <- makeConnection a b - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 Nothing + ackMessage b aId 2 Nothing pure (aId, bId) runRight_ $ do ("", "", DOWN {}) <- nGet a ("", "", DOWN {}) <- nGet b - 5 <- sendMessage b aId SMP.noMsgFlags "hello too" - 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" + 3 <- sendMessage b aId SMP.noMsgFlags "hello too" + 4 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ suspendAgent b 100000 ("", "", SUSPENDED) <- nGet b pure () @@ -1730,10 +1839,10 @@ testBatchedSubscriptions nCreate nDel t = (aIds', bIds') = unzip conns' subscribe a bIds subscribe b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 4 a bId b aId void $ resubscribeConnections a bIds void $ resubscribeConnections b aIds - forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 8 a bId b aId + forM_ conns' $ \(aId, bId) -> exchangeGreetingsMsgId_ PQEncOff 6 a bId b aId delete a bIds' delete b aIds' deleteFail a bIds' @@ -1786,9 +1895,9 @@ testBatchedPendingMessages nCreate nMsgs = withA = withAgent 1 agentCfg initAgentServers testDB withB = withAgent 2 agentCfg initAgentServers testDB2 -testAsyncCommands :: IO () -testAsyncCommands = - withAgentClients2 $ \alice bob -> runRight_ $ do +testAsyncCommands :: AgentClient -> AgentClient -> AgentMsgId -> IO () +testAsyncCommands alice bob baseId = + runRight_ $ do bobId <- createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bobId', INV (ACR _ qInfo)) <- get alice liftIO $ bobId' `shouldBe` bobId @@ -1833,7 +1942,6 @@ testAsyncCommands = get alice =##> \case ("", c, DEL_CONN) -> c == bobId; _ -> False liftIO $ noMessages alice "nothing else should be delivered to alice" where - baseId = 3 msgId = subtract baseId testAsyncCommandsRestore :: ATransport -> IO () @@ -1848,9 +1956,9 @@ testAsyncCommandsRestore t = do get alice' =##> \case ("1", _, INV _) -> True; _ -> False pure () -testAcceptContactAsync :: IO () -testAcceptContactAsync = - withAgentClients2 $ \alice bob -> runRight_ $ do +testAcceptContactAsync :: AgentClient -> AgentClient -> AgentMsgId -> IO () +testAcceptContactAsync alice bob baseId = + runRight_ $ do (_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, REQ invId _ "bob's connInfo") <- get alice @@ -1884,7 +1992,6 @@ testAcceptContactAsync = deleteConnection alice bobId liftIO $ noMessages alice "nothing else should be delivered to alice" where - baseId = 3 msgId = subtract baseId testDeleteConnectionAsync :: ATransport -> IO () @@ -1931,7 +2038,7 @@ testWaitDeliveryNoPending t = withAgentClients2 $ \alice bob -> liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDelivery :: ATransport -> IO () @@ -1985,7 +2092,7 @@ testWaitDelivery t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryAUTHErr :: ATransport -> IO () @@ -2028,7 +2135,7 @@ testWaitDeliveryAUTHErr t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryTimeout :: ATransport -> IO () @@ -2068,7 +2175,7 @@ testWaitDeliveryTimeout t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId testWaitDeliveryTimeout2 :: ATransport -> IO () @@ -2114,14 +2221,14 @@ testWaitDeliveryTimeout2 t = liftIO $ noMessages alice "nothing else should be delivered to alice" liftIO $ noMessages bob "nothing else should be delivered to bob" where - baseId = 3 + baseId = 1 msgId = subtract baseId -testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () -testJoinConnectionAsyncReplyError t = do +testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => ATransport -> IO () +testJoinConnectionAsyncReplyErrorV8 t = do let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} - withAgent 1 agentCfg initAgentServers testDB $ \a -> - withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do + withAgent 1 agentCfgVPrevPQ initAgentServers testDB $ \a -> + withAgent 2 agentCfgVPrevPQ initAgentServersSrv2 testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a @@ -2145,52 +2252,92 @@ testJoinConnectionAsyncReplyError t = do nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False runRight_ $ do allowConnectionAsync a "3" bId confId "alice's connInfo" + get a ##> ("3", bId, OK) liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure () withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False - pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False + nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) + exchangeGreetingsMsgId 4 a bId b aId + +testJoinConnectionAsyncReplyError :: HasCallStack => ATransport -> IO () +testJoinConnectionAsyncReplyError t = do + let initAgentServersSrv2 = initAgentServers {smp = userServers [noAuthSrv testSMPServer2]} + withAgent 1 agentCfg initAgentServers testDB $ \a -> + withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do + (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do + bId <- createConnectionAsync a 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe + ("1", bId', INV (ACR _ qInfo)) <- get a + liftIO $ bId' `shouldBe` bId + aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure (aId, bId) + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + withSmpServerOn t testPort2 $ do + confId <- withSmpServerStoreLogOn t testPort $ \_ -> do + -- both servers need to be online for connection to progress because of SKEY + get b =##> \case ("2", c, OK) -> c == aId; _ -> False + pGet a >>= \case + ("", "", AEvt _ (UP _ [_])) -> do + ("", _, CONF confId _ "bob's connInfo") <- get a + pure confId + ("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do + ("", "", UP _ [_]) <- nGet a + pure confId + r -> error $ "unexpected response " <> show r + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False + runRight_ $ do + allowConnectionAsync a "3" bId confId "alice's connInfo" + get a ##> ("3", bId, OK) + get a ##> ("", bId, CON) + liftIO $ threadDelay 500000 + ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId + pure () + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do + nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) exchangeGreetings a bId b aId testUsers :: IO () testUsers = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' deleteUser a auId True get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" testDeleteUserQuietly :: IO () testDeleteUserQuietly = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' deleteUser a auId False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" testUsersNoServer :: HasCallStack => ATransport -> IO () testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId auId <- createUser a [noAuthSrv testSMPServer] [noAuthSrv testXFTPServer] (aId', bId') <- makeConnectionForUsers a auId b 1 - exchangeGreetingsMsgId 4 a bId' b aId' + exchangeGreetings a bId' b aId' pure (aId, bId, auId, aId', bId') nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False @@ -2204,7 +2351,7 @@ testUsersNoServer t = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False - exchangeGreetingsMsgId 6 a bId b aId + exchangeGreetingsMsgId 4 a bId b aId where aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} @@ -2212,9 +2359,9 @@ testSwitchConnection :: InitialAgentServers -> IO () testSwitchConnection servers = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId - testFullSwitch a bId b aId 10 - testFullSwitch a bId b aId 16 + exchangeGreetings a bId b aId + testFullSwitch a bId b aId 8 + testFullSwitch a bId b aId 14 testFullSwitch :: AgentClient -> ByteString -> AgentClient -> ByteString -> Int64 -> ExceptT AgentErrorType IO () testFullSwitch a bId b aId msgId = do @@ -2265,7 +2412,7 @@ testSwitchAsync :: HasCallStack => InitialAgentServers -> IO () testSwitchAsync servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2286,8 +2433,8 @@ testSwitchAsync servers = do withA $ \a -> withB $ \b -> runRight_ $ do subscribeConnection a bId subscribeConnection b aId - exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 16 + exchangeGreetingsMsgId 8 a bId b aId + testFullSwitch a bId b aId 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2310,7 +2457,7 @@ testSwitchDelete :: InitialAgentServers -> IO () testSwitchDelete servers = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId liftIO $ disposeAgentClient b stats <- switchConnectionAsync a "" bId liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Just RSSwitchStarted] @@ -2325,7 +2472,7 @@ testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStarted servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2362,9 +2509,9 @@ testAbortSwitchStarted servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 12 a bId b aId + exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 18 + testFullSwitch a bId b aId 16 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2375,7 +2522,7 @@ testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO () testAbortSwitchStartedReinitiate servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2413,9 +2560,9 @@ testAbortSwitchStartedReinitiate servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 12 a bId b aId + exchangeGreetingsMsgId 10 a bId b aId - testFullSwitch a bId b aId 18 + testFullSwitch a bId b aId 16 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2442,7 +2589,7 @@ testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO () testCannotAbortSwitchSecured servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId pure (aId, bId) let withA' = sessionSubscribe withA [bId] withB' = sessionSubscribe withB [aId] @@ -2467,9 +2614,9 @@ testCannotAbortSwitchSecured servers = do phaseRcv a bId SPCompleted [Nothing] - exchangeGreetingsMsgId 10 a bId b aId + exchangeGreetingsMsgId 8 a bId b aId - testFullSwitch a bId b aId 16 + testFullSwitch a bId b aId 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2480,9 +2627,9 @@ testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO () testSwitch2Connections servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetings a bId1 b aId1 (aId2, bId2) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetings a bId2 b aId2 pure (aId1, bId1, aId2, bId2) let withA' = sessionSubscribe withA [bId1, bId2] withB' = sessionSubscribe withB [aId1, aId2] @@ -2523,11 +2670,11 @@ testSwitch2Connections servers = do void $ subscribeConnections a [bId1, bId2] void $ subscribeConnections b [aId1, aId2] - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 10 a bId2 b aId2 + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 8 a bId2 b aId2 - testFullSwitch a bId1 b aId1 16 - testFullSwitch a bId2 b aId2 16 + testFullSwitch a bId1 b aId1 14 + testFullSwitch a bId2 b aId2 14 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB @@ -2538,9 +2685,9 @@ testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO () testSwitch2ConnectionsAbort1 servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetings a bId1 b aId1 (aId2, bId2) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetings a bId2 b aId2 pure (aId1, bId1, aId2, bId2) let withA' = sessionSubscribe withA [bId1, bId2] withB' = sessionSubscribe withB [aId1, aId2] @@ -2576,19 +2723,19 @@ testSwitch2ConnectionsAbort1 servers = do phaseRcv a bId1 SPCompleted [Nothing] - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 8 a bId2 b aId2 + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 6 a bId2 b aId2 - testFullSwitch a bId1 b aId1 16 - testFullSwitch a bId2 b aId2 14 + testFullSwitch a bId1 b aId1 14 + testFullSwitch a bId2 b aId2 12 where withA :: (AgentClient -> IO a) -> IO a withA = withAgent 1 agentCfg servers testDB withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfg servers testDB2 -testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> IO Int -testCreateQueueAuth srvVersion clnt1 clnt2 = do +testCreateQueueAuth :: HasCallStack => VersionSMP -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> AgentMsgId -> IO Int +testCreateQueueAuth srvVersion clnt1 clnt2 baseId = do a <- getClient 1 clnt1 testDB b <- getClient 2 clnt2 testDB2 r <- runRight $ do @@ -2605,7 +2752,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do get a ##> ("", bId, CON) get b ##> ("", aId, INFO "alice's connInfo") get b ##> ("", aId, CON) - exchangeGreetings a bId b aId + exchangeGreetingsMsgId (baseId + 1) a bId b aId pure 2 disposeAgentClient a disposeAgentClient b @@ -2638,20 +2785,20 @@ testDeliveryReceipts = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b -- a sends, b receives and sends delivery receipt - 4 <- sendMessage a bId SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) + 2 <- sendMessage a bId SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False - ackMessage b aId 4 $ Just "" - get a =##> \case ("", c, Rcvd 4) -> c == bId; _ -> False - ackMessage a bId 5 Nothing + ackMessage b aId 2 $ Just "" + get a =##> \case ("", c, Rcvd 2) -> c == bId; _ -> False + ackMessage a bId 3 Nothing -- b sends, a receives and sends delivery receipt - 6 <- sendMessage b aId SMP.noMsgFlags "hello too" - get b ##> ("", aId, SENT 6) + 4 <- sendMessage b aId SMP.noMsgFlags "hello too" + get b ##> ("", aId, SENT 4) get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False - ackMessage a bId 6 $ Just "" - get b =##> \case ("", c, Rcvd 6) -> c == aId; _ -> False - ackMessage b aId 7 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) - ackMessage b aId 7 Nothing + ackMessage a bId 4 $ Just "" + get b =##> \case ("", c, Rcvd 4) -> c == aId; _ -> False + ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) + ackMessage b aId 5 Nothing testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO () testDeliveryReceiptsVersion t = do @@ -2662,15 +2809,15 @@ testDeliveryReceiptsVersion t = do (aId, bId) <- makeConnection_ PQSupportOff a b checkVersion a bId 3 checkVersion b aId 3 - (4, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello" - get a ##> ("", bId, SENT 4) - get b =##> \case ("", c, Msg' 4 PQEncOff "hello") -> c == aId; _ -> False - ackMessage b aId 4 $ Just "" + (2, _) <- A.sendMessage a bId PQEncOff SMP.noMsgFlags "hello" + get a ##> ("", bId, SENT 2) + get b =##> \case ("", c, Msg' 2 PQEncOff "hello") -> c == aId; _ -> False + ackMessage b aId 2 $ Just "" liftIO $ noMessages a "no delivery receipt (unsupported version)" - (5, _) <- A.sendMessage b aId PQEncOff SMP.noMsgFlags "hello too" - get b ##> ("", aId, SENT 5) - get a =##> \case ("", c, Msg' 5 PQEncOff "hello too") -> c == bId; _ -> False - ackMessage a bId 5 $ Just "" + (3, _) <- A.sendMessage b aId PQEncOff SMP.noMsgFlags "hello too" + get b ##> ("", aId, SENT 3) + get a =##> \case ("", c, Msg' 3 PQEncOff "hello too") -> c == bId; _ -> False + ackMessage a bId 3 $ Just "" liftIO $ noMessages b "no delivery receipt (unsupported version)" pure (aId, bId) @@ -2682,27 +2829,27 @@ testDeliveryReceiptsVersion t = do runRight_ $ do subscribeConnection a' bId subscribeConnection b' aId - exchangeGreetingsMsgId_ PQEncOff 6 a' bId b' aId - checkVersion a' bId 5 - checkVersion b' aId 5 - (8, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello" - get a' ##> ("", bId, SENT 8) - get b' =##> \case ("", c, Msg' 8 PQEncOff "hello") -> c == aId; _ -> False - ackMessage b' aId 8 $ Just "" - get a' =##> \case ("", c, Rcvd 8) -> c == bId; _ -> False - ackMessage a' bId 9 Nothing - (10, PQEncOff) <- A.sendMessage b' aId PQEncOn SMP.noMsgFlags "hello too" - get b' ##> ("", aId, SENT 10) - get a' =##> \case ("", c, Msg' 10 PQEncOff "hello too") -> c == bId; _ -> False - ackMessage a' bId 10 $ Just "" - get b' =##> \case ("", c, Rcvd 10) -> c == aId; _ -> False - ackMessage b' aId 11 Nothing - (12, _) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello 2" - get a' ##> ("", bId, SENT 12) - get b' =##> \case ("", c, Msg' 12 PQEncOff "hello 2") -> c == aId; _ -> False - ackMessage b' aId 12 $ Just "" - get a' =##> \case ("", c, Rcvd 12) -> c == bId; _ -> False - ackMessage a' bId 13 Nothing + exchangeGreetingsMsgId_ PQEncOff 4 a' bId b' aId + checkVersion a' bId 6 + checkVersion b' aId 6 + (6, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello" + get a' ##> ("", bId, SENT 6) + get b' =##> \case ("", c, Msg' 6 PQEncOff "hello") -> c == aId; _ -> False + ackMessage b' aId 6 $ Just "" + get a' =##> \case ("", c, Rcvd 6) -> c == bId; _ -> False + ackMessage a' bId 7 Nothing + (8, PQEncOff) <- A.sendMessage b' aId PQEncOn SMP.noMsgFlags "hello too" + get b' ##> ("", aId, SENT 8) + get a' =##> \case ("", c, Msg' 8 PQEncOff "hello too") -> c == bId; _ -> False + ackMessage a' bId 8 $ Just "" + get b' =##> \case ("", c, Rcvd 8) -> c == aId; _ -> False + ackMessage b' aId 9 Nothing + (10, _) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello 2" + get a' ##> ("", bId, SENT 10) + get b' =##> \case ("", c, Msg' 10 PQEncOff "hello 2") -> c == aId; _ -> False + ackMessage b' aId 10 $ Just "" + get a' =##> \case ("", c, Rcvd 10) -> c == bId; _ -> False + ackMessage a' bId 11 Nothing disposeAgentClient a' disposeAgentClient b' @@ -2773,8 +2920,8 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a a `hasClients` 2 - exchangeGreetingsMsgId 6 a bId1 b aId1 - exchangeGreetingsMsgId 6 a bId1' b aId1' + exchangeGreetingsMsgId 4 a bId1 b aId1 + exchangeGreetingsMsgId 4 a bId1' b aId1' liftIO $ threadDelay 250000 liftIO $ setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 @@ -2798,10 +2945,10 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a ("", "", UP _ _) <- nGet a a `hasClients` 4 - exchangeGreetingsMsgId 8 a bId1 b aId1 - exchangeGreetingsMsgId 8 a bId1' b aId1' - exchangeGreetingsMsgId 6 a bId2 b aId2 - exchangeGreetingsMsgId 6 a bId2' b aId2' + exchangeGreetingsMsgId 6 a bId1 b aId1 + exchangeGreetingsMsgId 6 a bId1' b aId1' + exchangeGreetingsMsgId 4 a bId2 b aId2 + exchangeGreetingsMsgId 4 a bId2' b aId2' liftIO $ threadDelay 250000 liftIO $ setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 @@ -2814,10 +2961,10 @@ testTwoUsers = withAgentClients2 $ \a b -> do ("", "", UP _ _) <- nGet a ("", "", UP _ _) <- nGet a a `hasClients` 2 - exchangeGreetingsMsgId 10 a bId1 b aId1 - exchangeGreetingsMsgId 10 a bId1' b aId1' - exchangeGreetingsMsgId 8 a bId2 b aId2 - exchangeGreetingsMsgId 8 a bId2' b aId2' + exchangeGreetingsMsgId 8 a bId1 b aId1 + exchangeGreetingsMsgId 8 a bId1' b aId1' + exchangeGreetingsMsgId 6 a bId2 b aId2 + exchangeGreetingsMsgId 6 a bId2' b aId2' where hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO () hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n @@ -2844,9 +2991,10 @@ testServerMultipleIdentities = bob' <- liftIO $ do Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" SMSubscribe disposeAgentClient bob + threadDelay 250000 getSMPAgentClient' 3 agentCfg initAgentServers testDB2 subscribeConnection bob' aliceId - exchangeGreetingsMsgId 6 alice bobId bob' aliceId + exchangeGreetingsMsgId 4 alice bobId bob' aliceId liftIO $ disposeAgentClient bob' where secondIdentityCReq :: ConnectionRequestUri 'CMInvitation @@ -2934,7 +3082,7 @@ testServerQueueInfo = do aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice liftIO $ threadDelay 200000 - checkEmptyQ alice bobId False + checkEmptyQ alice bobId True -- secured by sender allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, INFO "alice's connInfo") @@ -2942,7 +3090,7 @@ testServerQueueInfo = do liftIO $ threadDelay 200000 checkEmptyQ alice bobId True checkEmptyQ bob aliceId True - let msgId = 4 + let msgId = 2 (msgId', PQEncOn) <- A.sendMessage alice bobId PQEncOn SMP.noMsgFlags "hello" liftIO $ msgId' `shouldBe` msgId get alice ##> ("", bobId, SENT msgId) @@ -2993,14 +3141,14 @@ testServerQueueInfo = do pure () where checkEmptyQ c cId qiSnd' = do - r <- checkQ c cId qiSnd' (Just QSubThread) 0 Nothing + r <- checkQ c cId qiSnd' (Just QNoSub) 0 Nothing liftIO $ r `shouldBe` Nothing checkMsgQ c cId qiSize' = do r <- checkQ c cId True (Just QNoSub) qiSize' (Just MTMessage) liftIO $ isJust r `shouldBe` True pure r checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do - QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg} <- getConnectionQueueInfo c cId + ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c cId liftIO $ do qiSnd `shouldBe` qiSnd' qiNtf `shouldBe` False @@ -3018,7 +3166,7 @@ noNetworkDelay a = do networkDelay :: AgentClient -> Int64 -> IO () networkDelay a d' = do d <- waitNetwork a - unless (d' < d && d < d' + 15000) $ expectationFailure $ "expected delay " <> show d' <> ", d = " <> show d + unless (d' - 1000 < d && d < d' + 15000) $ expectationFailure $ "expected delay " <> show d' <> ", d = " <> show d waitNetwork :: AgentClient -> IO Int64 waitNetwork a = do @@ -3031,7 +3179,7 @@ exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> Con exchangeGreetings = exchangeGreetings_ PQEncOn exchangeGreetings_ :: HasCallStack => PQEncryption -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () -exchangeGreetings_ pqEnc = exchangeGreetingsMsgId_ pqEnc 4 +exchangeGreetings_ pqEnc = exchangeGreetingsMsgId_ pqEnc 2 exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 01eab9555..a104c6cf5 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -12,9 +12,9 @@ module AgentTests.NotificationTests where -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) import AgentTests.FunctionalAPITests - ( agentCfgV7, + ( agentCfgVPrevPQ, createConnection, - exchangeGreetingsMsgId, + exchangeGreetings, get, joinConnection, makeConnection, @@ -51,7 +51,7 @@ import qualified Data.ByteString.Char8 as B import Data.Text.Encoding (encodeUtf8) import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) -import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) +import SMPClient (cfg, cfgVPrev, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) @@ -70,7 +70,6 @@ import Simplex.Messaging.Transport (ATransport) import System.Directory (doesFileExist, removeFile) import Test.Hspec import UnliftIO -import Util removeFileIfExists :: FilePath -> IO () removeFileIfExists filePath = do @@ -144,28 +143,26 @@ notificationTests t = do withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> testNotificationsNewToken apns ntf -testNtfMatrix :: ATransport -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> Spec +testNtfMatrix :: HasCallStack => ATransport -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec testNtfMatrix t runTest = do describe "next and current" $ do - it "next servers: SMP v7, NTF v2; next clients: v7/v2" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfgV7 runTest - it "next servers: SMP v7, NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfg runTest - it "curr servers: SMP v6, NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfg agentCfg agentCfg runTest - skip "this case cannot be supported - see RFC" $ - it "servers: SMP v6, NTF v1; clients: v7/v2 (not supported)" $ - runNtfTestCfg t cfg ntfServerCfg agentCfgV7 agentCfgV7 runTest - -- servers can be migrated in any order - it "servers: next SMP v7, curr NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfg agentCfg agentCfg runTest - it "servers: curr SMP v6, next NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfgV2 agentCfg agentCfg runTest - -- clients can be partially migrated - it "servers: next SMP v7, curr NTF v2; clients: next/curr" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfg runTest - it "servers: next SMP v7, curr NTF v2; clients: curr/new" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfgV7 runTest + it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest + it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest + -- servers can be upgraded in any order + it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest + it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest + -- one of two clients can be upgraded + it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfg agentCfgVPrevPQ runTest + it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfg runTest -runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO () -runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = do +runNtfTestCfg :: HasCallStack => ATransport -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () +runNtfTestCfg t baseId smpCfg ntfCfg aCfg bCfg runTest = do withSmpServerConfigOn t smpCfg testPort $ \_ -> withAPNSMockServer $ \apns -> withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ -> - withAgentClientsCfg2 aCfg bCfg $ runTest apns + withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId threadDelay 100000 testNotificationToken :: APNSMockServer -> IO () @@ -345,8 +342,8 @@ testRunNTFServerTests t srv = withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing -testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do +testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} baseId alice@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 @@ -377,20 +374,20 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen -- alice client already has subscription for the connection Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message - threadDelay 200000 + threadDelay 500000 suspendAgent alice 0 closeSQLiteStore store - threadDelay 200000 + threadDelay 500000 -- aliceNtf client doesn't have subscription and is allowed to get notification message withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message pure () - threadDelay 200000 + threadDelay 500000 reopenSQLiteStore store foregroundAgent alice - threadDelay 200000 + threadDelay 500000 runRight_ $ do get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False @@ -404,11 +401,10 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen -- no notifications should follow noNotification apnsQ where - baseId = 3 msgId = subtract baseId -testNotificationSubscriptionNewConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () -testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = +testNotificationSubscriptionNewConnection :: HasCallStack => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} baseId alice bob = runRight_ $ do -- alice registers notification token DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ @@ -426,9 +422,9 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = allowConnection alice bobId confId "alice's connInfo" void $ messageNotificationData bob apnsQ get bob ##> ("", aliceId, INFO "alice's connInfo") - void $ messageNotificationData alice apnsQ + when (baseId == 3) $ void $ messageNotificationData alice apnsQ get alice ##> ("", bobId, CON) - void $ messageNotificationData bob apnsQ + when (baseId == 3) $ void $ messageNotificationData bob apnsQ get bob ##> ("", aliceId, CON) -- bob sends message 1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello" @@ -445,7 +441,6 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = -- no unexpected notifications should follow noNotification apnsQ where - baseId = 3 msgId = subtract baseId registerTestToken :: AgentClient -> ByteString -> NotificationsMode -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO DeviceToken @@ -520,7 +515,7 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = -- no notifications should follow noNotification apnsQ where - baseId = 3 + baseId = 1 msgId = subtract baseId testChangeToken :: APNSMockServer -> IO () @@ -559,7 +554,7 @@ testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers t -- no notifications should follow noNotification apnsQ where - baseId = 3 + baseId = 1 msgId = subtract baseId testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO () @@ -568,11 +563,11 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 - 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" - get bob ##> ("", aliceId, SENT 4) + 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" + get bob ##> ("", aliceId, SENT 2) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage alice bobId 4 Nothing + ackMessage alice bobId 2 Nothing liftIO $ killThread threadId pure (aliceId, bobId) @@ -580,8 +575,8 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice withNtfServerStoreLog t $ \threadId -> runRight_ $ do liftIO $ threadDelay 250000 - 5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" + get bob ##> ("", aliceId, SENT 3) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId @@ -592,11 +587,11 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic (aliceId, bobId) <- makeConnection alice bob _ <- registerTestToken alice "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 - 4 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" - get bob ##> ("", aliceId, SENT 4) + 2 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello" + get bob ##> ("", aliceId, SENT 2) void $ messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False - ackMessage alice bobId 4 Nothing + ackMessage alice bobId 2 Nothing liftIO $ killThread threadId pure (aliceId, bobId) @@ -608,8 +603,8 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alic nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False liftIO $ threadDelay 1000000 - 5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" - get bob ##> ("", aliceId, SENT 5) + 3 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" + get bob ##> ("", aliceId, SENT 3) _ <- messageNotificationData alice apnsQ get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId @@ -664,7 +659,7 @@ testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO () testSwitchNotifications servers APNSMockServer {apnsQ} = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b - exchangeGreetingsMsgId 4 a bId b aId + exchangeGreetings a bId b aId _ <- registerTestToken a "abcd" NMInstant apnsQ liftIO $ threadDelay 250000 let testMessage msg = do @@ -739,7 +734,7 @@ messageNotification apnsQ = do pure (nonce, message) _ -> error "bad notification" -messageNotificationData :: AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData +messageNotificationData :: HasCallStack => AgentClient -> TBQueue APNSMockRequest -> ExceptT AgentErrorType IO PNMessageData messageNotificationData c apnsQ = do (nonce, message) <- messageNotification apnsQ NtfToken {ntfDhSecret = Just dhSecret} <- getNtfTokenData c diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 039e26090..39a4b1b95 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -197,6 +197,9 @@ cData1 = testPrivateAuthKey :: C.APrivateAuthKey testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" +testPublicAuthKey :: C.APublicAuthKey +testPublicAuthKey = C.APublicAuthKey C.SEd25519 (C.publicKey "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe") + testPrivDhKey :: C.PrivateKeyX25519 testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk" @@ -218,6 +221,7 @@ rcvQueue1 = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = "2345", + sndSecure = True, status = New, dbQueueId = DBNewQueue, primary = True, @@ -235,7 +239,8 @@ sndQueue1 = connId = "conn1", server = smpServer1, sndId = "3456", - sndPublicKey = Nothing, + sndSecure = True, + sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, @@ -379,7 +384,8 @@ testUpgradeRcvConnToDuplex = connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "2345", - sndPublicKey = Nothing, + sndSecure = True, + sndPublicKey = testPublicAuthKey, sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, @@ -412,6 +418,7 @@ testUpgradeSndConnToDuplex = e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, sndId = "4567", + sndSecure = True, status = New, dbQueueId = DBNewQueue, rcvSwchStatus = Nothing, diff --git a/tests/CoreTests/TRcvQueuesTests.hs b/tests/CoreTests/TRcvQueuesTests.hs index 2b0009344..9f7c4932e 100644 --- a/tests/CoreTests/TRcvQueuesTests.hs +++ b/tests/CoreTests/TRcvQueuesTests.hs @@ -183,6 +183,7 @@ dummyRQ userId server connId = e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk", e2eDhSecret = Nothing, sndId = "", + sndSecure = True, status = New, dbQueueId = DBQueueId 0, primary = True, diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index bd8cee771..9bd124e55 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -28,7 +28,7 @@ import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H import Network.Socket -import SMPClient (serverBracket) +import SMPClient (prevRange, serverBracket) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C @@ -36,7 +36,6 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Protocol (NtfResponse) import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) import Simplex.Messaging.Notifications.Server.Env -import qualified Simplex.Messaging.Notifications.Server.Env as Env import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Server.Push.APNS.Internal import Simplex.Messaging.Notifications.Transport @@ -47,7 +46,6 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams) import Simplex.Messaging.Transport.HTTP2.Server import Simplex.Messaging.Transport.Server import qualified Simplex.Messaging.Transport.Server as Server -import Simplex.Messaging.Version (mkVersionRange) import Test.Hspec import UnliftIO.Async import UnliftIO.Concurrent @@ -108,18 +106,19 @@ ntfServerCfg = serverStatsLogFile = "tests/ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, ntfServerVRange = supportedServerNTFVRange, - transportConfig = defaultTransportServerConfig + transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes} } -ntfServerCfgV2 :: NtfServerConfig -ntfServerCfgV2 = +ntfServerCfgVPrev :: NtfServerConfig +ntfServerCfgVPrev = ntfServerCfg - { ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion, - smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}}, - Env.transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes} + { ntfServerVRange = prevRange $ ntfServerVRange ntfServerCfg, + smpAgentCfg = smpAgentCfg' {smpCfg = smpCfg' {serverVRange = prevRange serverVRange'}} } where smpAgentCfg' = smpAgentCfg ntfServerCfg + smpCfg' = smpCfg smpAgentCfg' + serverVRange' = serverVRange smpCfg' withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]} diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 3c9907c48..7cb2a88c5 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -14,7 +14,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import NtfClient (ntfTestPort) -import SMPClient (proxyVRange, testPort) +import SMPClient (proxyVRangeV8, testPort) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval @@ -80,8 +80,8 @@ agentCfg = where networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000} -agentProxyCfg :: AgentConfig -agentProxyCfg = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRange}} +agentProxyCfgV8 :: AgentConfig +agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}} fastRetryInterval :: RetryInterval fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000} diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 6bc36c29a..736016b3b 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -29,6 +29,7 @@ import qualified Simplex.Messaging.Transport.Client as Client import Simplex.Messaging.Transport.Server import qualified Simplex.Messaging.Transport.Server as Server import Simplex.Messaging.Version +import Simplex.Messaging.Version.Internal import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec @@ -99,7 +100,6 @@ cfg = { transports = [], smpHandshakeTimeout = 60000000, tbqSize = 1, - -- serverTbqSize = 1, msgQueueQuota = 4, queueIdBytes = 24, msgIdBytes = 24, @@ -133,18 +133,26 @@ cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVer cfgV8 :: ServerConfig cfgV8 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion} +cfgVPrev :: ServerConfig +cfgVPrev = cfg {smpServerVRange = prevRange $ smpServerVRange cfg} + +prevRange :: VersionRange v -> VersionRange v +prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} + +prevVersion :: Version v -> Version v +prevVersion (Version v) = Version (v - 1) + proxyCfg :: ServerConfig proxyCfg = - cfgV7 + cfg { allowSMPProxy = True, - smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, - smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {serverVRange = proxyVRange, agreeSecret = True}} + smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True}} } where - smpAgentCfg' = smpAgentCfg cfgV7 + smpAgentCfg' = smpAgentCfg cfg -proxyVRange :: VersionRangeSMP -proxyVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion +proxyVRangeV8 :: VersionRangeSMP +proxyVRangeV8 = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile} @@ -180,9 +188,6 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const withSmpServer :: HasCallStack => ATransport -> IO a -> IO a withSmpServer t = withSmpServerOn t testPort -withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a -withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const - withSmpServerProxy :: HasCallStack => ATransport -> IO a -> IO a withSmpServerProxy t = withSmpServerConfigOn t proxyCfg testPort . const diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index d71208db9..6452d2677 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -102,22 +102,22 @@ smpProxyTests = do describe "agent API" $ do describe "one server" $ do it "always via proxy" . oneServer $ - agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 it "without proxy" . oneServer $ - agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 describe "two servers" $ do it "always via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 it "both via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 it "without proxy" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 it "first via proxy for unknown" . twoServers $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1 it "without proxy with fallback" . twoServers_ proxyCfg cfgV7 $ - agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" + agentDeliverMessageViaProxy ([srv1], SPMUnknown, False) ([srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 3 it "fails when fallback is prohibited" . twoServers_ proxyCfg cfgV7 $ agentViaProxyVersionError it "retries sending when destination or proxy relay is offline" $ @@ -157,7 +157,7 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do -- prepare receiving queue (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe + QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe False let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv -- get proxy session sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") @@ -199,8 +199,8 @@ proxyConnectDeadRelay n d proxyServ = do Right !_noWay -> error "got unexpected client" Left !_err -> threadDelay d -agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> IO () -agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 = +agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO () +agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId = withAgent 1 aCfg (servers aTestCfg) testDB $ \alice -> withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do (bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe @@ -232,9 +232,8 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b get alice =##> \case ("", c, Msg' _ pq msg2') -> c == bobId && pq == pqEnc && msg2 == msg2'; _ -> False ackMessage alice bobId (baseId + 4) Nothing where - baseId = 3 msgId = subtract baseId . fst - aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} + aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} servers (srvs, smpProxyMode, _) = (initAgentServersProxy smpProxyMode SPFAllow) {smp = userServers $ L.map noAuthSrv srvs} agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO () @@ -299,14 +298,14 @@ agentDeliverMessagesViaProxyConc agentServers msgs = Left (Left e) -> cancel aSender >> throwIO e logDebug "run finished" pqEnc = CR.PQEncOn - aCfg = agentProxyCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} + aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} servers srvs = (initAgentServersProxy SPMAlways SPFAllow) {smp = userServers $ L.map noAuthSrv srvs} agentViaProxyVersionError :: IO () agentViaProxyVersionError = - withAgent 1 agentProxyCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do + withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do Left (A.BROKER _ (TRANSPORT TEVersion)) <- - withAgent 2 agentProxyCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do + withAgent 2 agentCfg (servers [SMPServer testHost testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do (_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () @@ -370,22 +369,22 @@ agentViaProxyRetryOffline = do withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just storeLog, storeMsgsFile = Just storeMsgs} port a `up` cId = nGet a =##> \case ("", "", UP _ [c]) -> c == cId; _ -> False a `down` cId = nGet a =##> \case ("", "", DOWN _ [c]) -> c == cId; _ -> False - aCfg = agentProxyCfg {messageRetryInterval = fastMessageRetryInterval} - baseId = 3 + aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} + baseId = 1 msgId = subtract baseId . fst servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers $ L.map noAuthSrv [srv]} testNoProxy :: IO () testNoProxy = do withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do - testSMPClient_ "127.0.0.1" testPort2 proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do + testSMPClient_ "127.0.0.1" testPort2 proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer Nothing) reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) testProxyAuth :: IO () testProxyAuth = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do - testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do + testSMPClient_ "127.0.0.1" testPort proxyVRangeV8 $ \(th :: THandleSMP TLS 'TClient) -> do (_, _s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer2 $ Just "wrong") reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) where diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index a124a42e4..10516b9f2 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -73,7 +73,7 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType B pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg -pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) +pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} @@ -134,7 +134,7 @@ testCreateSecure (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -199,7 +199,7 @@ testCreateDelete (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -271,7 +271,7 @@ stressTest (ATransport t) = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do - Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe False) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) @@ -289,7 +289,7 @@ testAllowNewQueues t = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) pure () testDuplex :: ATransport -> Spec @@ -299,7 +299,7 @@ testDuplex (ATransport t) = g <- C.newRandom (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe False) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band @@ -315,7 +315,7 @@ testDuplex (ATransport t) = (brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe False) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd) -- "reply_id ..." is ad-hoc, not a part of SMP protocol @@ -354,7 +354,7 @@ testSwitchSub (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") (ok1, OK) #== "sent test message 1" @@ -509,19 +509,21 @@ testWithStoreLog at@(ATransport t) = writeTVar senderId1 sId1 writeTVar notifierId nId Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB) - signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello") >>= \case - Resp "bcda" _ OK -> pure () - r -> unexpected r - Resp "" _ (Msg mId1 msg1) <- tGet1 h + (mId1, msg1) <- + signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello") >>= \case + Resp "" _ (Msg mId1 msg1) -> pure (mId1, msg1) + r -> error $ "unexpected response " <> take 100 (show r) + Resp "bcda" _ OK <- tGet1 h (decryptMsgV3 dhShared mId1 msg1, Right "hello") #== "delivered from queue 1" Resp "" _ (NMSG _ _) <- tGet1 h1 (sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2 atomically $ writeTVar senderId2 sId2 - signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") >>= \case - Resp "cdab" _ OK -> pure () - r -> unexpected r - Resp "" _ (Msg mId2 msg2) <- tGet1 h + (mId2, msg2) <- + signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too") >>= \case + Resp "" _ (Msg mId2 msg2) -> pure (mId2, msg2) + r -> error $ "unexpected response " <> take 100 (show r) + Resp "cdab" _ OK <- tGet1 h (decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2" Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL) @@ -740,7 +742,7 @@ createAndSecureQueue h sPub = do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) (rId', rId) #== "same queue ID" @@ -751,7 +753,7 @@ testTiming (ATransport t) = describe "should have similar time for auth error, whether queue exists or not, for all key types" $ forM_ timingTests $ \tst -> it (testName tst) $ - smpTest2Cfg cfgV7 (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> + smpTest2Cfg cfg (mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion) t $ \rh sh -> testSameTiming rh sh tst where testName :: (C.AuthAlg, C.AuthAlg, Int) -> String @@ -775,7 +777,7 @@ testTiming (ATransport t) = g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe False) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) @@ -884,7 +886,7 @@ testMsgExpireOnInterval t = testSMPClient @c $ \sh -> do (sId, rId, rKey, _) <- testSMPClient @c $ \rh -> createAndSecureQueue rh sPub Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should expire)") - threadDelay 2500000 + threadDelay 3000000 testSMPClient @c $ \rh -> do signSendRecv rh rKey ("2", rId, SUB) >>= \case Resp "2" _ OK -> pure () @@ -937,8 +939,8 @@ syntaxTests (ATransport t) = do describe "NEW" $ do it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX) it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX) - it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) - it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) + it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) describe "KEY" $ do it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH) it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX) diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 37ec00199..8de86eff1 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -398,7 +398,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp' + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp' rfId' `shouldBe` rfId -- tmp path should be removed after permanent error @@ -477,7 +477,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do -- send file - should fail with AUTH error withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- sfGet sndr' sfId' `shouldBe` sfId @@ -513,7 +513,7 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -551,7 +551,7 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -586,7 +586,7 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ runRight_ . void $ do -- receive file 1 again rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True - ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp liftIO $ rfId1 `shouldBe` rfId1' @@ -619,7 +619,7 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do -- receive file 1 again - should fail with AUTH error runRight $ do rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp liftIO $ rfId' `shouldBe` rfId diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 208b54dc5..72c843f32 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -67,10 +67,10 @@ withXFTPServer2 :: HasCallStack => IO a -> IO a withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const xftpTestPort :: ServiceName -xftpTestPort = "7000" +xftpTestPort = "8000" xftpTestPort2 :: ServiceName -xftpTestPort2 = "7001" +xftpTestPort2 = "8001" testXFTPServer :: XFTPServer testXFTPServer = fromString testXFTPServerStr @@ -79,10 +79,10 @@ testXFTPServer2 :: XFTPServer testXFTPServer2 = fromString testXFTPServerStr2 testXFTPServerStr :: String -testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" +testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" testXFTPServerStr2 :: String -testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001" +testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8001" xftpServerFiles :: FilePath xftpServerFiles = "tests/tmp/xftp-server-files"