From c5b7d3c7afb8c0df8d329885db09b08c2e88109c Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 16 Jun 2025 11:11:59 +0100 Subject: [PATCH 01/22] agent: use flexible (small/large) string encoding for contact link data, for backward/forward compatibility (#1569) * agent: use large string encoding for contact link data * size-dependent user link data encoding * tag large user data encoding with \255 --- src/Simplex/Messaging/Agent.hs | 12 +++++----- src/Simplex/Messaging/Agent/Protocol.hs | 21 ++++++++++++++--- src/Simplex/Messaging/Crypto/ShortLink.hs | 6 ++--- src/Simplex/Messaging/Util.hs | 4 +++- tests/AgentTests/EqInstances.hs | 6 ++++- tests/AgentTests/FunctionalAPITests.hs | 28 +++++++++++------------ tests/AgentTests/ShortLinkTests.hs | 18 +++++++-------- 7 files changed, 58 insertions(+), 37 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d178134c1..c72d39729 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -368,12 +368,12 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync' {-# INLINE deleteConnectionsAsync #-} -- | Create SMP agent connection (NEW command) -createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) +createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs {-# INLINE createConnection #-} -- | Create or update user's contact connection short link -setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> ConnInfo -> Maybe CRClientData -> AE (ConnShortLink c) +setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c) setConnShortLink c = withAgentEnv c .:: setConnShortLink' c {-# INLINE setConnShortLink #-} @@ -832,14 +832,14 @@ switchConnectionAsync' c corrId connId = pure . connectionStats $ DuplexConnection cData rqs' sqs _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex" -newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) +newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do srv <- getSMPServer c userId connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys) (connId,) <$> newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv `catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e -setConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> ConnInfo -> Maybe CRClientData -> AM (ConnShortLink c) +setConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AM (ConnShortLink c) setConnShortLink' c connId cMode userData clientData = withConnLock c connId "setConnShortLink" $ do SomeConn _ conn <- withStore c (`getConn` connId) @@ -935,7 +935,7 @@ changeConnectionUser' c oldUserId connId newUserId = do where updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId -newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId) +newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId) newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do case (cMode, pqInitKeys) of (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" @@ -978,7 +978,7 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange - prepareLinkData :: ConnInfo -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData) + prepareLinkData :: UserLinkData -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData) prepareLinkData userData e2eDhKey = do g <- asks random nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index bd242c8bf..44a749898 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -111,6 +111,7 @@ module Simplex.Messaging.Agent.Protocol ServiceScheme, FixedLinkData (..), ConnLinkData (..), + UserLinkData (..), OwnerAuth (..), OwnerId, ConnectionLink (..), @@ -167,6 +168,7 @@ module Simplex.Messaging.Agent.Protocol shortenShortLink, restoreShortLink, linkUserData, + linkUserData', ) where @@ -1633,7 +1635,7 @@ data FixedLinkData c = FixedLinkData } data ConnLinkData c where - InvitationLinkData :: VersionRangeSMPA -> ConnInfo -> ConnLinkData 'CMInvitation + InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation ContactLinkData :: { agentVRange :: VersionRangeSMPA, -- direct connection via connReq in fixed data is allowed. @@ -1642,15 +1644,22 @@ data ConnLinkData c where owners :: [OwnerAuth], -- alternative addresses of chat relays that receive requests for this contact address. relays :: [ConnShortLink 'CMContact], - userData :: ConnInfo + userData :: UserLinkData } -> ConnLinkData 'CMContact +newtype UserLinkData = UserLinkData ByteString + data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m) -linkUserData :: ConnLinkData c -> ConnInfo +linkUserData :: ConnLinkData c -> UserLinkData linkUserData = \case InvitationLinkData _ d -> d ContactLinkData {userData} -> userData +{-# INLINE linkUserData #-} + +linkUserData' :: ConnLinkData c -> ByteString +linkUserData' d = let UserLinkData s = linkUserData d in s +{-# INLINE linkUserData' #-} type OwnerId = ByteString @@ -1706,6 +1715,12 @@ instance Encoding AConnLinkData where userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding pure $ ACLD SCMContact ContactLinkData {agentVRange, direct, owners, relays, userData} +instance Encoding UserLinkData where + smpEncode (UserLinkData s) = if B.length s <= 254 then smpEncode s else smpEncode ('\255', Large s) + {-# INLINE smpEncode #-} + smpP = UserLinkData <$> ((A.char '\255' *> (unLarge <$> smpP)) <|> smpP) + {-# INLINE smpP #-} + data StoredClientService (s :: DBStored) = ClientService { dbServiceId :: DBEntityId' s, serviceId :: SMP.ServiceId diff --git a/src/Simplex/Messaging/Crypto/ShortLink.hs b/src/Simplex/Messaging/Crypto/ShortLink.hs index c32c05bcf..34f292c8c 100644 --- a/src/Simplex/Messaging/Crypto/ShortLink.hs +++ b/src/Simplex/Messaging/Crypto/ShortLink.hs @@ -48,17 +48,17 @@ contactShortLinkKdf (LinkKey k) = invShortLinkKdf :: LinkKey -> C.SbKey invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32 -encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPairEd25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString)) +encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPairEd25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> UserLinkData -> (LinkKey, (ByteString, ByteString)) encodeSignLinkData (rootKey, pk) agentVRange connReq userData = let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq} md = smpEncode $ connLinkData @c agentVRange userData in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk md)) -encodeSignUserData :: forall c. ConnectionModeI c => SConnectionMode c -> C.PrivateKeyEd25519 -> VersionRangeSMPA -> ConnInfo -> ByteString +encodeSignUserData :: forall c. ConnectionModeI c => SConnectionMode c -> C.PrivateKeyEd25519 -> VersionRangeSMPA -> UserLinkData -> ByteString encodeSignUserData _ pk agentVRange userData = encodeSign pk $ smpEncode $ connLinkData @c agentVRange userData -connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> ConnInfo -> ConnLinkData c +connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> UserLinkData -> ConnLinkData c connLinkData agentVRange userData = case sConnectionMode @c of SCMInvitation -> InvitationLinkData agentVRange userData SCMContact -> ContactLinkData {agentVRange, direct = True, owners = [], relays = [], userData} diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 416a61f8d..1a7dedef5 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -265,9 +265,11 @@ atomicModifyIORef'_ r f = atomicModifyIORef' r (\v -> (f v, ())) encodeJSON :: ToJSON a => a -> Text encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode +{-# INLINE encodeJSON #-} decodeJSON :: FromJSON a => Text -> Maybe a -decodeJSON = J.decode . LB.fromStrict . encodeUtf8 +decodeJSON = J.decodeStrict . encodeUtf8 +{-# INLINE decodeJSON #-} traverseWithKey_ :: Monad m => (k -> v -> m ()) -> Map k v -> m () traverseWithKey_ f = M.foldrWithKey (\k v -> (f k v >>)) (pure ()) diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index d59874921..52e88fdcc 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -5,7 +5,7 @@ module AgentTests.EqInstances where import Data.Type.Equality -import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..)) +import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..), UserLinkData (..)) import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client (ProxiedRelay (..)) @@ -30,6 +30,10 @@ deriving instance Show (ConnLinkData c) deriving instance Eq (ConnLinkData c) +deriving instance Show UserLinkData + +deriving instance Eq UserLinkData + deriving instance Show OwnerAuth deriving instance Eq OwnerAuth diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 000cee386..e527323f9 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1137,7 +1137,7 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testInviationShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do - let userData = "some user data" + let userData = UserLinkData "some user data" (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink @@ -1171,14 +1171,14 @@ testJoinConn_ viaProxy sndSecure a bId b connReq = do testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> AgentClient -> IO () testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do - let userData = "some user data" + let userData = UserLinkData "some user data" -- can't create short link with previous version (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe testJoinConn_ viaProxy sndSecure a bId b connReq testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testInviationShortLinkAsync viaProxy a b = do - let userData = "some user data" + let userData = UserLinkData "some user data" (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink @@ -1197,7 +1197,7 @@ testInviationShortLinkAsync viaProxy a b = do testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testContactShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do - let userData = "some user data" + let userData = UserLinkData "some user data" (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink @@ -1226,7 +1226,7 @@ testContactShortLink viaProxy a b = get b ##> ("", aId, CON) exchangeGreetingsViaProxy viaProxy a bId b aId -- update user data - let updatedData = "updated user data" + let updatedData = UserLinkData "updated user data" shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing shortLink' `shouldBe` shortLink (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink @@ -1245,7 +1245,7 @@ testAddContactShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) -- - let userData = "some user data" + let userData = UserLinkData "some user data" shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink @@ -1273,7 +1273,7 @@ testAddContactShortLink viaProxy a b = get b ##> ("", aId, CON) exchangeGreetingsViaProxy viaProxy a bId b aId -- update user data - let updatedData = "updated user data" + let updatedData = UserLinkData "updated user data" shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing shortLink' `shouldBe` shortLink (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink @@ -1282,7 +1282,7 @@ testAddContactShortLink viaProxy a b = testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do - let userData = "some user data" + let userData = UserLinkData "some user data" (bId, (CCLink connReq (Just shortLink), Nothing)) <- withSmpServer ps $ runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate withSmpServer ps $ do @@ -1294,11 +1294,11 @@ testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do - let userData = "some user data" + let userData = UserLinkData "some user data" (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- withSmpServer ps $ runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate Right connReq <- pure $ smpDecode (smpEncode connReq0) - let updatedData = "updated user data" + let updatedData = UserLinkData "updated user data" withSmpServer ps $ do (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink @@ -1314,12 +1314,12 @@ testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do - let userData = "some user data" + let userData = UserLinkData "some user data" ((contactId, (CCLink connReq0 Nothing, Nothing)), shortLink) <- withSmpServer ps $ runRight $ do r@(contactId, _) <- A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate (r,) <$> setConnShortLink a contactId SCMContact userData Nothing Right connReq <- pure $ smpDecode (smpEncode connReq0) - let updatedData = "updated user data" + let updatedData = UserLinkData "updated user data" withSmpServer ps $ do (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink @@ -1355,14 +1355,14 @@ testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do _ -> pure () withSmpServer ps $ do - let userData = "some user data" + let userData = UserLinkData "some user data" shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq linkUserData connData' `shouldBe` userData -- update user data - let updatedData = "updated user data" + let updatedData = UserLinkData "updated user data" shortLink' <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing shortLink' `shouldBe` shortLink -- check updated diff --git a/tests/AgentTests/ShortLinkTests.hs b/tests/AgentTests/ShortLinkTests.hs index 216b7c658..b38daa7d8 100644 --- a/tests/AgentTests/ShortLinkTests.hs +++ b/tests/AgentTests/ShortLinkTests.hs @@ -8,7 +8,7 @@ import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) import AgentTests.EqInstances () import Control.Concurrent.STM import Control.Monad.Except -import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SConnectionMode (..), SMPAgentError (..), linkUserData, supportedSMPAgentVRange) +import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SConnectionMode (..), SMPAgentError (..), UserLinkData (..), linkUserData, supportedSMPAgentVRange) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.ShortLink as SL import Test.Hspec hiding (fit, it) @@ -30,7 +30,7 @@ testInvShortLink = do -- encrypt g <- C.newRandom sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g - let userData = "some user data" + let userData = UserLinkData "some user data" (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData k = SL.invShortLinkKdf linkKey Right srvData <- runExceptT $ SL.encryptLinkData g k linkData @@ -44,7 +44,7 @@ testInvShortLinkBadDataHash = do -- encrypt g <- C.newRandom sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g - let userData = "some user data" + let userData = UserLinkData "some user data" (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData -- different key linkKey <- LinkKey <$> atomically (C.randomBytes 32 g) @@ -59,7 +59,7 @@ testContactShortLink = do -- encrypt g <- C.newRandom sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g - let userData = "some user data" + let userData = UserLinkData "some user data" (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData (_linkId, k) = SL.contactShortLinkKdf linkKey Right srvData <- runExceptT $ SL.encryptLinkData g k linkData @@ -73,12 +73,12 @@ testUpdateContactShortLink = do -- encrypt g <- C.newRandom sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g - let userData = "some user data" + let userData = UserLinkData "some user data" (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData (_linkId, k) = SL.contactShortLinkKdf linkKey Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData -- encrypt updated user data - let updatedUserData = "updated user data" + let updatedUserData = UserLinkData "updated user data" signed = SL.encodeSignUserData SCMContact (snd sigKeys) supportedSMPAgentVRange updatedUserData Right ud' <- runExceptT $ SL.encryptUserData g k signed -- decrypt @@ -91,7 +91,7 @@ testContactShortLinkBadDataHash = do -- encrypt g <- C.newRandom sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g - let userData = "some user data" + let userData = UserLinkData "some user data" (_linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData -- different key linkKey <- LinkKey <$> atomically (C.randomBytes 32 g) @@ -106,12 +106,12 @@ testContactShortLinkBadSignature = do -- encrypt g <- C.newRandom sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g - let userData = "some user data" + let userData = UserLinkData "some user data" (linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData (_linkId, k) = SL.contactShortLinkKdf linkKey Right (fd, _ud) <- runExceptT $ SL.encryptLinkData g k linkData -- encrypt updated user data - let updatedUserData = "updated user data" + let updatedUserData = UserLinkData "updated user data" -- another signature key (_, pk) <- atomically $ C.generateKeyPair @'C.Ed25519 g let signed = SL.encodeSignUserData SCMContact pk supportedSMPAgentVRange updatedUserData From b47d28a22a7e11883515ad8f46e01f324b902d43 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 17 Jun 2025 21:10:09 +0100 Subject: [PATCH 02/22] smp server: prometheus metrics for delievered and not acknowledged messages (to monitor stuck deliveries) (#1572) --- src/Simplex/Messaging/Server.hs | 10 +++++++++- src/Simplex/Messaging/Server/Prometheus.hs | 10 ++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index b17054025..194cded59 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -684,16 +684,24 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt let threadsCount = 0 #endif clientsCount <- IM.size <$> getServerClients srv + deliveredSubs <- getDeliveredMetrics smpSubs <- getSubscribersMetrics subscribers ntfSubs <- getSubscribersMetrics ntfSubscribers loadedCounts <- loadedQueueCounts $ fromMsgStore ms - pure RealTimeMetrics {socketStats, threadsCount, clientsCount, smpSubs, ntfSubs, loadedCounts} + pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, smpSubs, ntfSubs, loadedCounts} where getSubscribersMetrics ServerSubscribers {queueSubscribers, serviceSubscribers, subClients} = do subsCount <- M.size <$> getSubscribedClients queueSubscribers subClientsCount <- IS.size <$> readTVarIO subClients subServicesCount <- M.size <$> getSubscribedClients serviceSubscribers pure RTSubscriberMetrics {subsCount, subClientsCount, subServicesCount} + getDeliveredMetrics = foldM countClnt (RTSubscriberMetrics 0 0 0) =<< getServerClients srv + countClnt metrics Client {subscriptions} = do + cnt <- foldM countSubs 0 =<< readTVarIO subscriptions + pure $ if cnt > 0 + then metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1} + else metrics + countSubs !cnt Sub {delivered} = (\empty -> if empty then cnt else cnt + 1) <$> atomically (isEmptyTMVar delivered) runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s () runClient srvCert srvSignKey tp h = do diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index de16873ee..5d9dcc786 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -34,6 +34,7 @@ data RealTimeMetrics = RealTimeMetrics { socketStats :: [(ServiceName, SocketStats)], threadsCount :: Int, clientsCount :: Int, + deliveredSubs :: RTSubscriberMetrics, smpSubs :: RTSubscriberMetrics, ntfSubs :: RTSubscriberMetrics, loadedCounts :: LoadedQueueCounts @@ -55,6 +56,7 @@ prometheusMetrics sm rtm ts = { socketStats, threadsCount, clientsCount, + deliveredSubs, smpSubs, ntfSubs, loadedCounts @@ -426,6 +428,14 @@ prometheusMetrics sm rtm ts = \# TYPE simplex_smp_clients_total gauge\n\ \simplex_smp_clients_total " <> mshow clientsCount <> "\n\ \\n\ + \# HELP simplex_smp_delivered_total Total SMP subscriptions with delivered messages\n\ + \# TYPE simplex_smp_delivered_total gauge\n\ + \simplex_smp_delivered_total " <> mshow (subsCount deliveredSubs) <> "\n# delivered.subsCount\n\ + \\n\ + \# HELP simplex_smp_delivered_clients_total Subscribed clients\n\ + \# TYPE simplex_smp_delivered_clients_total gauge\n\ + \simplex_smp_delivered_clients_total " <> mshow (subClientsCount deliveredSubs) <> "\n# delivered.subClientsCount\n\ + \\n\ \# HELP simplex_smp_subscribtion_total Total SMP subscriptions\n\ \# TYPE simplex_smp_subscribtion_total gauge\n\ \simplex_smp_subscribtion_total " <> mshow (subsCount smpSubs) <> "\n# smp.subsCount\n\ From c8928626fc35b8843fd2be99c026395391cb39c5 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 19 Jun 2025 09:15:07 +0100 Subject: [PATCH 03/22] ntf server: do not log subscription status updates on subscribing/unsubscribing (#1574) --- .../Notifications/Server/Store/Postgres.hs | 40 ++++++++----------- 1 file changed, 17 insertions(+), 23 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index aaa4e5932..7d52bb975 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -493,11 +493,11 @@ updateSrvSubStatus st q status = batchUpdateSrvSubStatus :: NtfPostgresStore -> SMPServer -> Maybe ServiceId -> NonEmpty NotifierId -> NtfSubStatus -> IO Int batchUpdateSrvSubStatus st srv newServiceId nIds status = fmap (fromRight (-1)) $ withDB "batchUpdateSrvSubStatus" st $ \db -> runExceptT $ do - (srvId, currServiceId) <- ExceptT $ getSMPServerService db + (srvId :: Int64, currServiceId) <- ExceptT $ getSMPServerService db unless (currServiceId == newServiceId) $ liftIO $ void $ DB.execute db "UPDATE smp_servers SET ntf_service_id = ? WHERE smp_server_id = ?" (newServiceId, srvId) let params = L.toList $ L.map (srvId,isJust newServiceId,status,) nIds - batchUpdateStatus_ st db params + liftIO $ fromIntegral <$> DB.executeMany db updateSubStatusQuery params where getSMPServerService db = firstRow id AUTH $ @@ -514,9 +514,11 @@ batchUpdateSrvSubStatus st srv newServiceId nIds status = batchUpdateSrvSubErrors :: NtfPostgresStore -> SMPServer -> NonEmpty (NotifierId, NtfSubStatus) -> IO Int batchUpdateSrvSubErrors st srv subs = fmap (fromRight (-1)) $ withDB "batchUpdateSrvSubErrors" st $ \db -> runExceptT $ do - srvId <- ExceptT $ getSMPServerId db - let params = L.toList $ L.map (\(nId, status) -> (srvId, False, status, nId)) subs - batchUpdateStatus_ st db params + srvId :: Int64 <- ExceptT $ getSMPServerId db + let params = map (\(nId, status) -> (srvId, False, status, nId)) $ L.toList subs + subs' <- liftIO $ DB.returning db (updateSubStatusQuery <> " RETURNING s.subscription_id, s.status, s.ntf_service_assoc") params + withLog "batchUpdateStatus_" st $ forM_ subs' . logSubscriptionStatus + pure $ length subs' where getSMPServerId db = firstRow fromOnly AUTH $ @@ -529,24 +531,16 @@ batchUpdateSrvSubErrors st srv subs = |] (srvToRow srv) -batchUpdateStatus_ :: NtfPostgresStore -> DB.Connection -> [(Int64, NtfAssociatedService, NtfSubStatus, NotifierId)] -> ExceptT ErrorType IO Int -batchUpdateStatus_ st db params = do - subs <- - liftIO $ - DB.returning - db - [sql| - UPDATE subscriptions s - SET status = upd.status, ntf_service_assoc = upd.ntf_service_assoc - FROM (VALUES(?, ?, ?, ?)) AS upd(smp_server_id, ntf_service_assoc, status, smp_notifier_id) - WHERE s.smp_server_id = upd.smp_server_id - AND s.smp_notifier_id = (upd.smp_notifier_id :: BYTEA) - AND (s.status != upd.status OR s.ntf_service_assoc != upd.ntf_service_assoc) - RETURNING s.subscription_id, s.status, s.ntf_service_assoc - |] - params - withLog "batchUpdateStatus_" st $ forM_ subs . logSubscriptionStatus - pure $ length subs +updateSubStatusQuery :: Query +updateSubStatusQuery = + [sql| + UPDATE subscriptions s + SET status = upd.status, ntf_service_assoc = upd.ntf_service_assoc + FROM (VALUES(?, ?, ?, ?)) AS upd(smp_server_id, ntf_service_assoc, status, smp_notifier_id) + WHERE s.smp_server_id = upd.smp_server_id + AND s.smp_notifier_id = (upd.smp_notifier_id :: BYTEA) + AND (s.status != upd.status OR s.ntf_service_assoc != upd.ntf_service_assoc) + |] removeServiceAssociation :: NtfPostgresStore -> SMPServer -> IO (Either ErrorType (Int64, Int)) removeServiceAssociation st srv = do From 79c67f2026cd6dc3def2d0fac11089af667301e7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 19 Jun 2025 11:21:29 +0100 Subject: [PATCH 04/22] agent: JSON encoding for connection mode (#1576) --- src/Simplex/Messaging/Agent/Protocol.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 44a749898..68211523f 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -174,6 +174,8 @@ where import Control.Applicative (optional, (<|>)) import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?)) +import qualified Data.Aeson as J' +import qualified Data.Aeson.Encoding as JE import qualified Data.Aeson.TH as J import qualified Data.Aeson.Types as JT import Data.Attoparsec.ByteString.Char8 (Parser) @@ -192,6 +194,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) +import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Time.Clock.System (SystemTime) @@ -1193,6 +1196,16 @@ instance Encoding ConnectionMode where 'C' -> pure CMContact _ -> fail "bad connection mode" +instance ToJSON ConnectionMode where + toJSON = J'.String . T.toLower . decodeLatin1 . strEncode + {-# INLINE toJSON #-} + toEncoding = JE.text . T.toLower . decodeLatin1 . strEncode + {-# INLINE toEncoding #-} + +instance FromJSON ConnectionMode where + parseJSON = J'.withText "ConnectionMode" $ either fail pure . parseAll strP . encodeUtf8 . T.toUpper + {-# INLINE parseJSON #-} + connModeT :: Text -> Maybe ConnectionMode connModeT = \case "INV" -> Just CMInvitation From 455360205c83a1fa85f910e64f7feffcc101ffef Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 20 Jun 2025 13:46:59 +0100 Subject: [PATCH 05/22] smp server: prometheus histogram for message confirmation times (ACK) (#1575) * time buckets * split max time metric * histogram * histogram for confirmed delivery times * gaugehistogram * fix created, _ in gauge_histogram * remove comments * fix metrics --- src/Simplex/Messaging/Server.hs | 108 ++++++++++++--------- src/Simplex/Messaging/Server/Env/STM.hs | 2 +- src/Simplex/Messaging/Server/Prometheus.hs | 45 ++++++++- src/Simplex/Messaging/Server/QueueStore.hs | 3 + src/Simplex/Messaging/Server/Stats.hs | 41 ++++++++ 5 files changed, 149 insertions(+), 50 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 194cded59..03a672408 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -684,24 +684,29 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt let threadsCount = 0 #endif clientsCount <- IM.size <$> getServerClients srv - deliveredSubs <- getDeliveredMetrics + (deliveredSubs, deliveredTimes) <- getDeliveredMetrics =<< getSystemSeconds smpSubs <- getSubscribersMetrics subscribers ntfSubs <- getSubscribersMetrics ntfSubscribers loadedCounts <- loadedQueueCounts $ fromMsgStore ms - pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, smpSubs, ntfSubs, loadedCounts} + pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts} where getSubscribersMetrics ServerSubscribers {queueSubscribers, serviceSubscribers, subClients} = do subsCount <- M.size <$> getSubscribedClients queueSubscribers subClientsCount <- IS.size <$> readTVarIO subClients subServicesCount <- M.size <$> getSubscribedClients serviceSubscribers pure RTSubscriberMetrics {subsCount, subClientsCount, subServicesCount} - getDeliveredMetrics = foldM countClnt (RTSubscriberMetrics 0 0 0) =<< getServerClients srv - countClnt metrics Client {subscriptions} = do - cnt <- foldM countSubs 0 =<< readTVarIO subscriptions - pure $ if cnt > 0 - then metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1} - else metrics - countSubs !cnt Sub {delivered} = (\empty -> if empty then cnt else cnt + 1) <$> atomically (isEmptyTMVar delivered) + getDeliveredMetrics ts' = foldM countClnt (RTSubscriberMetrics 0 0 0, emptyTimeBuckets) =<< getServerClients srv + where + countClnt acc@(metrics, times) Client {subscriptions} = do + (cnt, times') <- foldM countSubs (0, times) =<< readTVarIO subscriptions + pure $ if cnt > 0 + then (metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1}, times') + else acc + countSubs acc@(!cnt, times) Sub {delivered} = do + delivered_ <- atomically $ tryReadTMVar delivered + pure $ case delivered_ of + Nothing -> acc + Just (_, ts) -> (cnt + 1, updateTimeBuckets ts ts' times) runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s () runClient srvCert srvSignKey tp h = do @@ -1633,7 +1638,7 @@ client -- This is tracked as "subscription" in the client to prevent these -- clients from being able to subscribe. pure s - getMessage_ :: Sub -> Maybe MsgId -> M s (Transmission BrokerMsg) + getMessage_ :: Sub -> Maybe (MsgId, RoundedSystemTime) -> M s (Transmission BrokerMsg) getMessage_ s delivered_ = do stats <- asks serverStats fmap (either err id) $ liftIO $ runExceptT $ @@ -1641,7 +1646,8 @@ client Just msg -> do let encMsg = encryptMsg qr msg incStat $ (if isJust delivered_ then msgGetDuplicate else msgGet) stats - atomically $ setDelivered s msg $> (corrId, entId, MSG encMsg) + ts <- liftIO getSystemSeconds + atomically $ setDelivered s msg ts $> (corrId, entId, MSG encMsg) Nothing -> incStat (msgGetNoMsg stats) $> ok withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Transmission BrokerMsg) @@ -1734,28 +1740,28 @@ client Nothing -> pure $ err NO_MSG Just sub -> atomically (getDelivered sub) >>= \case - Just st -> do + Just (st, ts) -> do stats <- asks serverStats fmap (either err id) $ liftIO $ runExceptT $ do case st of ProhibitSub -> do deletedMsg_ <- tryDelMsg ms q msgId - liftIO $ mapM_ (updateStats stats True) deletedMsg_ + liftIO $ mapM_ (updateStats stats True ts) deletedMsg_ pure ok _ -> do (deletedMsg_, msg_) <- tryDelPeekMsg ms q msgId - liftIO $ mapM_ (updateStats stats False) deletedMsg_ + liftIO $ mapM_ (updateStats stats False ts) deletedMsg_ liftIO $ deliverMessage "ACK" qr entId sub msg_ _ -> pure $ err NO_MSG where - getDelivered :: Sub -> STM (Maybe ServerSub) + getDelivered :: Sub -> STM (Maybe (ServerSub, RoundedSystemTime)) getDelivered Sub {delivered, subThread} = do - tryTakeTMVar delivered $>>= \msgId' -> + tryTakeTMVar delivered $>>= \v@(msgId', ts) -> if msgId == msgId' || B.null msgId - then pure $ Just subThread - else putTMVar delivered msgId' $> Nothing - updateStats :: ServerStats -> Bool -> Message -> IO () - updateStats stats isGet = \case + then pure $ Just (subThread, ts) + else putTMVar delivered v $> Nothing + updateStats :: ServerStats -> Bool -> RoundedSystemTime -> Message -> IO () + updateStats stats isGet deliveryTime = \case MessageQuota {} -> pure () Message {msgFlags} -> do incStat $ msgRecv stats @@ -1772,6 +1778,8 @@ client when (notification msgFlags) $ do incStat $ msgRecvNtf stats updatePeriodStats (activeQueuesNtf stats) entId + currTime <- getSystemSeconds + atomicModifyIORef'_ (msgRecvAckTimes stats) $ updateTimeBuckets deliveryTime currTime sendMessage :: MsgFlags -> MsgBody -> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg) sendMessage msgFlags msgBody q qr @@ -1839,33 +1847,35 @@ client -- the subscribed client var is read outside of STM to avoid transaction cost -- in case no client is subscribed. getSubscribedClient rId (queueSubscribers subscribers) - $>>= atomically . deliverToSub + $>>= deliverToSub >>= mapM_ forkDeliver where rId = recipientId q - deliverToSub rcv = + deliverToSub rcv = do + ts <- getSystemSeconds + atomically $ -- reading client TVar in the same transaction, -- so that if subscription ends, it re-evalutates -- and delivery is cancelled - -- the new client will receive message in response to SUB. - readTVar rcv - $>>= \rc@Client {subscriptions = subs, sndQ = sndQ'} -> TM.lookup rId subs - $>>= \s@Sub {subThread, delivered} -> case subThread of - ProhibitSub -> pure Nothing - ServerSub st -> readTVar st >>= \case - NoSub -> - tryTakeTMVar delivered >>= \case - Just _ -> pure Nothing -- if a message was already delivered, should not deliver more - Nothing -> - ifM - (isFullTBQueue sndQ') - (writeTVar st SubPending $> Just (rc, s, st)) - (deliver sndQ' s $> Nothing) - _ -> pure Nothing - deliver sndQ' s = do + readTVar rcv + $>>= \rc@Client {subscriptions = subs, sndQ = sndQ'} -> TM.lookup rId subs + $>>= \s@Sub {subThread, delivered} -> case subThread of + ProhibitSub -> pure Nothing + ServerSub st -> readTVar st >>= \case + NoSub -> + tryTakeTMVar delivered >>= \case + Just _ -> pure Nothing -- if a message was already delivered, should not deliver more + Nothing -> + ifM + (isFullTBQueue sndQ') + (writeTVar st SubPending $> Just (rc, s, st)) + (deliver sndQ' s ts $> Nothing) + _ -> pure Nothing + deliver sndQ' s ts = do let encMsg = encryptMsg qr msg writeTBQueue sndQ' [(CorrId "", rId, MSG encMsg)] - void $ setDelivered s msg + void $ setDelivered s msg ts forkDeliver (rc@Client {sndQ = sndQ'}, s@Sub {delivered}, st) = do t <- mkWeakThreadId =<< forkIO deliverThread atomically $ modifyTVar' st $ \case @@ -1878,13 +1888,14 @@ client -- lookup can be outside of STM transaction, -- as long as the check that it is the same client is inside. getSubscribedClient rId (queueSubscribers subscribers) >>= mapM_ deliverIfSame - deliverIfSame rcv = time "deliver" . atomically $ - whenM (sameClient rc rcv) $ + deliverIfSame rcv = time "deliver" $ do + ts <- getSystemSeconds + atomically $ whenM (sameClient rc rcv) $ tryTakeTMVar delivered >>= \case Just _ -> pure () -- if a message was already delivered, should not deliver more Nothing -> do -- a separate thread is needed because it blocks when client sndQ is full. - deliver sndQ' s + deliver sndQ' s ts writeTVar st NoSub enqueueNotification :: NtfCreds -> Message -> M s () @@ -1958,13 +1969,14 @@ client VRFailed e -> Left (corrId', entId', ERR e) deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> IO (Transmission BrokerMsg) - deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") . atomically $ + deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") $ case subThread of ProhibitSub -> pure resp _ -> case msg_ of - Just msg -> + Just msg -> do + ts <- getSystemSeconds let encMsg = encryptMsg qr msg - in setDelivered s msg $> (corrId, rId, MSG encMsg) + atomically (setDelivered s msg ts) $> (corrId, rId, MSG encMsg) _ -> pure resp where resp = (corrId, rId, OK) @@ -1982,8 +1994,10 @@ client msgId' = messageId msg msgTs' = messageTs msg - setDelivered :: Sub -> Message -> STM Bool - setDelivered s msg = tryPutTMVar (delivered s) $! messageId msg + setDelivered :: Sub -> Message -> RoundedSystemTime -> STM Bool + setDelivered Sub {delivered} msg !ts = do + let !msgId = messageId msg + tryPutTMVar delivered (msgId, ts) delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg) delQueueAndMsgs (q, QueueRec {rcvServiceId}) = do @@ -2024,7 +2038,7 @@ client SubPending -> QSubPending SubThread _ -> QSubThread ProhibitSub -> pure QProhibitSub - qDelivered <- atomically $ decodeLatin1 . encode <$$> tryReadTMVar delivered + qDelivered <- atomically $ decodeLatin1 . encode . fst <$$> tryReadTMVar delivered pure QSub {qSubThread, qDelivered} ok :: Transmission BrokerMsg diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 627c6079a..a04a8acd8 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -412,7 +412,7 @@ data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) data Sub = Sub { subThread :: ServerSub, -- Nothing value indicates that sub - delivered :: TMVar MsgId + delivered :: TMVar (MsgId, RoundedSystemTime) } newServer :: IO (Server s) diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index 5d9dcc786..cdcf10cfd 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -6,6 +6,8 @@ module Simplex.Messaging.Server.Prometheus where import Data.Int (Int64) +import qualified Data.IntMap.Strict as IM +import Data.List (mapAccumL) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), diffUTCTime) @@ -35,6 +37,7 @@ data RealTimeMetrics = RealTimeMetrics threadsCount :: Int, clientsCount :: Int, deliveredSubs :: RTSubscriberMetrics, + deliveredTimes :: TimeBuckets, smpSubs :: RTSubscriberMetrics, ntfSubs :: RTSubscriberMetrics, loadedCounts :: LoadedQueueCounts @@ -57,6 +60,7 @@ prometheusMetrics sm rtm ts = threadsCount, clientsCount, deliveredSubs, + deliveredTimes, smpSubs, ntfSubs, loadedCounts @@ -90,6 +94,7 @@ prometheusMetrics sm rtm ts = _msgSentLarge, _msgSentBlock, _msgRecv, + _msgRecvAckTimes, _msgRecvGet, _msgGet, _msgGetNoMsg, @@ -436,6 +441,25 @@ prometheusMetrics sm rtm ts = \# TYPE simplex_smp_delivered_clients_total gauge\n\ \simplex_smp_delivered_clients_total " <> mshow (subClientsCount deliveredSubs) <> "\n# delivered.subClientsCount\n\ \\n\ + \# HELP simplex_smp_delivery_ack_confirmed_time Times to confirm message delivery, only confirmed deliveries\n\ + \# TYPE simplex_smp_delivery_ack_confirmed_time histogram\n\ + \simplex_smp_delivery_ack_confirmed_time_sum " <> mshow (sumTime _msgRecvAckTimes) <> "\n\ + \simplex_smp_delivery_ack_confirmed_time_count " <> mshow (_msgRecv + _msgRecvGet) <> "\n" + <> showTimeBuckets "simplex_smp_delivery_ack_confirmed_time" (timeBuckets _msgRecvAckTimes) + <> showTimeBucket "simplex_smp_delivery_ack_confirmed_time" "+Inf" (_msgRecv + _msgRecvGet) + <> "\n\ + \# HELP simplex_smp_delivery_ack_confirmed_count Counts for confirmed deliveries\n\ + \# TYPE simplex_smp_delivery_ack_confirmed_count counter\n" + <> showBucketSums "simplex_smp_delivery_ack_confirmed_count" (timeBuckets _msgRecvAckTimes) + <> "\n\ + \# HELP simplex_smp_delivery_ack_pending_count Counts for pending delivery\n\ + \# TYPE simplex_smp_delivery_ack_pending_count gauge\n" + <> showBucketSums "simplex_smp_delivery_ack_pending_count" (timeBuckets deliveredTimes) + <> "\n\ + \# HELP simplex_smp_delivery_ack_time_max Max time to confirm message delivery\n\ + \# TYPE simplex_smp_delivery_ack_time_max gauge\n\ + \simplex_smp_delivery_ack_time_max " <> mshow (maxTime deliveredTimes) <> "\n# delivered.maxTime\n\ + \\n\ \# HELP simplex_smp_subscribtion_total Total SMP subscriptions\n\ \# TYPE simplex_smp_subscribtion_total gauge\n\ \simplex_smp_subscribtion_total " <> mshow (subsCount smpSubs) <> "\n# smp.subsCount\n\ @@ -480,15 +504,32 @@ prometheusMetrics sm rtm ts = \# TYPE simplex_smp_loaded_queues_ntf_lock_count gauge\n\ \simplex_smp_loaded_queues_ntf_lock_count " <> mshow (notifierLockCount loadedCounts) <> "\n# loadedCounts.notifierLockCount\n" + showTimeBuckets :: Text -> IM.IntMap Int -> Text + showTimeBuckets metric = T.concat . snd . mapAccumL accumBucket (0, 0) . IM.assocs + where + accumBucket (prevSec, total) (sec, cnt) = + let t + | sec - 60 > prevSec = showTimeBucket metric (tshow (sec - 60)) total + | otherwise = "" + in ((sec, total + cnt), t <> showTimeBucket metric (tshow sec) (total + cnt)) + showTimeBucket :: Text -> Text -> Int -> Text + showTimeBucket metric sec count = metric <> "_bucket{le=\"" <> sec <> "\"} " <> mshow count <> "\n" + showBucketSums :: Text -> IM.IntMap Int -> Text + showBucketSums metric buckets = T.concat $ map showBucketSum [(0, 60), (60, 300), (300, 1200), (1200, 3600), (3600, maxBound)] + where + showBucketSum (minTime, maxTime) = + metric <> "{period=\"" <> tshow minTime <> (if maxTime <= 3600 then "-" <> tshow maxTime else "+") <> "\"} " <> mshow bucketsSum <> "\n" + where + bucketsSum = IM.foldl' (+) 0 $ IM.filter (\sec -> minTime <= sec && sec < maxTime) buckets socketsMetric :: (SocketStats -> Int) -> Text -> Text -> Text socketsMetric sel metric descr = "# HELP " <> metric <> " " <> descr <> "\n" <> "# TYPE " <> metric <> " gauge\n" <> T.concat (map (\(port, ss) -> metric <> "{port=\"" <> T.pack port <> "\"} " <> mshow (sel ss) <> "\n") socketStats) <> "\n" - mstr a = a <> " " <> tsEpoch + mstr a = a <> " " <> tsEpoch ts mshow :: Show a => a -> Text mshow = mstr . tshow - tsEpoch = tshow @Int64 $ floor @Double $ realToFrac (ts `diffUTCTime` epoch) * 1000 + tsEpoch t = tshow @Int64 $ floor @Double $ realToFrac (t `diffUTCTime` epoch) * 1000 epoch = UTCTime systemEpochDay 0 {-# FOURMOLU_ENABLE\n#-} diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index cbac2bf08..9395f5bac 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -127,3 +127,6 @@ getRoundedSystemTime prec = (\t -> RoundedSystemTime $ (systemSeconds t `div` pr getSystemDate :: IO RoundedSystemTime getSystemDate = getRoundedSystemTime 86400 + +getSystemSeconds :: IO RoundedSystemTime +getSystemSeconds = RoundedSystemTime . systemSeconds <$> getSystemTime diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index da90b7216..50c611009 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -14,6 +14,8 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Hashable (hash) import Data.IORef +import Data.Int (Int64) +import qualified Data.IntMap.Strict as IM import Data.IntSet (IntSet) import qualified Data.IntSet as IS import Data.Set (Set) @@ -25,6 +27,7 @@ import Data.Time.Clock (UTCTime (..)) import GHC.IORef (atomicSwapIORef) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (EntityId (..)) +import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..)) import Simplex.Messaging.Util (atomicModifyIORef'_, tshow, unlessM) data ServerStats = ServerStats @@ -57,6 +60,7 @@ data ServerStats = ServerStats msgSentLarge :: IORef Int, msgSentBlock :: IORef Int, msgRecv :: IORef Int, + msgRecvAckTimes :: IORef TimeBuckets, msgRecvGet :: IORef Int, msgGet :: IORef Int, msgGetNoMsg :: IORef Int, @@ -115,6 +119,7 @@ data ServerStatsData = ServerStatsData _msgSentLarge :: Int, _msgSentBlock :: Int, _msgRecv :: Int, + _msgRecvAckTimes :: TimeBuckets, _msgRecvGet :: Int, _msgGet :: Int, _msgGetNoMsg :: Int, @@ -174,6 +179,7 @@ newServerStats ts = do msgSentLarge <- newIORef 0 msgSentBlock <- newIORef 0 msgRecv <- newIORef 0 + msgRecvAckTimes <- newIORef $ TimeBuckets 0 0 IM.empty msgRecvGet <- newIORef 0 msgGet <- newIORef 0 msgGetNoMsg <- newIORef 0 @@ -230,6 +236,7 @@ newServerStats ts = do msgSentLarge, msgSentBlock, msgRecv, + msgRecvAckTimes, msgRecvGet, msgGet, msgGetNoMsg, @@ -288,6 +295,7 @@ getServerStatsData s = do _msgSentLarge <- readIORef $ msgSentLarge s _msgSentBlock <- readIORef $ msgSentBlock s _msgRecv <- readIORef $ msgRecv s + _msgRecvAckTimes <- readIORef $ msgRecvAckTimes s _msgRecvGet <- readIORef $ msgRecvGet s _msgGet <- readIORef $ msgGet s _msgGetNoMsg <- readIORef $ msgGetNoMsg s @@ -344,6 +352,7 @@ getServerStatsData s = do _msgSentLarge, _msgSentBlock, _msgRecv, + _msgRecvAckTimes, _msgRecvGet, _msgGet, _msgGetNoMsg, @@ -403,6 +412,7 @@ setServerStats s d = do writeIORef (msgSentLarge s) $! _msgSentLarge d writeIORef (msgSentBlock s) $! _msgSentBlock d writeIORef (msgRecv s) $! _msgRecv d + writeIORef (msgRecvAckTimes s) $! _msgRecvAckTimes d writeIORef (msgRecvGet s) $! _msgRecvGet d writeIORef (msgGet s) $! _msgGet d writeIORef (msgGetNoMsg s) $! _msgGetNoMsg d @@ -592,6 +602,7 @@ instance StrEncoding ServerStatsData where _msgSentLarge, _msgSentBlock, _msgRecv, + _msgRecvAckTimes = emptyTimeBuckets, _msgRecvGet, _msgGet, _msgGetNoMsg, @@ -944,3 +955,33 @@ instance StrEncoding ServiceStatsData where _srvSubQueues, _srvSubEnd } + +data TimeBuckets = TimeBuckets + { sumTime :: Int64, + maxTime :: Int64, + timeBuckets :: IM.IntMap Int + } + deriving (Show) + +emptyTimeBuckets :: TimeBuckets +emptyTimeBuckets = TimeBuckets 0 0 IM.empty + +updateTimeBuckets :: RoundedSystemTime -> RoundedSystemTime -> TimeBuckets -> TimeBuckets +updateTimeBuckets + (RoundedSystemTime deliveryTime) + (RoundedSystemTime currTime) + TimeBuckets {sumTime, maxTime, timeBuckets} = + TimeBuckets + { sumTime = sumTime + t, + maxTime = max maxTime t, + timeBuckets = IM.alter (Just . maybe 1 (+ 1)) seconds timeBuckets + } + where + t = currTime - deliveryTime + seconds + | t <= 5 = fromIntegral t + | t <= 30 = t `toBucket` 5 + | t <= 60 = t `toBucket` 10 + | t <= 180 = t `toBucket` 30 + | otherwise = t `toBucket` 60 + toBucket n m = - fromIntegral (((- n) `div` m) * m) -- round up From bf27c846da7536c6aace69457b915b4880edcb06 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 20 Jun 2025 13:49:17 +0100 Subject: [PATCH 06/22] 6.4.0.10.1 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index efc1da25a..67cd1657d 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.4.0.10 +version: 6.4.0.10.1 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 976bd3a389aaded78b4285541e6dddd6b2766149 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 24 Jun 2025 10:06:44 +0100 Subject: [PATCH 07/22] agent: short link encodings (#1577) --- src/Simplex/Messaging/Agent/Protocol.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 68211523f..98743b2fe 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1153,22 +1153,39 @@ connReqUriP overrideScheme = do instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where parseJSON = strParseJSON "ConnectionRequestUri" + {-# INLINE parseJSON #-} instance ConnectionModeI m => ToJSON (ConnectionRequestUri m) where toJSON = strToJSON + {-# INLINE toJSON #-} toEncoding = strToJEncoding + {-# INLINE toEncoding #-} instance FromJSON AConnectionRequestUri where parseJSON = strParseJSON "ConnectionRequestUri" + {-# INLINE parseJSON #-} instance ToJSON AConnectionRequestUri where toJSON = strToJSON + {-# INLINE toJSON #-} toEncoding = strToJEncoding + {-# INLINE toEncoding #-} instance ConnectionModeI m => FromJSON (ConnShortLink m) where parseJSON = strParseJSON "ConnShortLink" + {-# INLINE parseJSON #-} instance ConnectionModeI m => ToJSON (ConnShortLink m) where + toJSON = strToJSON + {-# INLINE toJSON #-} + toEncoding = strToJEncoding + {-# INLINE toEncoding #-} + +instance FromJSON AConnShortLink where + parseJSON = strParseJSON "AConnShortLink" + {-# INLINE parseJSON #-} + +instance ToJSON AConnShortLink where toJSON = strToJSON toEncoding = strToJEncoding @@ -1432,6 +1449,13 @@ data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show) data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) +instance Eq AConnShortLink where + ACSL m sl == ACSL m' sl' = case testEquality m m' of + Just Refl -> sl == sl' + Nothing -> False + +deriving instance Show AConnShortLink + instance ToField AConnShortLink where toField = toField . Binary . strEncode instance FromField AConnShortLink where fromField = blobFieldDecoder strDecode From b4bcfd325b43caefd9b649653c1b3ee6920bad61 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 25 Jun 2025 19:06:00 +0100 Subject: [PATCH 08/22] agent: better handling errors during connection handshake retries (#1578) * agent: handle invitation connection handshake errors * fix/test retries for connecting via address --- src/Simplex/Messaging/Agent.hs | 112 ++++++---- src/Simplex/Messaging/Agent/Client.hs | 12 +- src/Simplex/Messaging/Agent/Protocol.hs | 2 +- src/Simplex/Messaging/Agent/Store.hs | 6 +- .../Messaging/Agent/Store/AgentStore.hs | 12 +- src/Simplex/Messaging/Crypto/Ratchet.hs | 9 + tests/AgentTests/FunctionalAPITests.hs | 207 ++++++++++++++++-- tests/AgentTests/SQLiteTests.hs | 8 +- 8 files changed, 293 insertions(+), 75 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index c72d39729..dffe27389 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -787,7 +787,7 @@ ackMessageAsync' c corrId connId msgId rcptInfo_ = do case cType of SCDuplex -> enqueueAck SCRcv -> enqueueAck - SCSnd -> throwE $ CONN SIMPLEX + SCSnd -> throwE $ CONN SIMPLEX "ackMessageAsync" SCContact -> throwE $ CMD PROHIBITED "ackMessageAsync: SCContact" SCNew -> throwE $ CMD PROHIBITED "ackMessageAsync: SCNew" where @@ -851,7 +851,7 @@ setConnShortLink' c connId cMode userData clientData = pure sl where prepareContactLinkData :: RcvQueue -> AM (RcvQueue, SMP.LinkId, ConnShortLink 'CMContact, QueueLinkData) - prepareContactLinkData rq@RcvQueue {server, sndId, e2ePrivKey, shortLink} = do + prepareContactLinkData rq@RcvQueue {shortLink} = do g <- asks random AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config let cslContact = CSLContact SLSServer CCTContact (qServer rq) @@ -863,7 +863,7 @@ setConnShortLink' c connId cMode userData clientData = pure (rq, linkId, cslContact shortLinkKey, (linkEncFixedData, d)) Nothing -> do sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g - let qUri = SMPQueueUri vr $ SMPQueueAddress server sndId (C.publicKey e2ePrivKey) (Just QMContact) + let qUri = SMPQueueUri vr $ (rcvSMPQueueAddress rq) {queueMode = Just QMContact} connReq = CRContactUri $ ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData (linkKey, linkData) = SL.encodeSignLinkData sigKeys smpAgentVRange connReq userData (linkId, k) = SL.contactShortLinkKdf linkKey @@ -1129,23 +1129,46 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod withInvLock c (strEncode inv) "joinConnSrv" $ do SomeConn cType conn <- withStore c (`getConn` connId) case conn of - NewConnection _ -> doJoin Nothing - SndConnection _ sq -> doJoin $ Just sq - DuplexConnection _ (RcvQueue {status = New} :| _) (sq@SndQueue {status = New} :| _) -> doJoin $ Just sq + NewConnection _ -> doJoin Nothing Nothing + SndConnection _ sq -> doJoin Nothing (Just sq) + DuplexConnection _ (rq@RcvQueue {status = New} :| _) (sq@SndQueue {status = sqStatus} :| _) + | sqStatus == New || sqStatus == Secured -> doJoin (Just rq) (Just sq) _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType where - doJoin :: Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId) - doJoin sq_ = do + doJoin :: Maybe RcvQueue -> Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId) + doJoin rq_ sq_ = do (cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup - secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode + secureConfirmQueue c cData rq_ sq srv cInfo (Just e2eSndParams) subMode >>= (mapM_ (delInvSL c connId srv) lnkId_ $>) joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = lift (compatibleContactUri cReqUri) >>= \case - Just (qInfo, vrsn@(Compatible v)) -> do - let pqInitKeys = CR.joinContactInitialKeys (v >= pqdrSMPAgentVersion) pqSup - (CCLink cReq _, service) <- newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys subMode srv - void $ sendInvitation c userId connId qInfo vrsn cReq cInfo - pure (False, service) + Just (qInfo, vrsn@(Compatible v)) -> + withInvLock c (strEncode cReqUri) "joinConnSrv" $ do + SomeConn cType conn <- withStore c (`getConn` connId) + let pqInitKeys = CR.joinContactInitialKeys (v >= pqdrSMPAgentVersion) pqSup + (CCLink cReq _, service) <- case conn of + NewConnection _ -> newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys subMode srv + RcvConnection _ rq -> mkJoinInvitation rq pqInitKeys + _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType + void $ sendInvitation c userId connId qInfo vrsn cReq cInfo + pure (False, service) + where + mkJoinInvitation rq@RcvQueue {clientService} pqInitKeys = do + g <- asks random + AgentConfig {smpClientVRange = vr, smpAgentVRange, e2eEncryptVRange = e2eVR} <- asks config + let qUri = SMPQueueUri vr $ (rcvSMPQueueAddress rq) {queueMode = Just QMMessaging} + crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] Nothing + e2eRcvParams <- withStore' c $ \db -> + getRatchetX3dhKeys db connId >>= \case + Right keys -> pure $ CR.mkRcvE2ERatchetParams (maxVersion e2eVR) keys + Left e -> do + nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no rcv ratchet " <> show e)) + let pqEnc = CR.initialPQEncryption False pqInitKeys + (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eVR) pqEnc + createRatchetX3dhKeys db connId pk1 pk2 pKem + pure e2eRcvParams + let cReq = CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eVR + pure (CCLink cReq Nothing, dbServiceId <$> clientService) Nothing -> throwE $ AGENT A_VERSION delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SMP.LinkId -> AM () @@ -1157,14 +1180,18 @@ joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequest joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do SomeConn cType conn <- withStore c (`getConn` connId) case conn of - NewConnection _ -> doJoin Nothing - SndConnection _ sq -> doJoin $ Just sq + NewConnection _ -> doJoin Nothing Nothing + SndConnection _ sq -> doJoin Nothing (Just sq) + -- this branch should never be reached with async flow because once receive queue is created, + -- there are not more failure points (sending confirmation is asynchronous) + DuplexConnection _ (rq@RcvQueue {status = New} :| _) (sq@SndQueue {status = sqStatus} :| _) + | sqStatus == New || sqStatus == Secured -> doJoin (Just rq) (Just sq) _ -> throwE $ CMD PROHIBITED $ "joinConnSrvAsync: bad connection " <> show cType where - doJoin :: Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId) - doJoin sq_ = do + doJoin :: Maybe RcvQueue -> Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId) + doJoin rq_ sq_ = do (cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport - secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode + secureConfirmQueueAsync c cData rq_ sq srv cInfo (Just e2eSndParams) subMode >>= (mapM_ (delInvSL c connId srv) lnkId_ $>) joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do throwE $ CMD PROHIBITED "joinConnSrvAsync" @@ -1254,7 +1281,7 @@ subscribeConnections' c connIds = do sndSubResult :: SndQueue -> Either AgentErrorType (Maybe ClientServiceId) sndSubResult SndQueue {status} = case status of Confirmed -> Right Nothing - Active -> Left $ CONN SIMPLEX + Active -> Left $ CONN SIMPLEX "subscribeConnections" _ -> Left $ INTERNAL "unexpected queue status" connResults :: [(RcvQueue, Either AgentErrorType (Maybe SMP.ServiceId))] -> Map ConnId (Either AgentErrorType (Maybe SMP.ServiceId)) connResults = M.map snd . foldl' addResult M.empty @@ -1327,7 +1354,7 @@ getConnectionMessages' c = mapM $ tryAgentError' . getConnectionMessage DuplexConnection _ (rq :| _) _ -> pure rq RcvConnection _ rq -> pure rq ContactConnection _ rq -> pure rq - SndConnection _ _ -> throwE $ CONN SIMPLEX + SndConnection _ _ -> throwE $ CONN SIMPLEX "getConnectionMessage" NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection" msg_ <- getQueueMessage c rq `catchAgentError` \e -> atomically (releaseGetLock c rq) >> throwError e when (isNothing msg_) $ do @@ -1412,7 +1439,7 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do prepareConn s (Right ((_, pqEnc, msgFlags, msgOrRef), SomeConn _ conn)) = case conn of DuplexConnection cData _ sqs -> prepareMsg cData sqs SndConnection cData sq -> prepareMsg cData [sq] - _ -> (s, Left $ CONN SIMPLEX) + _ -> (s, Left $ CONN SIMPLEX "sendMessagesB_") where prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) prepareMsg cData@ConnData {connId, pqSupport} sqs @@ -1881,7 +1908,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI notify cmd = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) cmd) notifyDel :: AEntityI e => InternalId -> AEvent e -> AM () notifyDel msgId cmd = notify cmd >> delMsg msgId - connError msgId = notifyDel msgId . ERR . CONN + connError msgId = notifyDel msgId . ERR . (`CONN` "") qError msgId = notifyDel msgId . ERR . AGENT . A_QUEUE internalErr msgId = notifyDel msgId . ERR . INTERNAL @@ -1899,7 +1926,7 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do case conn of DuplexConnection {} -> ack >> sendRcpt conn >> del RcvConnection {} -> ack >> del - SndConnection {} -> throwE $ CONN SIMPLEX + SndConnection {} -> throwE $ CONN SIMPLEX "ackMessage" ContactConnection {} -> throwE $ CMD PROHIBITED "ackMessage: ContactConnection" NewConnection _ -> throwE $ CMD PROHIBITED "ackMessage: NewConnection" where @@ -1933,8 +1960,8 @@ getConnectionQueueInfo' c connId = do DuplexConnection _ (rq :| _) _ -> getQueueInfo c rq RcvConnection _ rq -> getQueueInfo c rq ContactConnection _ rq -> getQueueInfo c rq - SndConnection {} -> throwE $ CONN SIMPLEX - NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionQueueInfo': NewConnection" + SndConnection {} -> throwE $ CONN SIMPLEX "getConnectionQueueInfo" + NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionQueueInfo: NewConnection" switchConnection' :: AgentClient -> ConnId -> AM ConnectionStats switchConnection' c connId = @@ -2035,7 +2062,7 @@ suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do DuplexConnection _ rqs _ -> mapM_ (suspendQueue c) rqs RcvConnection _ rq -> suspendQueue c rq ContactConnection _ rq -> suspendQueue c rq - SndConnection _ _ -> throwE $ CONN SIMPLEX + SndConnection _ _ -> throwE $ CONN SIMPLEX "suspendConnection" NewConnection _ -> throwE $ CMD PROHIBITED "suspendConnection" -- | Delete SMP agent connection (DEL command) in Reader monad @@ -2354,7 +2381,7 @@ toggleConnectionNtfs' c connId enable = do DuplexConnection cData _ _ -> toggle cData RcvConnection cData _ -> toggle cData ContactConnection cData _ -> toggle cData - _ -> throwE $ CONN SIMPLEX + _ -> throwE $ CONN SIMPLEX "toggleConnectionNtfs" where toggle :: ConnData -> AM () toggle cData @@ -2865,8 +2892,11 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId rc = CR.initRcvRatchet rcVs rcDHRs rcParams pqSupport' g <- asks random (agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt g rc M.empty encConnInfo - case (agentMsgBody_, skipped) of - (Right agentMsgBody, CR.SMDNoChange) -> + case skipped of + CR.SMDNoChange -> pure () + _ -> logWarn "conf: skipped confirmations" + case agentMsgBody_ of + Right agentMsgBody -> parseMessage agentMsgBody >>= \case AgentConnInfoReply smpQueues connInfo -> do processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer} @@ -2893,7 +2923,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId createConfirmation db g newConfirmation let srvs = map qServer $ smpReplyQueues senderConf notify $ CONF confId pqSupport' srvs connInfo - _ -> prohibited "conf: decrypt error or skipped" + _ -> prohibited "conf: decrypt error" -- party accepting connection (DuplexConnection _ (rq'@RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do g <- asks random @@ -3180,18 +3210,18 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _ (sq, _) <- lift $ newSndQueue userId connId qInfo' Nothing withStore c $ \db -> upgradeRcvConnToDuplex db connId sq -secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) -secureConfirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueueAsync :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) +secureConfirmQueueAsync c cData rq_ sq srv connInfo e2eEncryption_ subMode = do sqSecured <- agentSecureSndQueue c cData sq - (qInfo, service) <- mkAgentConfirmation c cData sq srv connInfo subMode + (qInfo, service) <- mkAgentConfirmation c cData rq_ sq srv connInfo subMode storeConfirmation c cData sq e2eEncryption_ qInfo lift $ submitPendingMsg c cData sq pure (sqSecured, service) -secureConfirmQueue :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) -secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} sq srv connInfo e2eEncryption_ subMode = do +secureConfirmQueue :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) +secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} rq_ sq srv connInfo e2eEncryption_ subMode = do sqSecured <- agentSecureSndQueue c cData sq - (qInfo, service) <- mkAgentConfirmation c cData sq srv connInfo subMode + (qInfo, service) <- mkAgentConfirmation c cData rq_ sq srv connInfo subMode msg <- mkConfirmation qInfo void $ sendConfirmation c sq msg withStore' c $ \db -> setSndQueueStatus db sq Confirmed @@ -3221,9 +3251,11 @@ agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {queueMode, status sndSecure = senderCanSecure queueMode initiatorRatchetOnConf = connAgentVersion >= ratchetOnConfSMPAgentVersion -mkAgentConfirmation :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId) -mkAgentConfirmation c cData sq srv connInfo subMode = do - (qInfo, service) <- createReplyQueue c cData sq subMode srv +mkAgentConfirmation :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId) +mkAgentConfirmation c cData rq_ sq srv connInfo subMode = do + (qInfo, service) <- case rq_ of + Nothing -> createReplyQueue c cData sq subMode srv + Just rq@RcvQueue {smpClientVersion = v, clientService} -> pure (SMPQueueInfo v $ rcvSMPQueueAddress rq, dbServiceId <$> clientService) pure (AgentConnInfoReply (qInfo :| []) connInfo, service) enqueueConfirmation :: AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> AM () diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 28c4fd7a3..da1993524 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -867,7 +867,7 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v = Right client -> do logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")" atomically $ putTMVar (sessionVar v) (Right client) - atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client) + liftIO $ nonBlockingWriteTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client) pure client Left e -> do ei <- asks $ persistErrorInterval . config @@ -2126,12 +2126,12 @@ withStoreBatch' c actions = withStoreBatch c (fmap (fmap Right) . actions) storeError :: StoreError -> AgentErrorType storeError = \case - SEConnNotFound -> CONN NOT_FOUND + SEConnNotFound -> CONN NOT_FOUND "" SEUserNotFound -> NO_USER - SERatchetNotFound -> CONN NOT_FOUND - SEConnDuplicate -> CONN DUPLICATE - SEBadConnType CRcv -> CONN SIMPLEX - SEBadConnType CSnd -> CONN SIMPLEX + SERatchetNotFound -> CONN NOT_FOUND "" + SEConnDuplicate -> CONN DUPLICATE "" + SEBadConnType cxt CRcv -> CONN SIMPLEX cxt + SEBadConnType cxt CSnd -> CONN SIMPLEX cxt SEInvitationNotFound cxt invId -> CMD PROHIBITED $ "SEInvitationNotFound " <> cxt <> ", invitationId = " <> show invId -- this error is never reported as store error, -- it is used to wrap agent operations when "transaction-like" store access is needed diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 98743b2fe..44662754e 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1837,7 +1837,7 @@ data AgentErrorType = -- | command or response error CMD {cmdErr :: CommandErrorType, errContext :: String} | -- | connection errors - CONN {connErr :: ConnectionErrorType} + CONN {connErr :: ConnectionErrorType, errContext :: String} | -- | user not found in database NO_USER | -- | SMP protocol errors forwarded to agent clients diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 1613cc190..4ae22213c 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -119,6 +119,10 @@ rcvQueueInfo :: RcvQueue -> RcvQueueInfo rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} = RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq} +rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress +rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} = + SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode + canAbortRcvSwitch :: RcvQueue -> Bool canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus where @@ -662,7 +666,7 @@ data StoreError SESndQueueExists | -- | Wrong connection type, e.g. "send" connection when "receive" or "duplex" is expected, or vice versa. -- 'upgradeRcvConnToDuplex' and 'upgradeSndConnToDuplex' do not allow duplex connections - they would also return this error. - SEBadConnType ConnType + SEBadConnType String ConnType | -- | Confirmation not found. SEConfirmationNotFound | -- | Invitation not found diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 137c320c8..c568de319 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -387,7 +387,7 @@ updateNewConnRcv db connId rq = getConn db connId $>>= \case (SomeConn _ NewConnection {}) -> updateConn (SomeConn _ RcvConnection {}) -> updateConn -- to allow retries - (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnRcv" $ connType c where updateConn :: IO (Either StoreError RcvQueue) updateConn = Right <$> addConnRcvQueue_ db connId rq @@ -396,7 +396,7 @@ updateNewConnSnd :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreEr updateNewConnSnd db connId sq = getConn db connId $>>= \case (SomeConn _ NewConnection {}) -> updateConn - (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + (SomeConn c _) -> pure . Left . SEBadConnType "updateNewConnSnd" $ connType c where updateConn :: IO (Either StoreError SndQueue) updateConn = Right <$> addConnSndQueue_ db connId sq @@ -472,14 +472,14 @@ upgradeRcvConnToDuplex :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either S upgradeRcvConnToDuplex db connId sq = getConn db connId $>>= \case (SomeConn _ RcvConnection {}) -> Right <$> addConnSndQueue_ db connId sq - (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + (SomeConn c _) -> pure . Left . SEBadConnType "upgradeRcvConnToDuplex" $ connType c -- TODO [certs rcv] store clientServiceId from NewRcvQueue upgradeSndConnToDuplex :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreError RcvQueue) upgradeSndConnToDuplex db connId rq = getConn db connId >>= \case Right (SomeConn _ SndConnection {}) -> Right <$> addConnRcvQueue_ db connId rq - Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + Right (SomeConn c _) -> pure . Left . SEBadConnType "upgradeSndConnToDuplex" $ connType c _ -> pure $ Left SEConnNotFound -- TODO [certs rcv] store clientServiceId from NewRcvQueue @@ -487,7 +487,7 @@ addConnRcvQueue :: DB.Connection -> ConnId -> NewRcvQueue -> IO (Either StoreErr addConnRcvQueue db connId rq = getConn db connId >>= \case Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnRcvQueue_ db connId rq - Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnRcvQueue" $ connType c _ -> pure $ Left SEConnNotFound addConnRcvQueue_ :: DB.Connection -> ConnId -> NewRcvQueue -> IO RcvQueue @@ -499,7 +499,7 @@ addConnSndQueue :: DB.Connection -> ConnId -> NewSndQueue -> IO (Either StoreErr addConnSndQueue db connId sq = getConn db connId >>= \case Right (SomeConn _ DuplexConnection {}) -> Right <$> addConnSndQueue_ db connId sq - Right (SomeConn c _) -> pure . Left . SEBadConnType $ connType c + Right (SomeConn c _) -> pure . Left . SEBadConnType "addConnSndQueue" $ connType c _ -> pure $ Left SEConnNotFound addConnSndQueue_ :: DB.Connection -> ConnId -> NewSndQueue -> IO SndQueue diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index e3daadfd9..7250a1d60 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -55,6 +55,7 @@ module Simplex.Messaging.Crypto.Ratchet supportedE2EEncryptVRange, generateRcvE2EParams, generateSndE2EParams, + mkRcvE2ERatchetParams, initialPQEncryption, connPQEncryption, joinContactInitialKeys, @@ -196,6 +197,8 @@ data ARKEMParams = forall s. RatchetKEMStateI s => ARKP (SRatchetKEMState s) (RK deriving instance Show ARKEMParams +type RcvRKEMParams = RKEMParams 'RKSProposed + instance RatchetKEMStateI s => Encoding (RKEMParams s) where smpEncode = \case RKParamsProposed k -> smpEncode ('P', k) @@ -406,6 +409,12 @@ data UseKEM (s :: RatchetKEMState) where data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s) +mkRcvE2ERatchetParams :: VersionE2E -> (PrivateKey a, PrivateKey a, Maybe RcvPrivRKEMParams) -> RcvE2ERatchetParams a +mkRcvE2ERatchetParams v (pk1, pk2, pKem) = E2ERatchetParams v (publicKey pk1) (publicKey pk2) (mkKem <$> pKem) + where + mkKem :: RcvPrivRKEMParams -> RcvRKEMParams + mkKem (PrivateRKParamsProposed (k, _)) = RKParamsProposed k + generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a) generateE2EParams g v useKEM_ = do (k1, pk1) <- atomically $ generateKeyPair g diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index e527323f9..6af1f585a 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -66,7 +66,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (isRight) import Data.Int (Int64) -import Data.List (find, nub) +import Data.List (find, isSuffixOf, nub) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map as M import Data.Maybe (isJust, isNothing) @@ -253,6 +253,12 @@ runRight action = Right x -> pure x Left e -> error $ "Unexpected error: " <> show e +runLeft :: (Show a, HasCallStack) => ExceptT e IO a -> IO e +runLeft action = + runExceptT action >>= \case + Right x -> error $ "unexpected result " <> show x + Left e -> pure e + getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission -> Bool] -> Expectation getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts @@ -331,6 +337,13 @@ functionalAPITests ps = do testAsyncServerOffline ps it "should restore confirmation after client restart" $ testAllowConnectionClientRestart ps + describe "Establishing connections with user retries" $ do + describe "Via invitation" $ do + it "should connect after errors" $ testInvitationErrors ps False + it "should connect after errors with client restarts" $ testInvitationErrors ps True + describe "Via contact" $ do + it "should connect after errors" $ testContactErrors ps False + it "should connect after errors with client restarts" $ testContactErrors ps True describe "Short connection links" $ do describe "should connect via 1-time short link" $ testProxyMatrix ps testInviationShortLink describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInviationShortLinkAsync @@ -971,7 +984,7 @@ testRejectContactRequest = (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice - liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND) + liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND "") rejectContact alice addrConnId invId liftIO $ noMessages bob "nothing delivered to bob" @@ -1134,6 +1147,161 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do disposeAgentClient alice2 disposeAgentClient bob +testInvitationErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO () +testInvitationErrors ps restart = do + a <- getAgentA + b <- getAgentB + (bId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMInvitation Nothing SMSubscribe + ("", "", DOWN _ [_]) <- nGet a + aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn + -- fails to secure the queue on testPort + BROKER srv NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + (testPort `isSuffixOf` srv) `shouldBe` True + withServer1 ps $ do + ("", "", UP _ [_]) <- nGet a + let loopSecure = do + -- secures the queue on testPort, but fails to create reply queue on testPort2 + BROKER srv2 NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + unless (testPort2 `isSuffixOf` srv2) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure + loopSecure + ("", "", DOWN _ [_]) <- nGet a + b' <- withServer2 ps $ do + threadDelay 200000 + let loopCreate = do + -- creates the reply queue on testPort2, but fails to send it to testPort + BROKER srv' NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate + loopCreate + restartAgentB restart b [aId] + ("", "", DOWN _ [_]) <- nGet b' + n <- withServer1 ps $ do + ("", "", UP _ [_]) <- nGet a + threadDelay 200000 + let loopConfirm n = + runExceptT (A.joinConnection b' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case + Right (True, Nothing) -> pure n + Right r -> error $ "unexpected result " <> show r + Left _ -> putStrLn "retrying confirm" >> threadDelay 200000 >> loopConfirm (n + 1) + n <- loopConfirm 1 + runRight $ do + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnectionAsync a "1" bId confId "alice's connInfo" + get a ##> ("1", bId, OK) + pure n + ("", "", DOWN _ [_]) <- nGet a + withServer2 ps $ do + get a ##> ("", bId, CON) -- note that server 1 is down, CON event is sent when HELLO is sent to server 2 + ("", "", UP _ [_]) <- nGet b' + get b' ##> ("", aId, INFO "alice's connInfo") + get b' ##> ("", aId, CON) + withServer1 ps $ do + ("", "", UP _ [_]) <- nGet a + runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn 2 (2 + n) a bId b' aId + disposeAgentClient a + disposeAgentClient b' + +restartAgentA :: Bool -> AgentClient -> [ConnId] -> IO AgentClient +restartAgentA = restartAgent_ getAgentA + +restartAgentB :: Bool -> AgentClient -> [ConnId] -> IO AgentClient +restartAgentB = restartAgent_ getAgentB + +restartAgent_ :: IO AgentClient -> Bool -> AgentClient -> [ConnId] -> IO AgentClient +restartAgent_ getAgent restart c cIds + | restart = do + disposeAgentClient c + threadDelay 200000 + c' <- getAgent + rs <- runRight $ subscribeConnections c' cIds + all isRight rs `shouldBe` True + pure c' + | otherwise = pure c + +testContactErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO () +testContactErrors ps restart = do + a <- getAgentA + b <- getAgentB + (contactId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMContact Nothing SMSubscribe + ("", "", DOWN _ [_]) <- nGet a + aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn + -- fails to create queue on testPort2 + BROKER srv2 NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + (testPort2 `isSuffixOf` srv2) `shouldBe` True + b' <- restartAgentB restart b [aId] + let loopCreate2 = do + -- creates the reply queue on testPort2, but fails to send invitation to testPort + BROKER srv' NETWORK <- runLeft $ A.joinConnection b' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create 2" >> threadDelay 200000 >> loopCreate2 + b'' <- withServer2 ps $ do + loopCreate2 + restartAgentB restart b' [aId] + ("", "", DOWN _ [_]) <- nGet b'' + invId <- withServer1 ps $ do + ("", "", UP _ [_]) <- nGet a + let loopSend = do + -- sends the invitation to testPort + runExceptT (A.joinConnection b'' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case + Right (False, Nothing) -> pure () + Right r -> error $ "unexpected result " <> show r + Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend + loopSend + ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get a + pure invId + ("", "", DOWN _ [_]) <- nGet a + bId <- runRight $ A.prepareConnectionToAccept a True invId PQSupportOn + withServer2 ps $ do + ("", "", UP _ [_]) <- nGet b'' + let loopSecure = do + -- secures the queue on testPort2, but fails to create reply queue on testPort + BROKER srv NETWORK <- runLeft $ acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + unless (testPort `isSuffixOf` srv) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure + loopSecure + ("", "", DOWN _ [_]) <- nGet b'' + a' <- withServer1 ps $ do + ("", "", UP _ [_]) <- nGet a + let loopCreate = do + -- creates the reply queue on testPort, but fails to send confirmation to testPort2 + BROKER srv2' NETWORK <- runLeft $ acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + unless (testPort2 `isSuffixOf` srv2') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate + loopCreate + restartAgentA restart a [contactId, bId] + ("", "", DOWN _ [_, _]) <- nGet a' -- the second connection is from accept + (n, confId) <- withServer2 ps $ do + ("", "", UP _ [_]) <- nGet b'' + let loopConfirm n = + runExceptT (acceptContact a' bId True invId "alice's connInfo" PQSupportOn SMSubscribe) >>= \case + Right (True, Nothing) -> pure n + Right r -> error $ "unexpected result " <> show r + Left _ -> putStrLn "retrying accept confirm" >> threadDelay 200000 >> loopConfirm (n + 1) + n <- loopConfirm 1 + ("", _, A.CONF confId PQSupportOn _ "alice's connInfo") <- get b'' + pure (n, confId) + ("", "", DOWN _ [_]) <- nGet b'' + runRight_ $ allowConnection b'' aId confId "bob's connInfo" + withServer1 ps $ do + ("", "", UP _ [_, _]) <- nGet a' + get a' ##> ("", bId, A.INFO PQSupportOn "bob's connInfo") + get a' ##> ("", bId, A.CON PQEncOn) + get b'' ##> ("", aId, A.CON PQEncOn) -- note that server 2 is down, this event is delivered when HELLO is sent to server 1 + a'' <- restartAgentA restart a' [contactId, bId] + withServer2 ps $ do + ("", "", UP _ [_]) <- nGet b'' + runRight_ $ exchangeGreetingsViaProxyMsgId_ False PQEncOn (2 + n) 2 a'' bId b'' aId + disposeAgentClient a'' + disposeAgentClient b'' + +getAgentA :: IO AgentClient +getAgentA = getSMPAgentClient' 1 agentCfg initAgentServers testDB + +getAgentB :: IO AgentClient +getAgentB = getSMPAgentClient' 2 agentCfg (initAgentServers {smp = userServers [testSMPServer2]}) testDB2 + +withServer1 :: (ASrvTransport, AStoreType) -> IO a -> IO a +withServer1 ps = withSmpServerStoreLogOn ps testPort . const + +withServer2 :: (ASrvTransport, AStoreType) -> IO a -> IO a +withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 . const + testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testInviationShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do @@ -2235,7 +2403,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = liftIO $ do let dc = S.fromList $ take nDel cs all isRight (M.withoutKeys r dc) `shouldBe` True - all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True + all (== Left (CONN NOT_FOUND "")) (M.restrictKeys r dc) `shouldBe` True M.keys r `shouldMatchList` cs delete :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO () delete c cs = do @@ -2247,7 +2415,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = deleteFail c cs = do r <- deleteConnections c cs liftIO $ do - all (== Left (CONN NOT_FOUND)) r `shouldBe` True + all (== Left (CONN NOT_FOUND "")) r `shouldBe` True M.keys r `shouldMatchList` cs runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do @@ -3651,24 +3819,29 @@ exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> Agen exchangeGreetingsMsgId = exchangeGreetingsMsgId_ PQEncOn exchangeGreetingsMsgId_ :: HasCallStack => PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () -exchangeGreetingsMsgId_ = exchangeGreetingsViaProxyMsgId_ False +exchangeGreetingsMsgId_ pqEnc msgId = exchangeGreetingsViaProxyMsgId_ False pqEnc msgId msgId exchangeGreetingsViaProxy :: HasCallStack => Bool -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () -exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2 +exchangeGreetingsViaProxy viaProxy = exchangeGreetingsViaProxyMsgId_ viaProxy PQEncOn 2 2 -exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () -exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc msgId alice bobId bob aliceId = do +exchangeGreetingsViaProxyMsgId_ :: HasCallStack => Bool -> PQEncryption -> Int64 -> Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () +exchangeGreetingsViaProxyMsgId_ viaProxy pqEnc aMsgId bMsgId alice bobId bob aliceId = do msgId1 <- A.sendMessage alice bobId pqEnc SMP.noMsgFlags "hello" - liftIO $ msgId1 `shouldBe` (msgId, pqEnc) - get alice =##> \case ("", c, A.SENT mId srv_) -> c == bobId && mId == msgId && viaProxy == isJust srv_; _ -> False - get bob =##> \case ("", c, Msg' mId pq "hello") -> c == aliceId && mId == msgId && pq == pqEnc; _ -> False - ackMessage bob aliceId msgId Nothing + liftIO $ msgId1 `shouldBe` (aMsgId, pqEnc) + get alice =##> \case ("", c, A.SENT mId srv_) -> c == bobId && mId == aMsgId && viaProxy == isJust srv_; _ -> False + if aMsgId <= bMsgId + then get bob =##> \case ("", c, Msg' mId pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False + else get bob =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello") -> c == aliceId && mId == bMsgId && pq == pqEnc; _ -> False + ackMessage bob aliceId bMsgId Nothing msgId2 <- A.sendMessage bob aliceId pqEnc SMP.noMsgFlags "hello too" - let msgId' = msgId + 1 - liftIO $ msgId2 `shouldBe` (msgId', pqEnc) - get bob =##> \case ("", c, A.SENT mId srv_) -> c == aliceId && mId == msgId' && viaProxy == isJust srv_; _ -> False - get alice =##> \case ("", c, Msg' mId pq "hello too") -> c == bobId && mId == msgId' && pq == pqEnc; _ -> False - ackMessage alice bobId msgId' Nothing + let aMsgId' = aMsgId + 1 + bMsgId' = bMsgId + 1 + liftIO $ msgId2 `shouldBe` (bMsgId', pqEnc) + get bob =##> \case ("", c, A.SENT mId srv_) -> c == aliceId && mId == bMsgId' && viaProxy == isJust srv_; _ -> False + if aMsgId >= bMsgId + then get alice =##> \case ("", c, Msg' mId pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False + else get alice =##> \case ("", c, MsgErr' mId (MsgSkipped 2 _) pq "hello too") -> c == bobId && mId == aMsgId' && pq == pqEnc; _ -> False + ackMessage alice bobId aMsgId' Nothing exchangeGreetingsMsgIds :: HasCallStack => AgentClient -> ConnId -> Int64 -> AgentClient -> ConnId -> Int64 -> ExceptT AgentErrorType IO () exchangeGreetingsMsgIds alice bobId aliceMsgId bob aliceId bobMsgId = do diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 44b58a7f8..056dc5dd3 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -421,10 +421,10 @@ testUpgradeRcvConnToDuplex = smpClientVersion = VersionSMPC 1 } upgradeRcvConnToDuplex db "conn1" anotherSndQueue - `shouldReturn` Left (SEBadConnType CSnd) + `shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CSnd) _ <- upgradeSndConnToDuplex db "conn1" rcvQueue1 upgradeRcvConnToDuplex db "conn1" anotherSndQueue - `shouldReturn` Left (SEBadConnType CDuplex) + `shouldReturn` Left (SEBadConnType "upgradeRcvConnToDuplex" CDuplex) testUpgradeSndConnToDuplex :: SpecWith DBStore testUpgradeSndConnToDuplex = @@ -455,10 +455,10 @@ testUpgradeSndConnToDuplex = deleteErrors = 0 } upgradeSndConnToDuplex db "conn1" anotherRcvQueue - `shouldReturn` Left (SEBadConnType CRcv) + `shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CRcv) _ <- upgradeRcvConnToDuplex db "conn1" sndQueue1 upgradeSndConnToDuplex db "conn1" anotherRcvQueue - `shouldReturn` Left (SEBadConnType CDuplex) + `shouldReturn` Left (SEBadConnType "upgradeSndConnToDuplex" CDuplex) testSetRcvQueueStatus :: SpecWith DBStore testSetRcvQueueStatus = From a46edd60f0e2460ec4a7d6fb371412f32e988357 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 30 Jun 2025 21:50:21 +0100 Subject: [PATCH 09/22] 6.4.0.11 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 67cd1657d..497b2b981 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.4.0.10.1 +version: 6.4.0.11 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From c5eb66038bb9268671a353638606f6d0bd1de761 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Thu, 3 Jul 2025 09:29:39 +0000 Subject: [PATCH 10/22] agent: allow to accept contact requests after address is deleted (#1580) --- simplexmq.cabal | 4 +- src/Simplex/Messaging/Agent.hs | 65 ++++++++----------- src/Simplex/Messaging/Agent/Store.hs | 2 +- .../Messaging/Agent/Store/AgentStore.hs | 15 ++--- .../Agent/Store/Postgres/Migrations/App.hs | 4 +- ..._conn_invitations_remove_cascade_delete.hs | 37 +++++++++++ .../Agent/Store/SQLite/Migrations/App.hs | 4 +- .../Migrations/M20250517_service_certs.hs | 1 + ..._conn_invitations_remove_cascade_delete.hs | 38 +++++++++++ .../Store/SQLite/Migrations/agent_schema.sql | 2 +- tests/AgentTests/FunctionalAPITests.hs | 31 +++++---- 11 files changed, 136 insertions(+), 67 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 497b2b981..fe8c91e90 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -162,6 +162,7 @@ library Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete else exposed-modules: Simplex.Messaging.Agent.Store.SQLite @@ -208,6 +209,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete if !flag(client_library) exposed-modules: Simplex.FileTransfer.Client.Main @@ -559,7 +561,7 @@ test-suite simplexmq-test build-depends: memory , sqlcipher-simple - if !flag(client_postgres) || flag(server_postgres) + if !flag(client_postgres) || flag(client_postgres) || flag(server_postgres) build-depends: deepseq ==1.4.* , process diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index dffe27389..b0c5526e6 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -343,8 +343,8 @@ allowConnectionAsync c = withAgentEnv c .:: allowConnectionAsync' c {-# INLINE allowConnectionAsync #-} -- | Accept contact after REQ notification (ACPT command) asynchronously, synchronous response is new connection id -acceptContactAsync :: AgentClient -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId -acceptContactAsync c aCorrId enableNtfs = withAgentEnv c .:: acceptContactAsync' c aCorrId enableNtfs +acceptContactAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId +acceptContactAsync c userId aCorrId enableNtfs = withAgentEnv c .:: acceptContactAsync' c userId aCorrId enableNtfs {-# INLINE acceptContactAsync #-} -- | Acknowledge message (ACK command) asynchronously, no synchronous response @@ -406,8 +406,8 @@ prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c {-# INLINE prepareConnectionToJoin #-} -- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID). -prepareConnectionToAccept :: AgentClient -> Bool -> ConfirmationId -> PQSupport -> AE ConnId -prepareConnectionToAccept c enableNtfs = withAgentEnv c .: newConnToAccept c "" enableNtfs +prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> ConfirmationId -> PQSupport -> AE ConnId +prepareConnectionToAccept c userId enableNtfs = withAgentEnv c .: newConnToAccept c userId "" enableNtfs {-# INLINE prepareConnectionToAccept #-} -- | Join SMP agent connection (JOIN command). @@ -421,13 +421,13 @@ allowConnection c = withAgentEnv c .:. allowConnection' c {-# INLINE allowConnection #-} -- | Accept contact after REQ notification (ACPT command) -acceptContact :: AgentClient -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId) -acceptContact c connId enableNtfs = withAgentEnv c .:: acceptContact' c connId enableNtfs +acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId) +acceptContact c userId connId enableNtfs = withAgentEnv c .:: acceptContact' c userId connId enableNtfs {-# INLINE acceptContact #-} -- | Reject contact (RJCT command) -rejectContact :: AgentClient -> ConnId -> ConfirmationId -> AE () -rejectContact c = withAgentEnv c .: rejectContact' c +rejectContact :: AgentClient -> ConfirmationId -> AE () +rejectContact c = withAgentEnv c . rejectContact' c {-# INLINE rejectContact #-} -- | Subscribe to receive connection messages (SUB command) @@ -770,16 +770,13 @@ allowConnectionAsync' c corrId connId confId ownConnInfo = -- and also it can't be triggered by user concurrently several times in a row. It could be improved similarly to -- `acceptContact` by creating a new map for invitation locks and taking lock here, and removing `unacceptInvitation` -- while marking invitation as accepted inside "lock level transaction" after successful `joinConnAsync`. -acceptContactAsync' :: AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId -acceptContactAsync' c corrId enableNtfs invId ownConnInfo pqSupport subMode = do - Invitation {contactConnId, connReq} <- withStore c $ \db -> getInvitation db "acceptContactAsync'" invId - withStore c (`getConn` contactConnId) >>= \case - SomeConn _ (ContactConnection ConnData {userId} _) -> do - withStore' c $ \db -> acceptInvitation db invId ownConnInfo - joinConnAsync c userId corrId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do - withStore' c (`unacceptInvitation` invId) - throwE err - _ -> throwE $ CMD PROHIBITED "acceptContactAsync" +acceptContactAsync' :: AgentClient -> UserId -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId +acceptContactAsync' c userId corrId enableNtfs invId ownConnInfo pqSupport subMode = do + Invitation {connReq} <- withStore c $ \db -> getInvitation db "acceptContactAsync'" invId + withStore' c $ \db -> acceptInvitation db invId ownConnInfo + joinConnAsync c userId corrId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do + withStore' c (`unacceptInvitation` invId) + throwE err ackMessageAsync' :: AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AM () ackMessageAsync' c corrId connId msgId rcptInfo_ = do @@ -1036,13 +1033,10 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} withStore c $ \db -> createNewConn db g cData SCMInvitation -newConnToAccept :: AgentClient -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId -newConnToAccept c connId enableNtfs invId pqSup = do - Invitation {connReq, contactConnId} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId - withStore c (`getConn` contactConnId) >>= \case - SomeConn _ (ContactConnection ConnData {userId} _) -> - newConnToJoin c userId connId enableNtfs connReq pqSup - _ -> throwE $ CMD PROHIBITED "newConnToAccept" +newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId +newConnToAccept c userId connId enableNtfs invId pqSup = do + Invitation {connReq} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId + newConnToJoin c userId connId enableNtfs connReq pqSup joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do @@ -1220,20 +1214,17 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne _ -> throwE $ CMD PROHIBITED "allowConnection" -- | Accept contact (ACPT command) in Reader monad -acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) -acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do - Invitation {contactConnId, connReq} <- withStore c $ \db -> getInvitation db "acceptContact'" invId - withStore c (`getConn` contactConnId) >>= \case - SomeConn _ (ContactConnection ConnData {userId} _) -> do - r <- joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode - withStore' c $ \db -> acceptInvitation db invId ownConnInfo - pure r - _ -> throwE $ CMD PROHIBITED "acceptContact" +acceptContact' :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) +acceptContact' c userId connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do + Invitation {connReq} <- withStore c $ \db -> getInvitation db "acceptContact'" invId + r <- joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode + withStore' c $ \db -> acceptInvitation db invId ownConnInfo + pure r -- | Reject contact (RJCT command) in Reader monad -rejectContact' :: AgentClient -> ConnId -> InvitationId -> AM () -rejectContact' c contactConnId invId = - withStore c $ \db -> deleteInvitation db contactConnId invId +rejectContact' :: AgentClient -> InvitationId -> AM () +rejectContact' c invId = + withStore' c $ \db -> deleteInvitation db invId {-# INLINE rejectContact' #-} -- | Subscribe to receive connection messages (SUB command) in Reader monad diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 4ae22213c..faedce6bb 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -515,7 +515,7 @@ data NewInvitation = NewInvitation data Invitation = Invitation { invitationId :: InvitationId, - contactConnId :: ConnId, + contactConnId_ :: Maybe ConnId, connReq :: ConnectionRequestUri 'CMInvitation, recipientConnInfo :: ConnInfo, ownConnInfo :: Maybe ConnInfo, diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index c568de319..09b76671b 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -728,7 +728,7 @@ createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInf db [sql| INSERT INTO conn_invitations - (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0); + (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0); |] (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo) @@ -745,8 +745,8 @@ getInvitation db cxt invitationId = |] (Only (Binary invitationId)) where - invitation (contactConnId, connReq, recipientConnInfo, ownConnInfo, BI accepted) = - Invitation {invitationId, contactConnId, connReq, recipientConnInfo, ownConnInfo, accepted} + invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted) = + Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted} acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO () acceptInvitation db invitationId ownConnInfo = @@ -764,12 +764,9 @@ unacceptInvitation :: DB.Connection -> InvitationId -> IO () unacceptInvitation db invitationId = DB.execute db "UPDATE conn_invitations SET accepted = 0, own_conn_info = NULL WHERE invitation_id = ?" (Only (Binary invitationId)) -deleteInvitation :: DB.Connection -> ConnId -> InvitationId -> IO (Either StoreError ()) -deleteInvitation db contactConnId invId = - getConn db contactConnId $>>= \case - SomeConn SCContact _ -> - Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId) - _ -> pure $ Left SEConnNotFound +deleteInvitation :: DB.Connection -> InvitationId -> IO () +deleteInvitation db invId = + DB.execute db "DELETE FROM conn_invitations WHERE invitation_id = ?" (Only (Binary invId)) getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink) getInvShortLink db server linkId = diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs index e6e6efaf8..565a06760 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs @@ -7,13 +7,15 @@ import Data.Text (Text) import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = [ ("20241210_initial", m20241210_initial, Nothing), ("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies), - ("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links) + ("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links), + ("20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs new file mode 100644 index 000000000..a61a60d5d --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250702_conn_invitations_remove_cascade_delete where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.RawString.QQ (r) + +m20250702_conn_invitations_remove_cascade_delete :: Text +m20250702_conn_invitations_remove_cascade_delete = + T.pack + [r| +ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey; + +ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id DROP NOT NULL; + +ALTER TABLE conn_invitations + ADD CONSTRAINT conn_invitations_contact_conn_id_fkey + FOREIGN KEY (contact_conn_id) + REFERENCES connections(conn_id) + ON DELETE SET NULL; +|] + +down_m20250702_conn_invitations_remove_cascade_delete :: Text +down_m20250702_conn_invitations_remove_cascade_delete = + T.pack + [r| +ALTER TABLE conn_invitations DROP CONSTRAINT conn_invitations_contact_conn_id_fkey; + +ALTER TABLE conn_invitations ALTER COLUMN contact_conn_id SET NOT NULL; + +ALTER TABLE conn_invitations + ADD CONSTRAINT conn_invitations_contact_conn_id_fkey + FOREIGN KEY (contact_conn_id) + REFERENCES connections(conn_id) + ON DELETE CASCADE; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs index eea7db3ca..9d5d65ea7 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs @@ -43,6 +43,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -85,7 +86,8 @@ schemaMigrations = ("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts), ("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params), ("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies), - ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links) + ("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links), + ("m20250702_conn_invitations_remove_cascade_delete", m20250702_conn_invitations_remove_cascade_delete, Just down_m20250702_conn_invitations_remove_cascade_delete) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250517_service_certs.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250517_service_certs.hs index 48f847091..7708fd6d2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250517_service_certs.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250517_service_certs.hs @@ -5,6 +5,7 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250517_service_certs w import Database.SQLite.Simple (Query) import Database.SQLite.Simple.QQ (sql) +-- TODO move date forward, create migration for postgres m20250517_service_certs :: Query m20250517_service_certs = [sql| diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs new file mode 100644 index 000000000..9abccb476 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250702_conn_invitations_remove_cascade_delete.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20250702_conn_invitations_remove_cascade_delete :: Query +m20250702_conn_invitations_remove_cascade_delete = + [sql| +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace( + sql, + 'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE', + 'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL' + ) +WHERE name = 'conn_invitations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] + +down_m20250702_conn_invitations_remove_cascade_delete :: Query +down_m20250702_conn_invitations_remove_cascade_delete = + [sql| +PRAGMA writable_schema=1; + +UPDATE sqlite_master +SET sql = replace( + sql, + 'contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL', + 'contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE' + ) +WHERE name = 'conn_invitations' AND type = 'table'; + +PRAGMA writable_schema=0; +|] 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 fde671d7a..ad39937cd 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -154,7 +154,7 @@ CREATE TABLE conn_confirmations( ) WITHOUT ROWID; CREATE TABLE conn_invitations( invitation_id BLOB NOT NULL PRIMARY KEY, - contact_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, + contact_conn_id BLOB REFERENCES connections ON DELETE SET NULL, cr_invitation BLOB NOT NULL, recipient_conn_info BLOB NOT NULL, accepted INTEGER NOT NULL DEFAULT 0, diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 6af1f585a..445d087cb 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -888,8 +888,8 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` reqPQSupport - bobId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ) - (sqSecured', Nothing) <- acceptContact alice bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe + bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ) + (sqSecured', Nothing) <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe liftIO $ sqSecured' `shouldBe` sqSecured ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob liftIO $ pqSup'' `shouldBe` bPQ @@ -939,8 +939,8 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn - bId <- A.prepareConnectionToAccept alice True invId (CR.connPQEncryption aPQ) - (sqSecuredAccept, Nothing) <- acceptContact alice bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe + bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ) + (sqSecuredAccept, Nothing) <- acceptContact alice 1 bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe liftIO $ sqSecuredAccept `shouldBe` False -- agent cfg is v8 ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b liftIO $ pqSup'' `shouldBe` pq @@ -979,13 +979,12 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () testRejectContactRequest :: HasCallStack => IO () testRejectContactRequest = withAgentClients2 $ \alice bob -> runRight_ $ do - (addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe + (_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice - liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND "") - rejectContact alice addrConnId invId + rejectContact alice invId liftIO $ noMessages bob "nothing delivered to bob" testUpdateConnectionUserId :: HasCallStack => IO () @@ -1248,12 +1247,12 @@ testContactErrors ps restart = do ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get a pure invId ("", "", DOWN _ [_]) <- nGet a - bId <- runRight $ A.prepareConnectionToAccept a True invId PQSupportOn + bId <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn withServer2 ps $ do ("", "", UP _ [_]) <- nGet b'' let loopSecure = do -- secures the queue on testPort2, but fails to create reply queue on testPort - BROKER srv NETWORK <- runLeft $ acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + BROKER srv NETWORK <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe unless (testPort `isSuffixOf` srv) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure loopSecure ("", "", DOWN _ [_]) <- nGet b'' @@ -1261,7 +1260,7 @@ testContactErrors ps restart = do ("", "", UP _ [_]) <- nGet a let loopCreate = do -- creates the reply queue on testPort, but fails to send confirmation to testPort2 - BROKER srv2' NETWORK <- runLeft $ acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + BROKER srv2' NETWORK <- runLeft $ acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe unless (testPort2 `isSuffixOf` srv2') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate loopCreate restartAgentA restart a [contactId, bId] @@ -1269,7 +1268,7 @@ testContactErrors ps restart = do (n, confId) <- withServer2 ps $ do ("", "", UP _ [_]) <- nGet b'' let loopConfirm n = - runExceptT (acceptContact a' bId True invId "alice's connInfo" PQSupportOn SMSubscribe) >>= \case + runExceptT (acceptContact a' 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe) >>= \case Right (True, Nothing) -> pure n Right r -> error $ "unexpected result " <> show r Left _ -> putStrLn "retrying accept confirm" >> threadDelay 200000 >> loopConfirm (n + 1) @@ -1384,8 +1383,8 @@ testContactShortLink viaProxy a b = (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe liftIO $ sndSecure `shouldBe` False ("", _, REQ invId _ "bob's connInfo") <- get a - bId <- A.prepareConnectionToAccept a True invId PQSupportOn - (sndSecure', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn + (sndSecure', Nothing) <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe liftIO $ sndSecure' `shouldBe` True ("", _, CONF confId _ "alice's connInfo") <- get b allowConnection b aId confId "bob's connInfo" @@ -1431,8 +1430,8 @@ testAddContactShortLink viaProxy a b = (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe liftIO $ sndSecure `shouldBe` False ("", _, REQ invId _ "bob's connInfo") <- get a - bId <- A.prepareConnectionToAccept a True invId PQSupportOn - (sndSecure', Nothing) <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn + (sndSecure', Nothing) <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe liftIO $ sndSecure' `shouldBe` True ("", _, CONF confId _ "alice's connInfo") <- get b allowConnection b aId confId "bob's connInfo" @@ -2573,7 +2572,7 @@ testAcceptContactAsync sqSecured alice bob baseId = (aliceId, sqSecuredJoin) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection ("", _, REQ invId _ "bob's connInfo") <- get alice - bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" PQSupportOn SMSubscribe + bobId <- acceptContactAsync alice 1 "1" True invId "alice's connInfo" PQSupportOn SMSubscribe get alice =##> \case ("1", c, JOINED sqSecured') -> c == bobId && sqSecured' == sqSecured; _ -> False ("", _, CONF confId _ "alice's connInfo") <- get bob allowConnection bob aliceId confId "bob's connInfo" From bfa52c4ba503bfaac29e5b03f71fbaf7a30e4c49 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 3 Jul 2025 18:09:02 +0100 Subject: [PATCH 11/22] docs: update RFC for short links to match the implementation (#1581) --- rfcs/2025-03-16-smp-queues.md | 202 ++++++++++++++++------------------ 1 file changed, 94 insertions(+), 108 deletions(-) diff --git a/rfcs/2025-03-16-smp-queues.md b/rfcs/2025-03-16-smp-queues.md index 5b46b383b..d79e6f419 100644 --- a/rfcs/2025-03-16-smp-queues.md +++ b/rfcs/2025-03-16-smp-queues.md @@ -5,22 +5,19 @@ This change is related to these problems: - differentiating queue retention time, - supporting MITM-resistant short connection links, -- improving notifications. This RFC is based on the previous discussions about short links, blob storage and notifications ([1](./2024-06-21-short-links.md), [2](./2024-09-09-smp-blobs.md), [3](./2024-11-25-queue-blobs-2.md), [4](./2024-09-25-ios-notifications-2.md)). -SMP protocol supports two types of queues - queues to communicate over and queues to send invitations. While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent. +SMP protocol supports two types of queues - queues to send messages (messaging queues) and queues to send invitations to connect (contact queues). While SMP protocol was originally "unaware" of these queue types, it could differentiate it by message flow, and with the recent addition of SKEY command to allow securing the queue by the sender this difference became persistent. Simply designating queue types would allow to use this information to decide for how long to retain queues, and potentially extending it: - unsecured 1-time invitation queues with sndSecure (support of securing by sender) - e.g., 3 months. - contact address queues without sndSecure - e.g., 3 years without activity. -- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and superpeer addresses for the group. - -This proposal also combines NEW and NKEY command to streamline notifications in preparation to reworking of the notifications protocol. +- Possibly, "queues" that prohibit messages and used only as blob storage - they would be used to store group profiles and super-peer addresses for the group. ## Design objectives -We want to achieve these objectives: +We want to achieve these objectives for short links and associated queue data: 1. no possibility to provide incorrect SenderId inside link data (e.g. from another queue). 2. link data cannot be accessed by the server unless it has the link. 3. prevent MITM attack by the server, including the server that obtained the link. @@ -28,17 +25,17 @@ We want to achieve these objectives: 5. for one-time links, prevent accessing link data by link observers who did not compromise the server. 6. allow changing the user-defined part of link data. 7. avoid changing the link when user-defined part of link data changes, while preventing MITM attack by the server on user-defined part, even if it has the link. -8. retain the quality that it is impossible to check the existense of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs). +8. retain the quality that it is impossible to check the existence of secured queue from having any of its temporary visible IDs (sender ID and link ID in 1-time invitations) - it requires that these IDs remain server-generated (contrary to the previous RFCs). -To achieve these objectives the queue data must have immutable part and mutable part. +To achieve these objectives the queue data will include fixed (immutable) and user-defined (mutable) parts. -Immutable part would include: -- full conection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response. +Fixed part would include: +- full connection request (the current long link with all keys, including PQ keys). This includes SenderId that must match server response. - public signature key to verify mutable part of link data. -Signed mutable part would inlcude: -- any links to chat relays that should be contacted instead of this queue (not in this RFC), but would allow delegating group connections and contact request connections to prevent spam, hiding online presense, etc. -- and user-defined data - user profile or group profile. +Signed mutable part would include: +- any links to chat relays that should be contacted instead of this queue (not in this RFC), to allow delegating group connections and contact request connections to prevent spam, hiding online presence, etc. +- and user-defined data - user profile or group profile, chat preferences, welcome message, etc. The link itself should include both the key and auth tag from the encryption of immutable part. Accessing one-time link data should require providing sender key and signing the command (`LKEY`). @@ -49,8 +46,6 @@ Current NEW and NKEY commands: ```haskell NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient -NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient - -- | Queue IDs and keys, returned in IDS response data QueueIdsKeys = QIK { rcvId :: RecipientId, @@ -70,43 +65,48 @@ data NewQueueReq = NewQueueReq rcvDhKey :: RcvPublicDhKey, auth_ :: Maybe BasicAuth, subMode :: SubscriptionMode, - queueData :: Maybe QueueReqData, - ntfCreds :: Maybe NewNtfCreds + queueReqData :: Maybe QueueReqData, } --- Replaces NKEY command --- This avoids additional command required from the client to enable notifications. --- Further changes would move NotifierId generation to the client, and including a signed and encrypted command to be forwarded by SMP server to notification server. -data NtfRequest = NtfRequest NtfPublicAuthKey RcvNtfPublicDhKey - -- QRMessaging implies that sender can secure the queue. -- LinkId is not used with QRMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used. -- LinkId is required with QRContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists. -data QueueReqData = QRMessaging (Maybe QueueLinkData) | QRContact (Maybe (LinkId, QueueLinkData)) +data QueueReqData + = QRMessaging (Maybe (SenderId, QueueLinkData)) + | QRContact (Maybe (LinkId, (SenderId, QueueLinkData))) -- SenderId should be computed client-side as the first 24 bytes of sha3-384(correlation_id), -- The server must verify it and reject if it is not. -type QueueLinkData = (SenderId, EncImmutableDataBytes, EncUserDataBytes) +-- It allows to include sender ID inside encrypted associated link data as part of full connection URI without requesting it from the server, but prevents checking if a given sender ID exists (queue creation would fail for a duplicate sender ID), as sha3-384 derivation is not reversible. +type QueueLinkData = (EncFixedLinkData, EncUserDataBytes) -type EncImmutableDataBytes = ByteString +type EncFixedLinkData = ByteString type EncUserDataBytes = ByteString --- We need to use binary encoding for AConnectionRequestUri to reduce its size --- connReq including the full link allows connection redundancy. --- The clients would reject changed immutable data (based on auth tag in the link) and --- AConnectionRequestUri where SenderId of the queue does not match. -data ImmutableLinkData = ImmutableLinkData - { signature :: SignatureEd25519, -- signature of the remaining part of immutable data - connReq :: AConnectionRequestUri, - sigKey :: PublicKeyEd25519 +-- We need to use binary encoding for ConnectionRequestUri to reduce its size +-- The clients would reject changed immutable data and +-- ConnectionRequestUri where server or SenderId of the queue do not match. +data FixedLinkData c = FixedLinkData + { agentVRange :: VersionRangeSMPA, + rootKey :: C.PublicKeyEd25519, + connReq :: ConnectionRequestUri c } --- This part of link data can also include any relays, but possibly we need a separate blob for it -data UserLinkData = UserLinkData - { signature :: SignatureEd25519, -- signs the remaining part of the data - userData :: ByteString -- the max size needs to be estimated, but it is likely to be ~ 14kb - } +data ConnLinkData c where + InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation + ContactLinkData :: + { agentVRange :: VersionRangeSMPA, + -- direct connection via connReq in fixed data is allowed. + direct :: Bool, + -- additional owner keys to sign changes of mutable data. + owners :: [OwnerAuth], + -- alternative addresses of chat relays that receive requests for this contact address. + relays :: [ConnShortLink 'CMContact], + userData :: UserLinkData + } -> ConnLinkData 'CMContact + +newtype UserLinkData = UserLinkData ByteString -- | Updated queue IDs and keys, returned in IDS response data QueueIdsKeys = QIK @@ -114,17 +114,14 @@ data QueueIdsKeys = QIK sndId :: SenderId, -- server-generated rcvPublicDhKey :: RcvPublicDhKey, sndSecure :: SenderCanSecure, -- possibly, can be removed? or implied? - linkId :: Maybe LinkId, -- server-generated - serverNtfCreds :: Maybe ServerNtfCreds -- currently returned in NID response + linkId :: Maybe LinkId -- server-generated } - -data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey -- NotifierId is server-generated. ``` -In addition to that we add the command allowing to update and also to retrieve and, optionally, secure the queue and get link data in one request, to have only one request: +In addition to that we add the command allowing to update and also to retrieve and secure the queue and get link data in one request, to have only one request: ```haskell --- This command allows to set all data or to update mutlable part of contact address queue. +-- This command allows to set all data or to update mutable part of contact address queue. -- This command should fail on queues that support sndSecure and also on new queues created with QRMessaging. -- This should fail if LinkId or immutable part of data is changed with the update, but will succeed if only mutable part is updated, so it can be retried. -- Entity ID is RecipientId. @@ -147,58 +144,43 @@ LKEY :: SndPublicAuthKey -> Command Sender -- Entity ID is LinkId LGET :: Command Sender --- Response to LGET, LSKEY and LSGET +-- Response to LGET and LSET -- Entity ID is the same as in the command LNK :: SenderId -> QueueLinkData -> BrokerMsg ``` -To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existense, it is proposed that `sender_id` is computed client-side as the first 24 bytes of 48 in `sha3-384(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID. +To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existence, it is proposed that `sender_id` is computed client-side as the first 24 bytes of 48 in `sha3-384(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID. -To allow retries and to avoid regenerating all queue data, NEW command must be idempotent, and `correlation_id` must be preserved in command for queue creation, so that the same `correlation_id` and all other data is used in retries. `correlation_id` should be removed after queue creation success. +To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` (and for contact queue, also `link_id`, which would be random as it is derived from hash of fixed link data that includes a random signature key) should be used on each attempt, because other IDs would be generated randomly on the server, and in case the previous command succeeded on the server but failed to be communicated to the client, the retry will fail if the same ID is used. -To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` / `link_id` should be used on each attempt, because other IDs would be generated randomly on the server, and in case the previous command succeeded on the server but failed to be communicated to the client, the retry will fail if the same ID is used. - -Alternative solutions considered and rejected: +Alternative solutions that would allow retries that were considered and rejected: - additional request to save queue data, after `sender_id` is returned by the server. The scenarios that require short links are interactive - creating user addresses and 1-time invitations - so making two requests instead of one would make the UX worse. - include empty sender_id in the immutable data and have it replaced by the accepting party with `sender_id` received in `LINK` response - both a weird design, and might create possibility for some attacks via server, especially for contact addresses. - making NEW commands idempotent. Doing it would require generating all IDs client-side, not only `sender_id`. It increases complexity, and it is not really necessary as the only scenarios when retries are needed are async NEW commands, that do not require short links. For future short links of chat relays the retries are much less likely, as chat relays will have good network connections. ## Algorithm to prepare and to interpret queue link data. -For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existense checks. +For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existence checks (oracle attack). -**Prepare queue link data** +This scheme results in 32 byte binary size for contact addresses and 56 bytes for 1-time invitation links. -- the queue owner generates a random 256 bit `link_key` that will be used in the link URI. -- for 1-time links: crypto_box key and 2 nonces to encrypt link data are derived from link_uri using HKDF: `cb_key <> nonce1 <> nonce2 = HKDF(link_key, 80 bytes)` (nonce1 is used for immutable and nonce2 for user-defined parts). -- for contact address links: key and 2 nonces and linkId will be derived: `link_id <> cb_key <> nonce1 <> nonce2 = HKDF(link_key, 104 bytes)` -- both parts of link data are encrypted with crypto_box, and included into `NEW` or `LNEW` commands. +For fixed link data. -**Retrieving queue link data** - -- the sender uses `LinkId` from URI (or derived from URI) as entity ID to retrieve link data. -- for one time links the sender must authorize the request to retrieve the data, the key is provided with the first request, preventing undetected access by link observers. -- having received the link data, the client can now decrypt it using secret_box. - -## Improved algorithm to prepare and to interpret queue link data. - -This scheme reduces the size of the binary in the link from 48 bytes (72 in case of 1-time links) to 32 bytes (56 bytes for 1-time links). - -For immutable data. - -1. `link_key = SHA3-256(immutable_data)` - used as part of link, and to encrypt content. -2. HKDF: +1. Generate random `nonce` (also used as a correlation ID for server command) and signature key (public `rootKey` included in fixed data). +2. Compute sender ID from `nonce` as the first 24 bytes of sha3-384 of `nonce`. +3. Generate other keys for queue address, including queue e2e encryption keys and double ratchet connection e2e encryption keys. +4. Construct the full connection address to be included in fixed data. +5. `link_key = SHA3-256(fixed_data)` - used as part of the link, and to derive the key to encrypt content. +6. HKDF: 1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`. - 2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated. -3. -3. Random `nonce1` (for immutable data), to be stored with the link data. -4. Encrypt: `(ct1, tag1) = secret_box(immutable_data, key, nonce1)`. -5. Store: `(nonce1, ct1, tag1)` stored as immutable link data. + 2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated. +7. Encrypt: `(ct1, tag1) = secret_box(fixed_data, key, nonce1)`, where `nonce1` is a random nonce +5. Store: `(nonce1, ct1, tag1)` stored as fixed link data. For mutable user data: 1. Random `nonce2` and the same key are used. -2. Sign `user_data` with key included in `immutable_data`. +2. Sign `user_data` with key included in `fixed_data`. 3. Encrypt: `(ct2, tag2) = secret_box(signed_used_data, key, nonce2)`. 4. Store: `(nonce2, ct2, tag2)` @@ -208,13 +190,15 @@ Link recipient: 2. HKDF: 1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`. 2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`. -3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`. -4. Decrypt: `immutable_data = decrypt (nonce1, ct1, tag1)`. -5. Verify: `SHA3-256(immutable_data) == link_key`, abort if not. -6. Decrypt: `signed_used_data = decrypt(nonce2, ct2, tag2)` -7. Verify signature with key in immutable data. +3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`: + 1) contact address: `LGET` command, that allows retrieving link data multiple times. + 2) 1-time invitation: `LKEY` command, that non-optionally secures the queue, and only allows repeated link data retrievals if the same sender's key is provided and signs the transmission. This prevents link data retrieval by link observers. +4. Decrypt: `(signature1, fixed_data) = decrypt (nonce1, ct1, tag1)`. +5. Verify: `SHA3-256(fixed_data) == link_key`, abort if not. +6. Decrypt: `(signature2, used_data) = decrypt(nonce2, ct2, tag2)`. +7. Verify signatures using key in the fixed data, abort if they don't match. -While using content hash as encryption key is unconventional, it is not completely unheard of - e.g., it is used in convergent encryption (although in our case using random nonce makes it not convergent, but other use cases suggest that this approach preserves encryption security). It is particularly acceptable for our use case, as `immutable_data` contains mostly random keys. +While using content hash as encryption key is unconventional, it is not completely unusual - e.g., it is used in convergent encryption (although in our case using random nonce makes it not convergent, but other use cases suggest that this approach preserves encryption security). It is particularly acceptable for our use case, as `fixed_data` contains mostly random keys. ## Threat model @@ -222,10 +206,10 @@ While using content hash as encryption key is unconventional, it is not complete can: - delete link data. -- hide link selectively from some requests. +- hide link data selectively for some or for all requests. cannot: -- undetectably replace link data, even if they have the link (objective 3). +- undetectably replace link data, even if it has the link (objective 3). - access unencrypted link data, whether it was or was not accessed by the accepting party, provided it has no link (objective 2). - observe IP addresses of the users accessing link data, if private routing is used. @@ -236,10 +220,10 @@ can: cannot: - undetectably access observed 1-time link data, accessing the link would make the link inaccessible to the sender (objective 5). -- undetectbly check the existense of messaging queue or 1-time link (objective 8). +- undetectably check the existence of messaging queue or 1-time link (objective 8). - replace or delete the link data. -**Queue owner who did not comprmise the server**: +**Queue owner who did not compromise the server**: cannot: - redirect connecting user to another queue, on the same or on another server (objective 1). @@ -247,40 +231,42 @@ cannot: ## Correlation of design objectives with design elements -1. The presense of `SenderId` in `LINK` response from the server. +1. The presence of `SenderId` in `LNK` response from the server. 2. Encryption of link data with crypto_box. -3. Auth tag in the link prevents server modification of immutable part of link data. Signature verification key in immutable part, and signing of mutable part prevents server modification of mutable part of link data. -4. No server command to change immutable part of link data once it's set. +3. Deriving encryption key from the hash of fixed data prevents it being modified by the server - any change would be detected and rejected by the client, as the hash of fixed data won't match the link. Signature verification with the key from fixed data, and signing of mutable data prevents server modification of mutable data. +4. No server command to change fixed data once it's set. Also, changing fixed data would require changing the link. 5. 1-time link data can only be accessed with `LKEY` command, that while allows retries to mitigate network failures, will require the same key for retries. 6. `LSET` command. -7. The link only includes auth tag for immutable part, mutable part includes signature. -8. Temporarily public IDs (SenderId and LinkId for 1-time invitations) are generated server-side, and cannot be provided by the clients when creating the queues to check if these IDs are free. +7. The link is derived from fixed data only, so it does not change when mutable link data changes. Mutable part is signed preventing server MITM attacks. +8. SenderId is derived from request correlation ID, so it cannot be arbitrary defined to check existence of some known queue. LinkId for 1-time invitation is generated server-side, so it cannot be provided by the client when creating the queues to check if these IDs are used. ## Syntax for short links -The proposed syntax: +The syntax: ```abnf -shortConnectionLink = %s"https://" smpServerHost "/" linkUri [ "?" param *( "&" param ) ] +shortConnectionLink = uriAuthority "/" linkUri [ "?" param *( "&" param ) ] +uriAuthority = %s"https://" smpServerHost / "simplex:" ; using simplex: scheme requires including host in the parameter hostParam smpServerHost = ; RFC1123, RFC5891 -linkUri = %s"i#" serverInfo oneTimeLinkBytes / %s"c#" serverInfo contactLinkBytes -oneTimeLinkBytes = ; 56 bytes / 75 base64 encoded characters -contactLinkBytes = ; 32 bytes / 43 base64 encoded characters -; linkId - 96 bits/24 bytes +linkUri = %s"i#" oneTimeLink / contactType "#" contactLink +contactType = %s"a" / %s"g" / %s"c" ; contact / group / channel address, respectively +oneTimeLink = "/" ; 56 bytes / 75 base64 encoded characters +contactLink = ; 32 bytes / 43 base64 encoded characters +; linkId - 192 bits/24 bytes ; linkKey - 256 bits/32 bytes -serverInfo = [fingerprint "@" [hostnames "/"]] ; not needed for preset servers, required otherwise - the clients must refuse to connect if they don't have fingerprint in the code. - -fingerprint = -hostnames = "h=" *( "," ) ; additional hostnames, e.g. onion +param = hostsParam / portParam / certHashParam +hostsParam = %s"h=" host *("," host) ; additional hostnames, e.g. onion +portParam = %s"p=" 1*DIGIT ; server port +certHashParam = %s"c=" ``` -To have shorter links fingerpring and additional server hostnames do not need to be specified for preconfigured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint. +To have shorter links fingerprint and additional server hostnames do not need to be specified for pre-configured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint. -Example one-time link for preset server (103 characters): +Example one-time link for preset server (104 characters): ``` -https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij01234 +https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij01/23456789abcdefghij0123456789abcdefghij01234 ``` Example contact link for preset server (71 characters): @@ -289,16 +275,16 @@ Example contact link for preset server (71 characters): https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abc ``` -Example contact link for user-defined server (with fingerprint, but without onion hostname - 115 characters): +Example contact link for user-defined server (with fingerprint, but without onion hostname - 117 characters): ``` -https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abc +https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU ``` -Example contact link for user-defined server (with fingerprint ant onion hostname - 178 characters): +Example contact link for user-defined server (with fingerprint ant onion hostname - 182 characters): ``` -https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc +https://smp1.example.com/c#abcdefghij0123456789abcdefghij0123456789abc?c=0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU&h=beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion ``` For the links to work in the browser the servers must provide server pages. From 1b8613d7679768a8b870fc2f2ccffb25328f00ea Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 4 Jul 2025 16:31:57 +0000 Subject: [PATCH 12/22] build: do not exclude postgres modules for client_library flag (#1579) * don't exclude postgres modules for client_library flag * fix build with client and server postgres flag --------- Co-authored-by: Evgeny Poberezkin --- simplexmq.cabal | 15 +++++++-------- .../Notifications/Server/Store/Postgres.hs | 2 +- .../Messaging/Server/QueueStore/Postgres.hs | 5 ++--- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index fe8c91e90..58de2cc45 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -210,6 +210,13 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250702_conn_invitations_remove_cascade_delete + if flag(client_postgres) || flag(server_postgres) + exposed-modules: + Simplex.Messaging.Agent.Store.Postgres + Simplex.Messaging.Agent.Store.Postgres.Common + Simplex.Messaging.Agent.Store.Postgres.DB + Simplex.Messaging.Agent.Store.Postgres.Migrations + Simplex.Messaging.Agent.Store.Postgres.Util if !flag(client_library) exposed-modules: Simplex.FileTransfer.Client.Main @@ -242,14 +249,6 @@ library Simplex.Messaging.Server.StoreLog.ReadWrite Simplex.Messaging.Server.StoreLog.Types Simplex.Messaging.Transport.WebSockets - if flag(client_postgres) || flag(server_postgres) - exposed-modules: - Simplex.Messaging.Agent.Store.Postgres - Simplex.Messaging.Agent.Store.Postgres.Common - Simplex.Messaging.Agent.Store.Postgres.DB - Simplex.Messaging.Agent.Store.Postgres.Migrations - Simplex.Messaging.Agent.Store.Postgres.Util - if flag(server_postgres) exposed-modules: Simplex.Messaging.Notifications.Server diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 7d52bb975..8df158182 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -56,6 +56,7 @@ import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_) import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Store (NtfSTMStore (..), NtfSubData (..), NtfTknData (..), TokenNtfMessageRecord (..), ntfSubServer) @@ -75,7 +76,6 @@ import System.IO (IOMode (..), hFlush, stdout, withFile) import Text.Hex (decodeHex) #if !defined(dbPostgres) -import Simplex.Messaging.Encoding.String import Simplex.Messaging.Util (eitherToMaybe) #endif diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index b159207de..aa1a006e2 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -53,6 +53,7 @@ import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Set as S import Data.Text (Text) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import qualified Data.X509 as X import qualified Data.X509.Validation as XV @@ -69,7 +70,7 @@ import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.AgentStore () import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common -import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) +import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (parseAll) @@ -89,8 +90,6 @@ import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM #if !defined(dbPostgres) -import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_) import Simplex.Messaging.Encoding.String #endif From 660c4293f0c0a1aa8a6c6c8a1e863e182d089a93 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 5 Jul 2025 11:35:27 +0100 Subject: [PATCH 13/22] 6.4.0.11.1 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 58de2cc45..106d9a41e 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.4.0.11 +version: 6.4.0.11.1 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 36f05e272e76c21b69752d75552afb0fe005500f Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 7 Jul 2025 09:38:52 +0100 Subject: [PATCH 14/22] agent: support different timeouts for interactive and background requests (#1582) * agent: support different timeouts for interactive and background requests * fix tests * use one constructor for the first request and for retries --- src/Simplex/FileTransfer/Client.hs | 10 +- src/Simplex/FileTransfer/Client/Agent.hs | 6 +- src/Simplex/Messaging/Agent.hs | 280 +++++++-------- src/Simplex/Messaging/Agent/Client.hs | 324 +++++++++--------- .../Messaging/Agent/NtfSubSupervisor.hs | 3 +- src/Simplex/Messaging/Client.hs | 245 +++++++------ src/Simplex/Messaging/Client/Agent.hs | 6 +- src/Simplex/Messaging/Notifications/Client.hs | 46 +-- tests/AgentTests/FunctionalAPITests.hs | 88 +++-- tests/AgentTests/NotificationTests.hs | 15 +- tests/CoreTests/SOCKSSettings.hs | 2 +- tests/SMPAgentClient.hs | 6 +- tests/SMPProxyTests.hs | 38 +- tests/XFTPAgent.hs | 3 +- 14 files changed, 579 insertions(+), 493 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 01eca236c..5e4c84aa3 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -36,8 +36,10 @@ import Simplex.FileTransfer.Protocol import Simplex.FileTransfer.Transport import Simplex.Messaging.Client ( NetworkConfig (..), + NetworkRequestMode (..), ProtocolClientError (..), TransportSession, + netTimeoutInt, chooseTransportHost, defaultNetworkConfig, transportClientConfig, @@ -107,7 +109,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession ProtocolServer _ host port keyHash = srv useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host - let tcConfig = transportClientConfig xftpNetworkConfig useHost False clientALPN + let tcConfig = transportClientConfig xftpNetworkConfig NRMBackground useHost False clientALPN http2Config = xftpHTTP2Config tcConfig config clientVar <- newTVarIO Nothing let usePort = if null port then "443" else port @@ -178,7 +180,7 @@ xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkCon defaultHTTP2ClientConfig { bodyHeadSize = xftpBlockSize, suportedTLSParams = defaultSupportedParams, - connTimeout = tcpConnectTimeout, + connTimeout = netTimeoutInt tcpConnectTimeout NRMBackground, transportConfig } @@ -268,11 +270,11 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec { xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ = - maybe tcpTimeout (chunkTimeout cfg) chunkSize_ + maybe (netTimeoutInt tcpTimeout NRMBackground) (chunkTimeout cfg) chunkSize_ chunkTimeout :: XFTPClientConfig -> Word32 -> Int chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz = - tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int))) + netTimeoutInt tcpTimeout NRMBackground + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int))) deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO () deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index 5d6b5c7a5..d5733ac14 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -19,7 +19,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock (UTCTime, getCurrentTime) import Simplex.FileTransfer.Client import Simplex.Messaging.Agent.RetryInterval -import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError) +import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), ProtocolClientError (..), netTimeoutInt, temporaryClientError) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer) import Simplex.Messaging.TMap (TMap) @@ -90,7 +90,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do waitForXFTPClient :: XFTPClientVar -> ME XFTPClient waitForXFTPClient clientVar = do let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config - client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar) + client_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar clientVar) liftEither $ case client_ of Just (Right c) -> Right c Just (Left e) -> Left e @@ -127,6 +127,6 @@ closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv = where closeClient cVar = do let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config - tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case + netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar cVar) >>= \case Just (Right client) -> closeXFTPClient client `catchAll_` pure () _ -> pure () diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index b0c5526e6..41a4e347a 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -182,7 +182,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations) import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration) -import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, temporaryClientError, unexpectedResponse) +import Simplex.Messaging.Client (NetworkRequestMode (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) @@ -368,22 +368,22 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync' {-# INLINE deleteConnectionsAsync #-} -- | Create SMP agent connection (NEW command) -createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) -createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs +createConnection :: ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) +createConnection c nm userId enableNtfs = withAgentEnv c .::. newConn c nm userId enableNtfs {-# INLINE createConnection #-} -- | Create or update user's contact connection short link -setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c) -setConnShortLink c = withAgentEnv c .:: setConnShortLink' c +setConnShortLink :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c) +setConnShortLink c = withAgentEnv c .::. setConnShortLink' c {-# INLINE setConnShortLink #-} -deleteConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> AE () -deleteConnShortLink c = withAgentEnv c .: deleteConnShortLink' c +deleteConnShortLink :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> AE () +deleteConnShortLink c = withAgentEnv c .:. deleteConnShortLink' c {-# INLINE deleteConnShortLink #-} -- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries -getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c) -getConnShortLink c = withAgentEnv c .: getConnShortLink' c +getConnShortLink :: AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c) +getConnShortLink c = withAgentEnv c .:. getConnShortLink' c {-# INLINE getConnShortLink #-} -- | This irreversibly deletes short link data, and it won't be retrievable again @@ -411,8 +411,8 @@ prepareConnectionToAccept c userId enableNtfs = withAgentEnv c .: newConnToAccep {-# INLINE prepareConnectionToAccept #-} -- | Join SMP agent connection (JOIN command). -joinConnection :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId) -joinConnection c userId connId enableNtfs = withAgentEnv c .:: joinConn c userId connId enableNtfs +joinConnection :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId) +joinConnection c nm userId connId enableNtfs = withAgentEnv c .:: joinConn c nm userId connId enableNtfs {-# INLINE joinConnection #-} -- | Allow connection to continue after CONF notification (LET command) @@ -421,8 +421,8 @@ allowConnection c = withAgentEnv c .:. allowConnection' c {-# INLINE allowConnection #-} -- | Accept contact after REQ notification (ACPT command) -acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId) -acceptContact c userId connId enableNtfs = withAgentEnv c .:: acceptContact' c userId connId enableNtfs +acceptContact :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId) +acceptContact c userId connId enableNtfs = withAgentEnv c .::. acceptContact' c userId connId enableNtfs {-# INLINE acceptContact #-} -- | Reject contact (RJCT command) @@ -501,13 +501,13 @@ ackMessage :: AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AE ackMessage c = withAgentEnv c .:. ackMessage' c {-# INLINE ackMessage #-} -getConnectionQueueInfo :: AgentClient -> ConnId -> AE ServerQueueInfo -getConnectionQueueInfo c = withAgentEnv c . getConnectionQueueInfo' c +getConnectionQueueInfo :: AgentClient -> NetworkRequestMode -> ConnId -> AE ServerQueueInfo +getConnectionQueueInfo c = withAgentEnv c .: getConnectionQueueInfo' c {-# INLINE getConnectionQueueInfo #-} -- | Switch connection to the new receive queue -switchConnection :: AgentClient -> ConnId -> AE ConnectionStats -switchConnection c = withAgentEnv c . switchConnection' c +switchConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE ConnectionStats +switchConnection c = withAgentEnv c .: switchConnection' c {-# INLINE switchConnection #-} -- | Abort switching connection to the new receive queue @@ -521,18 +521,18 @@ synchronizeRatchet c = withAgentEnv c .:. synchronizeRatchet' c {-# INLINE synchronizeRatchet #-} -- | Suspend SMP agent connection (OFF command) -suspendConnection :: AgentClient -> ConnId -> AE () -suspendConnection c = withAgentEnv c . suspendConnection' c +suspendConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE () +suspendConnection c = withAgentEnv c .: suspendConnection' c {-# INLINE suspendConnection #-} -- | Delete SMP agent connection (DEL command) -deleteConnection :: AgentClient -> ConnId -> AE () -deleteConnection c = withAgentEnv c . deleteConnection' c +deleteConnection :: AgentClient -> NetworkRequestMode -> ConnId -> AE () +deleteConnection c = withAgentEnv c .: deleteConnection' c {-# INLINE deleteConnection #-} -- | Delete multiple connections, batching commands when possible -deleteConnections :: AgentClient -> [ConnId] -> AE (Map ConnId (Either AgentErrorType ())) -deleteConnections c = withAgentEnv c . deleteConnections' c +deleteConnections :: AgentClient -> NetworkRequestMode -> [ConnId] -> AE (Map ConnId (Either AgentErrorType ())) +deleteConnections c = withAgentEnv c .: deleteConnections' c {-# INLINE deleteConnections #-} -- | get servers used for connection @@ -546,11 +546,11 @@ getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c {-# INLINE getConnectionRatchetAdHash #-} -- | Test protocol server -testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> UserId -> ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure) -testProtocolServer c userId srv = withAgentEnv' c $ case protocolTypeI @p of - SPSMP -> runSMPServerTest c userId srv - SPXFTP -> runXFTPServerTest c userId srv - SPNTF -> runNTFServerTest c userId srv +testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure) +testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of + SPSMP -> runSMPServerTest c nm userId srv + SPXFTP -> runXFTPServerTest c nm userId srv + SPNTF -> runNTFServerTest c nm userId srv -- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network setNetworkConfig :: AgentClient -> NetworkConfig -> IO () @@ -583,17 +583,17 @@ reconnectAllServers c = do reconnectServerClients c ntfClients -- | Register device notifications token -registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus -registerNtfToken c = withAgentEnv c .: registerNtfToken' c +registerNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AE NtfTknStatus +registerNtfToken c = withAgentEnv c .:. registerNtfToken' c {-# INLINE registerNtfToken #-} -- | Verify device notifications token -verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE () -verifyNtfToken c = withAgentEnv c .:. verifyNtfToken' c +verifyNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AE () +verifyNtfToken c = withAgentEnv c .:: verifyNtfToken' c {-# INLINE verifyNtfToken #-} -checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus -checkNtfToken c = withAgentEnv c . checkNtfToken' c +checkNtfToken :: AgentClient -> NetworkRequestMode -> DeviceToken -> AE NtfTknStatus +checkNtfToken c = withAgentEnv c .: checkNtfToken' c {-# INLINE checkNtfToken #-} deleteNtfToken :: AgentClient -> DeviceToken -> AE () @@ -812,7 +812,7 @@ deleteConnectionsAsync_ onSuccess c waitDelivery connIds = case connIds of withStore' c $ \db -> forM_ connIds' $ setConnDeleted db waitDelivery void . lift . forkIO $ withLock' (deleteLock c) "deleteConnectionsAsync" $ - deleteConnQueues c waitDelivery True rqs >> void (runExceptT onSuccess) + deleteConnQueues c NRMBackground waitDelivery True rqs >> void (runExceptT onSuccess) -- | Add connection to the new receive queue switchConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> AM ConnectionStats @@ -829,22 +829,22 @@ switchConnectionAsync' c corrId connId = pure . connectionStats $ DuplexConnection cData rqs' sqs _ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex" -newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) -newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do +newConn :: ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) +newConn c nm userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do srv <- getSMPServer c userId connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys) - (connId,) <$> newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv + (connId,) <$> newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv `catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e -setConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AM (ConnShortLink c) -setConnShortLink' c connId cMode userData clientData = +setConnShortLink' :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AM (ConnShortLink c) +setConnShortLink' c nm connId cMode userData clientData = withConnLock c connId "setConnShortLink" $ do SomeConn _ conn <- withStore c (`getConn` connId) (rq, lnkId, sl, d) <- case (conn, cMode) of (ContactConnection _ rq, SCMContact) -> prepareContactLinkData rq (RcvConnection _ rq, SCMInvitation) -> prepareInvLinkData rq _ -> throwE $ CMD PROHIBITED "setConnShortLink: invalid connection or mode" - addQueueLink c rq lnkId d + addQueueLink c nm rq lnkId d pure sl where prepareContactLinkData :: RcvQueue -> AM (RcvQueue, SMP.LinkId, ConnShortLink 'CMContact, QueueLinkData) @@ -879,18 +879,18 @@ setConnShortLink' c connId cMode userData clientData = pure (rq, shortLinkId, sl, (linkEncFixedData, d)) Nothing -> throwE $ CMD PROHIBITED "setConnShortLink: no ShortLinkCreds in invitation" -deleteConnShortLink' :: AgentClient -> ConnId -> SConnectionMode c -> AM () -deleteConnShortLink' c connId cMode = +deleteConnShortLink' :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> AM () +deleteConnShortLink' c nm connId cMode = withConnLock c connId "deleteConnShortLink" $ do SomeConn _ conn <- withStore c (`getConn` connId) case (conn, cMode) of - (ContactConnection _ rq, SCMContact) -> deleteQueueLink c rq - (RcvConnection _ rq, SCMInvitation) -> deleteQueueLink c rq + (ContactConnection _ rq, SCMContact) -> deleteQueueLink c nm rq + (RcvConnection _ rq, SCMInvitation) -> deleteQueueLink c nm rq _ -> throwE $ CMD PROHIBITED "deleteConnShortLink: not contact address" -- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent. -getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnLinkData c) -getConnShortLink' c userId = \case +getConnShortLink' :: forall c. AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnLinkData c) +getConnShortLink' c nm userId = \case CSLInvitation _ srv linkId linkKey -> do g <- asks random invLink <- withStore' c $ \db -> do @@ -902,12 +902,12 @@ getConnShortLink' c userId = \case createInvShortLink db sl pure sl let k = SL.invShortLinkKdf linkKey - ld@(sndId, _) <- secureGetQueueLink c userId invLink + ld@(sndId, _) <- secureGetQueueLink c nm userId invLink withStore' c $ \db -> setInvShortLinkSndId db invLink sndId decryptData srv linkKey k ld CSLContact _ _ srv linkKey -> do let (linkId, k) = SL.contactShortLinkKdf linkKey - ld <- getQueueLink c userId srv linkId + ld <- getQueueLink c nm userId srv linkId decryptData srv linkKey k ld where decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (ConnectionRequestUri c, ConnLinkData c) @@ -932,8 +932,8 @@ changeConnectionUser' c oldUserId connId newUserId = do where updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId -newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId) -newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do +newRcvConnSrv :: forall c. ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe UserLinkData -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (CreatedConnLink c, Maybe ClientServiceId) +newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do case (cMode, pqInitKeys) of (SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv" _ -> pure () @@ -955,7 +955,7 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s AgentConfig {smpClientVRange = vr} <- asks config -- TODO [notifications] send correct NTF credentials here -- let ntfCreds_ = Nothing - (rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e + (rq, qUri, tSess, sessId) <- newRcvQueue_ c nm userId connId srvWithAuth vr qd subMode nonce_ e2eKeys `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 @@ -1038,10 +1038,10 @@ newConnToAccept c userId connId enableNtfs invId pqSup = do Invitation {connReq} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId newConnToJoin c userId connId enableNtfs connReq pqSup -joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) -joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do +joinConn :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) +joinConn c nm userId connId enableNtfs cReq cInfo pqSupport subMode = do srv <- getNextSMPServer c userId [qServer $ connReqQueue cReq] - joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv + joinConnSrv c nm userId connId enableNtfs cReq cInfo pqSupport subMode srv connReqQueue :: ConnectionRequestUri c -> SMPQueueUri connReqQueue = \case @@ -1118,8 +1118,8 @@ versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_ {-# INLINE versionPQSupport_ #-} -joinConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId) -joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = +joinConnSrv :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM (SndQueueSecured, Maybe ClientServiceId) +joinConnSrv c nm userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = withInvLock c (strEncode inv) "joinConnSrv" $ do SomeConn cType conn <- withStore c (`getConn` connId) case conn of @@ -1132,19 +1132,19 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod doJoin :: Maybe RcvQueue -> Maybe SndQueue -> AM (SndQueueSecured, Maybe ClientServiceId) doJoin rq_ sq_ = do (cData, sq, e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup - secureConfirmQueue c cData rq_ sq srv cInfo (Just e2eSndParams) subMode + secureConfirmQueue c nm cData rq_ sq srv cInfo (Just e2eSndParams) subMode >>= (mapM_ (delInvSL c connId srv) lnkId_ $>) -joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = +joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn@(Compatible v)) -> withInvLock c (strEncode cReqUri) "joinConnSrv" $ do SomeConn cType conn <- withStore c (`getConn` connId) let pqInitKeys = CR.joinContactInitialKeys (v >= pqdrSMPAgentVersion) pqSup (CCLink cReq _, service) <- case conn of - NewConnection _ -> newRcvConnSrv c userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys subMode srv + NewConnection _ -> newRcvConnSrv c NRMBackground userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys subMode srv RcvConnection _ rq -> mkJoinInvitation rq pqInitKeys _ -> throwE $ CMD PROHIBITED $ "joinConnSrv: bad connection " <> show cType - void $ sendInvitation c userId connId qInfo vrsn cReq cInfo + void $ sendInvitation c nm userId connId qInfo vrsn cReq cInfo pure (False, service) where mkJoinInvitation rq@RcvQueue {clientService} pqInitKeys = do @@ -1190,10 +1190,10 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do throwE $ CMD PROHIBITED "joinConnSrvAsync" -createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM (SMPQueueInfo, Maybe ClientServiceId) -createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do +createReplyQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM (SMPQueueInfo, Maybe ClientServiceId) +createReplyQueue c nm ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do -- TODO [notifications] send correct NTF credentials here - (rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode -- Nothing + (rq, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode -- Nothing atomically $ incSMPServerStat c userId (qServer rq) connCreated let qInfo = toVersionT qUri smpClientVersion rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq @@ -1214,10 +1214,10 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne _ -> throwE $ CMD PROHIBITED "allowConnection" -- | Accept contact (ACPT command) in Reader monad -acceptContact' :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) -acceptContact' c userId connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do +acceptContact' :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) +acceptContact' c nm userId connId enableNtfs invId ownConnInfo pqSupport subMode = withConnLock c connId "acceptContact" $ do Invitation {connReq} <- withStore c $ \db -> getInvitation db "acceptContact'" invId - r <- joinConn c userId connId enableNtfs connReq ownConnInfo pqSupport subMode + r <- joinConn c nm userId connId enableNtfs connReq ownConnInfo pqSupport subMode withStore' c $ \db -> acceptInvitation db invId ownConnInfo pure r @@ -1486,7 +1486,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do - (CCLink cReq _, service) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv + (CCLink cReq _, service) <- newRcvConnSrv c NRMBackground userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv notify $ INV (ACR cMode cReq) service JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty @@ -1499,9 +1499,9 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do noServer . tryWithLock "switchConnection" $ withStore c (`getConn` connId) >>= \case SomeConn _ conn@(DuplexConnection _ (replaced :| _rqs) _) -> - switchDuplexConnection c conn replaced >>= notify . SWITCH QDRcv SPStarted + switchDuplexConnection c NRMBackground conn replaced >>= notify . SWITCH QDRcv SPStarted _ -> throwE $ CMD PROHIBITED "SWCH: not duplex" - DEL -> withServer' . tryCommand $ deleteConnection' c connId >> notify OK + DEL -> withServer' . tryCommand $ deleteConnection' c NRMBackground connId >> notify OK _ -> notify $ ERR $ INTERNAL $ "unsupported async command " <> show (aCommandTag cmd) AInternalCommand cmd -> case cmd of ICAckDel rId srvMsgId msgId -> withServer $ \srv -> tryWithLock "ICAckDel" $ ack srv rId srvMsgId >> withStore' c (\db -> deleteMsg db connId msgId) @@ -1535,7 +1535,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do ICDeleteConn -> withStore' c (`deleteCommand` cmdId) ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do rq <- withStore c (\db -> getDeletedRcvQueue db connId srv rId) - deleteQueue c rq + deleteQueue c NRMBackground rq withStore' c (`deleteConnRcvQueue` rq) ICQSecure rId senderKey -> withServer $ \srv -> tryWithLock "ICQSecure" . withDuplexConn $ \(DuplexConnection cData rqs sqs) -> @@ -1543,7 +1543,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do Just rq'@RcvQueue {server, sndId, status, dbReplaceQueueId = Just replaceQId} -> case find ((replaceQId ==) . dbQId) rqs of Just rq1 -> when (status == Confirmed) $ do - secureQueue c rq' senderKey + secureQueue c NRMBackground 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 @@ -1563,7 +1563,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do | primary -> internalErr "ICQDelete: cannot delete primary rcv queue" | otherwise -> do checkRQSwchStatus rq' RSReceivedMessage - tryError (deleteQueue c rq') >>= \case + tryError (deleteQueue c NRMBackground rq') >>= \case Right () -> finalizeSwitch Left e | temporaryOrHostError e -> throwE e @@ -1583,7 +1583,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do ackQueueMessage c rq srvMsgId secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM () secure rq@RcvQueue {server} senderKey = do - secureQueue c rq senderKey + secureQueue c NRMBackground rq senderKey atomically $ incSMPServerStat c userId server connSecured withStore' c $ \db -> setRcvQueueStatus db rq Secured where @@ -1749,8 +1749,8 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq@SndQueue {userI liftIO $ waitWhileSuspended c liftIO $ waitForUserNetwork c resp <- tryError $ case msgType of - AM_CONN_INFO -> sendConfirmation c sq msgBody - AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody + AM_CONN_INFO -> sendConfirmation c NRMBackground sq msgBody + AM_CONN_INFO_REPLY -> sendConfirmation c NRMBackground sq msgBody _ -> case pendingMsgPrepData_ of Nothing -> sendAgentMessage c sq msgFlags msgBody Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} -> do @@ -1944,18 +1944,18 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do withStore' c $ \db -> deleteDeliveredSndMsg db connId $ InternalId sndMsgId _ -> pure () -getConnectionQueueInfo' :: AgentClient -> ConnId -> AM ServerQueueInfo -getConnectionQueueInfo' c connId = do +getConnectionQueueInfo' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ServerQueueInfo +getConnectionQueueInfo' c nm connId = do SomeConn _ conn <- withStore c (`getConn` connId) case conn of - DuplexConnection _ (rq :| _) _ -> getQueueInfo c rq - RcvConnection _ rq -> getQueueInfo c rq - ContactConnection _ rq -> getQueueInfo c rq + DuplexConnection _ (rq :| _) _ -> getQueueInfo c nm rq + RcvConnection _ rq -> getQueueInfo c nm rq + ContactConnection _ rq -> getQueueInfo c nm rq SndConnection {} -> throwE $ CONN SIMPLEX "getConnectionQueueInfo" NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionQueueInfo: NewConnection" -switchConnection' :: AgentClient -> ConnId -> AM ConnectionStats -switchConnection' c connId = +switchConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM ConnectionStats +switchConnection' c nm connId = withConnLock c connId "switchConnection" $ withStore c (`getConn` connId) >>= \case SomeConn _ conn@(DuplexConnection cData rqs@(rq :| _rqs) _) @@ -1963,18 +1963,18 @@ switchConnection' c connId = | otherwise -> do when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "switchConnection: send prohibited" rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted - switchDuplexConnection c conn rq' + switchDuplexConnection c nm conn rq' _ -> throwE $ CMD PROHIBITED "switchConnection: not duplex" -switchDuplexConnection :: AgentClient -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats -switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBEntityId dbQueueId, sndId} = do +switchDuplexConnection :: AgentClient -> NetworkRequestMode -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats +switchDuplexConnection c nm (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBEntityId dbQueueId, sndId} = do checkRQSwchStatus rq RSSwitchStarted clientVRange <- asks $ smpClientVRange . config -- try to get the server that is different from all queues, or at least from the primary rcv queue srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth -- TODO [notifications] send correct NTF credentials here - (q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SCMInvitation SMSubscribe -- Nothing + (q, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv' clientVRange SCMInvitation SMSubscribe -- Nothing let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq' lift $ addNewQueueSubscription c rq'' tSess sessId @@ -2046,21 +2046,21 @@ ackQueueMessage c rq@RcvQueue {userId, connId, server} srvMsgId = do atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ MSGNTF srvMsgId brokerTs_) -- | Suspend SMP agent connection (OFF command) in Reader monad -suspendConnection' :: AgentClient -> ConnId -> AM () -suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do +suspendConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM () +suspendConnection' c nm connId = withConnLock c connId "suspendConnection" $ do SomeConn _ conn <- withStore c (`getConn` connId) case conn of - DuplexConnection _ rqs _ -> mapM_ (suspendQueue c) rqs - RcvConnection _ rq -> suspendQueue c rq - ContactConnection _ rq -> suspendQueue c rq + DuplexConnection _ rqs _ -> mapM_ (suspendQueue c nm) rqs + RcvConnection _ rq -> suspendQueue c nm rq + ContactConnection _ rq -> suspendQueue c nm rq SndConnection _ _ -> throwE $ CONN SIMPLEX "suspendConnection" NewConnection _ -> throwE $ CMD PROHIBITED "suspendConnection" -- | Delete SMP agent connection (DEL command) in Reader monad -- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure -- currently it is used only in tests -deleteConnection' :: AgentClient -> ConnId -> AM () -deleteConnection' c connId = toConnResult connId =<< deleteConnections' c [connId] +deleteConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM () +deleteConnection' c nm connId = toConnResult connId =<< deleteConnections' c nm [connId] {-# INLINE deleteConnection' #-} connRcvQueues :: Connection d -> [RcvQueue] @@ -2072,16 +2072,16 @@ connRcvQueues = \case NewConnection _ -> [] -- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure. -deleteConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ())) +deleteConnections' :: AgentClient -> NetworkRequestMode -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ())) deleteConnections' = deleteConnections_ getConns False False {-# INLINE deleteConnections' #-} deleteDeletedConns :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ())) -deleteDeletedConns = deleteConnections_ getDeletedConns True False +deleteDeletedConns c = deleteConnections_ getDeletedConns True False c NRMBackground {-# INLINE deleteDeletedConns #-} deleteDeletedWaitingDeliveryConns :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ())) -deleteDeletedWaitingDeliveryConns = deleteConnections_ getConns True True +deleteDeletedWaitingDeliveryConns c = deleteConnections_ getConns True True c NRMBackground {-# INLINE deleteDeletedWaitingDeliveryConns #-} prepareDeleteConnections_ :: @@ -2119,9 +2119,9 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do atomically $ writeTBQueue (ntfSubQ ns) (NSCDeleteSub, connIds') notify = atomically . writeTBQueue (subQ c) -deleteConnQueues :: AgentClient -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ())) -deleteConnQueues c waitDelivery ntf rqs = do - rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs) +deleteConnQueues :: AgentClient -> NetworkRequestMode -> Bool -> Bool -> [RcvQueue] -> AM' (Map ConnId (Either AgentErrorType ())) +deleteConnQueues c nm waitDelivery ntf rqs = do + rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c nm rqs) let connIds = M.keys $ M.filter isRight rs deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing cIds_ <- L.nonEmpty . catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds) @@ -2172,12 +2172,13 @@ deleteConnections_ :: Bool -> Bool -> AgentClient -> + NetworkRequestMode -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ())) -deleteConnections_ _ _ _ _ [] = pure M.empty -deleteConnections_ getConnections ntf waitDelivery c connIds = do +deleteConnections_ _ _ _ _ _ [] = pure M.empty +deleteConnections_ getConnections ntf waitDelivery c nm connIds = do (rs, rqs, _) <- prepareDeleteConnections_ getConnections c waitDelivery connIds - rcvRs <- lift $ deleteConnQueues c waitDelivery ntf rqs + rcvRs <- lift $ deleteConnQueues c nm waitDelivery ntf rqs let rs' = M.union rs rcvRs notifyResultError rs' pure rs' @@ -2233,8 +2234,8 @@ checkUserServers name srvs = unless (any (\ServerCfg {enabled} -> enabled) srvs) $ logWarn (name <> ": all passed servers are disabled, using all servers.") -registerNtfToken' :: AgentClient -> DeviceToken -> NotificationsMode -> AM NtfTknStatus -registerNtfToken' c suppliedDeviceToken suppliedNtfMode = +registerNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> NotificationsMode -> AM NtfTknStatus +registerNtfToken' c nm suppliedDeviceToken suppliedNtfMode = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId, ntfTknStatus, ntfTknAction, ntfMode = savedNtfMode} -> do status <- case (ntfTokenId, ntfTknAction) of @@ -2248,18 +2249,18 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = | otherwise -> replaceToken tknId (Just tknId, Just (NTAVerify code)) | savedDeviceToken == suppliedDeviceToken -> - t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code + t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c nm tknId tkn code | otherwise -> replaceToken tknId (Just tknId, Just NTACheck) | savedDeviceToken == suppliedDeviceToken -> do ns <- asks ntfSupervisor let tkn' = tkn {ntfMode = suppliedNtfMode} atomically $ nsUpdateToken ns tkn' - agentNtfCheckToken c tknId tkn' >>= \case + agentNtfCheckToken c nm tknId tkn' >>= \case NTActive -> do when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCSmpDelete - lift $ setCronInterval c tknId tkn + lift $ setCronInterval c nm tknId tkn t tkn' (NTActive, Just NTACheck) $ pure () status -> t tkn' (status, Nothing) $ pure () | otherwise -> replaceToken tknId @@ -2281,13 +2282,13 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = createToken where tryReplace ns = do - agentNtfReplaceToken c tknId tkn suppliedDeviceToken + agentNtfReplaceToken c nm tknId tkn suppliedDeviceToken withStore' c $ \db -> updateDeviceToken db tkn suppliedDeviceToken atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode} pure NTRegistered _ -> createToken where - t tkn = withToken c tkn Nothing + t tkn = withToken c nm tkn Nothing createToken :: AM NtfTknStatus createToken = lift (getNtfServer c) >>= \case @@ -2304,37 +2305,37 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = _ -> throwE $ CMD PROHIBITED "createToken" registerToken :: NtfToken -> AM () registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do - (tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey + (tknId, srvPubDhKey) <- agentNtfRegisterToken c nm tkn ntfPubKey pubDhKey let dhSecret = C.dh' srvPubDhKey privDhKey withStore' c $ \db -> updateNtfTokenRegistration db tkn tknId dhSecret ns <- asks ntfSupervisor atomically $ nsUpdateToken ns tkn {deviceToken = suppliedDeviceToken, ntfTknStatus = NTRegistered, ntfMode = suppliedNtfMode} -verifyNtfToken' :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AM () -verifyNtfToken' c deviceToken nonce code = +verifyNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> C.CbNonce -> ByteString -> AM () +verifyNtfToken' c nm deviceToken nonce code = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "verifyNtfToken: different token" code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code toStatus <- - withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $ - agentNtfVerifyToken c tknId tkn code' + withToken c nm tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $ + agentNtfVerifyToken c nm tknId tkn code' when (toStatus == NTActive) $ do - lift $ setCronInterval c tknId tkn + lift $ setCronInterval c nm tknId tkn when (ntfMode == NMInstant) $ initializeNtfSubs c _ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token" -setCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> AM' () -setCronInterval c tknId tkn = do +setCronInterval :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> AM' () +setCronInterval c nm tknId tkn = do cron <- asks $ ntfCron . config - void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c tknId tkn cron + void $ forkIO $ void $ runExceptT $ agentNtfSetCronInterval c nm tknId tkn cron -checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus -checkNtfToken' c deviceToken = +checkNtfToken' :: AgentClient -> NetworkRequestMode -> DeviceToken -> AM NtfTknStatus +checkNtfToken' c nm deviceToken = withStore' c getSavedNtfToken >>= \case Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfTknAction} -> do when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "checkNtfToken: different token" - status <- agentNtfCheckToken c tknId tkn + status <- agentNtfCheckToken c nm tknId tkn let action = case status of NTInvalid _ -> Nothing NTExpired -> Nothing @@ -2383,8 +2384,8 @@ toggleConnectionNtfs' c connId enable = do let cmd = if enable then NSCCreate else NSCSmpDelete atomically $ sendNtfSubCommand ns (cmd, [connId]) -withToken :: AgentClient -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus -withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do +withToken :: AgentClient -> NetworkRequestMode -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus +withToken c nm tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do ns <- asks ntfSupervisor forM_ from_ $ \(status, action) -> do withStore' c $ \db -> updateNtfToken db tkn status (Just action) @@ -2398,7 +2399,7 @@ withToken c tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = Left e@(NTF _ AUTH) -> do withStore' c $ \db -> removeNtfToken db tkn atomically $ nsRemoveNtfToken ns - void $ registerNtfToken' c deviceToken ntfMode + void $ registerNtfToken' c nm deviceToken ntfMode throwE e Left e -> throwE e @@ -3186,6 +3187,7 @@ switchStatusError q expected actual = <> (", expected=" <> show expected) <> (", actual=" <> show actual) +-- used only in background connectReplyQueues :: AgentClient -> ConnData -> ConnInfo -> Maybe SndQueue -> NonEmpty SMPQueueInfo -> AM () connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _) = do clientVRange <- asks $ smpClientVRange . config @@ -3194,7 +3196,7 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _ Just qInfo' -> do -- in case of SKEY retry the connection is already duplex sq' <- maybe upgradeConn pure sq_ - void $ agentSecureSndQueue c cData sq' + void $ agentSecureSndQueue c NRMBackground cData sq' enqueueConfirmation c cData sq' ownConnInfo Nothing where upgradeConn = do @@ -3203,18 +3205,18 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _ secureConfirmQueueAsync :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) secureConfirmQueueAsync c cData rq_ sq srv connInfo e2eEncryption_ subMode = do - sqSecured <- agentSecureSndQueue c cData sq - (qInfo, service) <- mkAgentConfirmation c cData rq_ sq srv connInfo subMode + sqSecured <- agentSecureSndQueue c NRMBackground cData sq + (qInfo, service) <- mkAgentConfirmation c NRMBackground cData rq_ sq srv connInfo subMode storeConfirmation c cData sq e2eEncryption_ qInfo lift $ submitPendingMsg c cData sq pure (sqSecured, service) -secureConfirmQueue :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) -secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} rq_ sq srv connInfo e2eEncryption_ subMode = do - sqSecured <- agentSecureSndQueue c cData sq - (qInfo, service) <- mkAgentConfirmation c cData rq_ sq srv connInfo subMode +secureConfirmQueue :: AgentClient -> NetworkRequestMode -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM (SndQueueSecured, Maybe ClientServiceId) +secureConfirmQueue c nm cData@ConnData {connId, connAgentVersion, pqSupport} rq_ sq srv connInfo e2eEncryption_ subMode = do + sqSecured <- agentSecureSndQueue c nm cData sq + (qInfo, service) <- mkAgentConfirmation c nm cData rq_ sq srv connInfo subMode msg <- mkConfirmation qInfo - void $ sendConfirmation c sq msg + void $ sendConfirmation c nm sq msg withStore' c $ \db -> setSndQueueStatus db sq Confirmed pure (sqSecured, service) where @@ -3229,10 +3231,10 @@ secureConfirmQueue c cData@ConnData {connId, connAgentVersion, pqSupport} rq_ sq (encConnInfo, _) <- agentRatchetEncrypt db cData agentMsgBody e2eEncConnInfoLength (Just pqEnc) currentE2EVersion pure . smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo} -agentSecureSndQueue :: AgentClient -> ConnData -> SndQueue -> AM SndQueueSecured -agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {queueMode, status} +agentSecureSndQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> AM SndQueueSecured +agentSecureSndQueue c nm ConnData {connAgentVersion} sq@SndQueue {queueMode, status} | sndSecure && status == New = do - secureSndQueue c sq + secureSndQueue c nm sq withStore' c $ \db -> setSndQueueStatus db sq Secured pure initiatorRatchetOnConf -- on repeat JOIN processing (e.g. previous attempt to create reply queue failed) @@ -3242,10 +3244,10 @@ agentSecureSndQueue c ConnData {connAgentVersion} sq@SndQueue {queueMode, status sndSecure = senderCanSecure queueMode initiatorRatchetOnConf = connAgentVersion >= ratchetOnConfSMPAgentVersion -mkAgentConfirmation :: AgentClient -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId) -mkAgentConfirmation c cData rq_ sq srv connInfo subMode = do +mkAgentConfirmation :: AgentClient -> NetworkRequestMode -> ConnData -> Maybe RcvQueue -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> AM (AgentMessage, Maybe ClientServiceId) +mkAgentConfirmation c nm cData rq_ sq srv connInfo subMode = do (qInfo, service) <- case rq_ of - Nothing -> createReplyQueue c cData sq subMode srv + Nothing -> createReplyQueue c nm cData sq subMode srv Just rq@RcvQueue {smpClientVersion = v, clientService} -> pure (SMPQueueInfo v $ rcvSMPQueueAddress rq, dbServiceId <$> clientService) pure (AgentConnInfoReply (qInfo :| []) connInfo, service) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index da1993524..b7850e50d 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -568,8 +568,9 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, presetDomai slowNetworkConfig :: NetworkConfig -> NetworkConfig slowNetworkConfig cfg@NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb} = - cfg {tcpConnectTimeout = slow tcpConnectTimeout, tcpTimeout = slow tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb} + cfg {tcpConnectTimeout = slowTimeout tcpConnectTimeout, tcpTimeout = slowTimeout tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb} where + slowTimeout (NetworkTimeout t1 t2) = NetworkTimeout (slow t1) (slow t2) slow :: Integral a => a -> a slow t = (t * 3) `div` 2 @@ -583,7 +584,7 @@ agentDRG AgentClient {agentEnv = Env {random}} = random class (Encoding err, Show err) => ProtocolServerClient v err msg | msg -> v, msg -> err where type Client msg = c | c -> msg - getProtocolServerClient :: AgentClient -> TransportSession msg -> AM (Client msg) + getProtocolServerClient :: AgentClient -> NetworkRequestMode -> TransportSession msg -> AM (Client msg) type ProtoClient msg = c | c -> msg protocolClient :: Client msg -> ProtoClient msg clientProtocolError :: HostName -> err -> AgentErrorType @@ -613,7 +614,7 @@ instance ProtocolServerClient NTFVersion ErrorType NtfResponse where instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where type Client FileResponse = XFTPClient - getProtocolServerClient = getXFTPServerClient + getProtocolServerClient c _ = getXFTPServerClient c type ProtoClient FileResponse = XFTPClient protocolClient = id clientProtocolError = XFTP @@ -621,19 +622,19 @@ instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where clientServer = X.xftpClientServer clientTransportHost = X.xftpTransportHost -getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient -getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do +getSMPServerClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> AM SMPConnectedClient +getSMPServerClient c@AgentClient {active, smpClients, workerSeq} nm tSess = do unlessM (readTVarIO active) $ throwE INACTIVE ts <- liftIO getCurrentTime atomically (getSessVar workerSeq tSess smpClients ts) - >>= either newClient (waitForProtocolClient c tSess smpClients) + >>= either newClient (waitForProtocolClient c nm tSess smpClients) where newClient v = do prs <- liftIO TM.emptyIO - smpConnectClient c tSess prs v + smpConnectClient c nm tSess prs v -getSMPProxyClient :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay) -getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} proxySrv_ destSess@(userId, destSrv, qId) = do +getSMPProxyClient :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay) +getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} nm proxySrv_ destSess@(userId, destSrv, qId) = do unlessM (readTVarIO active) $ throwE INACTIVE proxySrv <- maybe (getNextServer c userId proxySrvs [destSrv]) pure proxySrv_ ts <- liftIO getCurrentTime @@ -651,11 +652,11 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq -- we do not need to check if it is a new proxied relay session, -- as the client is just created and there are no sessions yet rv <- atomically $ either id id <$> getSessVar workerSeq destSrv prs ts - clnt <- smpConnectClient c tSess prs v + clnt <- smpConnectClient c nm tSess prs v (clnt,) <$> newProxiedRelay clnt auth rv waitForProxyClient :: SMPTransportSession -> Maybe SMP.BasicAuth -> SMPClientVar -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay) waitForProxyClient tSess auth v = do - clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c tSess smpClients v + clnt@(SMPConnectedClient _ prs) <- waitForProtocolClient c nm tSess smpClients v ts <- liftIO getCurrentTime sess <- atomically (getSessVar workerSeq destSrv prs ts) @@ -663,7 +664,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq pure (clnt, sess) newProxiedRelay :: SMPConnectedClient -> Maybe SMP.BasicAuth -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay) newProxiedRelay (SMPConnectedClient smp prs) proxyAuth rv = - tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp destSrv proxyAuth) >>= \case + tryAgentError (liftClient SMP (clientServer smp) $ connectSMPProxiedRelay smp nm destSrv proxyAuth) >>= \case Right sess -> do atomically $ putTMVar (sessionVar rv) (Right sess) pure $ Right sess @@ -677,14 +678,14 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq waitForProxiedRelay :: SMPTransportSession -> ProxiedRelayVar -> AM (Either AgentErrorType ProxiedRelay) waitForProxiedRelay (_, srv, _) rv = do NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c - sess_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar rv) + sess_ <- liftIO $ netTimeoutInt tcpConnectTimeout nm `timeout` atomically (readTMVar $ sessionVar rv) pure $ case sess_ of Just (Right sess) -> Right sess Just (Left e) -> Left e Nothing -> Left $ BROKER (B.unpack $ strEncode srv) TIMEOUT -smpConnectClient :: AgentClient -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient -smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) prs v = +smpConnectClient :: AgentClient -> NetworkRequestMode -> SMPTransportSession -> TMap SMPServer ProxiedRelayVar -> SMPClientVar -> AM SMPConnectedClient +smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} nm tSess@(_, srv, _) prs v = newProtocolClient c tSess smpClients connectClient v `catchAgentError` \e -> lift (resubscribeSMPSession c tSess) >> throwE e where @@ -695,7 +696,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs} tSess@(_, srv, _) env <- ask liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do ts <- readTVarIO proxySessTs - smp <- ExceptT $ getProtocolClient g tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs + smp <- ExceptT $ getProtocolClient g nm tSess cfg (presetSMPDomains c) (Just msgQ) ts $ smpClientDisconnected c tSess env v' prs pure SMPConnectedClient {connectedClient = smp, proxiedRelays = prs} smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO () @@ -783,14 +784,14 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> AM' () notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd) -getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient -getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tSess@(_, srv, _) = do +getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient +getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} nm tSess@(_, srv, _) = do unlessM (readTVarIO active) $ throwE INACTIVE ts <- liftIO getCurrentTime atomically (getSessVar workerSeq tSess ntfClients ts) >>= either (newProtocolClient c tSess ntfClients connectClient) - (waitForProtocolClient c tSess ntfClients) + (waitForProtocolClient c nm tSess ntfClients) where connectClient :: NtfClientVar -> AM NtfClient connectClient v = do @@ -798,7 +799,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs} tS g <- asks random ts <- readTVarIO proxySessTs liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $ - getProtocolClient g tSess cfg [] Nothing ts $ + getProtocolClient g nm tSess cfg [] Nothing ts $ clientDisconnected v clientDisconnected :: NtfClientVar -> NtfClient -> IO () @@ -814,7 +815,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} atomically (getSessVar workerSeq tSess xftpClients ts) >>= either (newProtocolClient c tSess xftpClients connectClient) - (waitForProtocolClient c tSess xftpClients) + (waitForProtocolClient c NRMBackground tSess xftpClients) where connectClient :: XFTPClientVar -> AM XFTPClient connectClient v = do @@ -834,13 +835,14 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs} waitForProtocolClient :: (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => AgentClient -> + NetworkRequestMode -> TransportSession msg -> TMap (TransportSession msg) (ClientVar msg) -> ClientVar msg -> AM (Client msg) -waitForProtocolClient c tSess@(_, srv, _) clients v = do +waitForProtocolClient c nm tSess@(_, srv, _) clients v = do NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c - client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) + client_ <- liftIO $ netTimeoutInt tcpConnectTimeout nm `timeout` atomically (readTMVar $ sessionVar v) case client_ of Just (Right smpClient) -> pure smpClient Just (Left (e, ts_)) -> case ts_ of @@ -848,7 +850,7 @@ waitForProtocolClient c tSess@(_, srv, _) clients v = do Just ts -> ifM ((ts <) <$> liftIO getCurrentTime) - (atomically (removeSessVar v tSess clients) >> getProtocolServerClient c tSess) + (atomically (removeSessVar v tSess clients) >> getProtocolServerClient c nm tSess) (throwE e) Nothing -> throwE $ BROKER (B.unpack $ strEncode srv) TIMEOUT @@ -979,7 +981,7 @@ closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg - closeClient_ c v = do NetworkConfig {tcpConnectTimeout} <- getNetworkConfig c E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $ - tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case + netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v) >>= \case Just (Right client) -> closeProtocolServerClient (protocolClient client) `catchAll_` pure () _ -> pure () @@ -1021,9 +1023,9 @@ 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 -> (Client msg -> AM a) -> AM a -withClient_ c tSess@(_, srv, _) action = do - cl <- getProtocolServerClient c tSess +withClient_ :: forall a v err msg. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> AM a) -> AM a +withClient_ c nm tSess@(_, srv, _) action = do + cl <- getProtocolServerClient c nm tSess action cl `catchAgentError` logServerError where logServerError :: AgentErrorType -> AM a @@ -1031,9 +1033,9 @@ withClient_ c tSess@(_, srv, _) action = do logServer "<--" c srv NoEntity $ bshow e throwE e -withProxySession :: AgentClient -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a -withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do - (cl, sess_) <- getSMPProxyClient c proxySrv_ destSess +withProxySession :: AgentClient -> NetworkRequestMode -> Maybe SMPServerWithAuth -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a +withProxySession c nm proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do + (cl, sess_) <- getSMPProxyClient c nm proxySrv_ destSess logServer ("--> " <> proxySrv cl <> " >") c destSrv entId cmdStr case sess_ of Right sess -> do @@ -1048,41 +1050,42 @@ withProxySession c proxySrv_ destSess@(_, destSrv, _) entId cmdStr action = do logServer ("<-- " <> proxySrv cl <> " <") c destSrv NoEntity $ bshow e throwE e -withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a -withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do +withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> AM a) -> AM a +withLogClient_ c nm tSess@(_, srv, _) entId cmdStr action = do logServer' "-->" c srv entId cmdStr - res <- withClient_ c tSess action + res <- withClient_ c nm tSess action logServer' "<--" c srv entId "OK" return res -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 +withClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a +withClient c nm tSess action = withClient_ c nm 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 -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a -withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client +withLogClient :: forall v err msg a. ProtocolServerClient v err msg => AgentClient -> NetworkRequestMode -> TransportSession msg -> ByteString -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> AM a +withLogClient c nm tSess entId cmdStr action = withLogClient_ c nm tSess entId cmdStr $ \client -> liftClient (clientProtocolError @v @err @msg) (clientServer $ protocolClient client) $ action client {-# INLINE withLogClient #-} -withSMPClient :: SMPQueueRec q => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a -withSMPClient c q cmdStr action = do +withSMPClient :: SMPQueueRec q => AgentClient -> NetworkRequestMode -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a +withSMPClient c nm q cmdStr action = do tSess <- mkSMPTransportSession c q - withLogClient c tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient + withLogClient c nm tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient -sendOrProxySMPMessage :: AgentClient -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) -sendOrProxySMPMessage c userId destSrv connId cmdStr spKey_ senderId msgFlags msg = - fst <$> sendOrProxySMPCommand c userId destSrv connId cmdStr senderId sendViaProxy sendDirectly +sendOrProxySMPMessage :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) +sendOrProxySMPMessage c nm userId destSrv connId cmdStr spKey_ senderId msgFlags msg = + fst <$> sendOrProxySMPCommand c nm userId destSrv connId 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 + proxySMPMessage smp nm proxySess spKey_ senderId msgFlags msg sendDirectly smp = do atomically $ incSMPServerStat c userId destSrv sentDirectAttempts - sendSMPMessage smp spKey_ senderId msgFlags msg + sendSMPMessage smp nm spKey_ senderId msgFlags msg sendOrProxySMPCommand :: forall a. AgentClient -> + NetworkRequestMode -> UserId -> SMPServer -> ConnId -> -- session entity ID, for short links LinkId is used @@ -1091,7 +1094,7 @@ sendOrProxySMPCommand :: (SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) -> (SMPClient -> ExceptT SMPClientError IO a) -> AM (Maybe SMPServer, a) -sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do +sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do tSess <- mkTransportSession c userId destSrv connId ifM shouldUseProxy (sendViaProxy Nothing tSess) ((Nothing,) <$> sendDirectly tSess) where @@ -1113,7 +1116,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c) sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer, a) sendViaProxy proxySrv_ destSess@(_, _, connId_) = do - r <- tryAgentError . withProxySession c proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do + r <- tryAgentError . withProxySession c nm proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess let proxySrv = protocolClientServer' smp case r' of @@ -1159,7 +1162,7 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId | serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e) | otherwise -> throwE e sendDirectly tSess = - withLogClient_ c tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do + withLogClient_ c nm tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do tryAgentError (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case Right r -> r <$ atomically (incSMPServerStat c userId destSrv sentDirect) Left e -> throwE e @@ -1170,8 +1173,8 @@ ipAddressProtected NetworkConfig {socksProxy, hostMode} (ProtocolServer _ hosts where isOnionHost = \case THOnionHost _ -> True; _ -> False -withNtfClient :: AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a -withNtfClient c srv (EntityId entId) = withLogClient c (0, srv, Nothing) entId +withNtfClient :: AgentClient -> NetworkRequestMode -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a +withNtfClient c nm srv (EntityId entId) = withLogClient c nm (0, srv, Nothing) entId withXFTPClient :: ProtocolServerClient v err msg => @@ -1182,7 +1185,7 @@ withXFTPClient :: AM b withXFTPClient c (userId, srv, sessEntId) cmdStr action = do tSess <- mkTransportSession c userId srv sessEntId - withLogClient c tSess sessEntId cmdStr action + withLogClient c NRMBackground tSess sessEntId cmdStr action liftClient :: (Show err, Encoding err) => (HostName -> err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> AM a liftClient protocolError_ = liftError . protocolClientError protocolError_ @@ -1222,8 +1225,8 @@ data ProtocolTestFailure = ProtocolTestFailure } deriving (Eq, Show) -runSMPServerTest :: AgentClient -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure) -runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do +runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure) +runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg C.AuthAlg ra <- asks $ rcvAuthAlg . config C.AuthAlg sa <- asks $ sndAuthAlg . config @@ -1231,20 +1234,20 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do liftIO $ do let tSess = (userId, srv, Nothing) ts <- readTVarIO $ proxySessTs c - getProtocolClient g tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case + getProtocolClient g nm tSess cfg (presetSMPDomains c) Nothing ts (\_ -> pure ()) >>= \case Right smp -> do rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g (sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do -- TODO [notifications] - SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) -- Nothing + SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp nm Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) -- Nothing liftError (testErr TSSecureQueue) $ case queueMode of - Just QMMessaging -> secureSndSMPQueue smp spKey sndId sKey - _ -> secureSMPQueue smp rpKey rcvId sKey - liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId - ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp + Just QMMessaging -> secureSndSMPQueue smp nm spKey sndId sKey + _ -> secureSMPQueue smp nm rpKey rcvId sKey + liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp nm rpKey rcvId + ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient smp pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1252,8 +1255,8 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure testErr step = ProtocolTestFailure step . protocolClientError SMP addr -runXFTPServerTest :: AgentClient -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure) -runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do +runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure) +runXFTPServerTest c nm userId (ProtoServerWithAuth srv auth) = do cfg <- asks $ xftpCfg . config g <- asks random xftpNetworkConfig <- getNetworkConfig c @@ -1277,7 +1280,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath 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 + ok <- netTimeoutInt (tcpTimeout xftpNetworkConfig) nm `timeout` X.closeXFTPClient xftp pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1300,23 +1303,23 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do createTestChunk :: FilePath -> IO () createTestChunk fp = B.writeFile fp =<< atomically . C.randomBytes chSize =<< C.newRandom -runNTFServerTest :: AgentClient -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure) -runNTFServerTest c userId (ProtoServerWithAuth srv _) = do +runNTFServerTest :: AgentClient -> NetworkRequestMode -> UserId -> NtfServerWithAuth -> AM' (Maybe ProtocolTestFailure) +runNTFServerTest c nm userId (ProtoServerWithAuth srv _) = do cfg <- getClientConfig c ntfCfg C.AuthAlg a <- asks $ rcvAuthAlg . config g <- asks random liftIO $ do let tSess = (userId, srv, Nothing) ts <- readTVarIO $ proxySessTs c - getProtocolClient g tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case + getProtocolClient g nm tSess cfg [] Nothing ts (\_ -> pure ()) >>= \case Right ntf -> do (nKey, npKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do let deviceToken = DeviceToken PPApnsNull "test_ntf_token" - (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 + (tknId, _) <- liftError (testErr TSCreateNtfToken) $ ntfRegisterToken ntf nm npKey (NewNtfTkn deviceToken nKey dhKey) + liftError (testErr TSDeleteNtfToken) $ ntfDeleteToken ntf nm npKey tknId + ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient ntf pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok Left e -> pure (Just $ testErr TSConnect e) where @@ -1350,11 +1353,11 @@ getSessionMode = fmap sessionMode . getNetworkConfig {-# INLINE getSessionMode #-} -- TODO [notifications] -newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) -newRcvQueue c userId connId srv vRange cMode subMode = do +newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue c nm userId connId srv vRange cMode subMode = do let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing e2eKeys <- atomically . C.generateKeyPair =<< asks random - newRcvQueue_ c userId connId srv vRange qrd subMode Nothing e2eKeys + newRcvQueue_ c nm userId connId srv vRange qrd subMode Nothing e2eKeys data ClntQueueReqData = CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData))) @@ -1371,8 +1374,8 @@ queueReqData = \case CQRMessaging d -> QRMessaging $ srvReq <$> d CQRContact d -> QRContact $ srvReq <$> d -newRcvQueue_ :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) -newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode nonce_ (e2eDhKey, e2ePrivKey) = do +newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId) +newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode nonce_ (e2eDhKey, e2ePrivKey) = do C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g @@ -1381,8 +1384,8 @@ newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode tSess <- mkTransportSession c userId srv connId -- TODO [notifications] r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serviceId}) <- - withClient c tSess $ \(SMPConnectedClient smp _) -> - (thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd) + withClient c nm tSess $ \(SMPConnectedClient smp _) -> + (thParams smp,) <$> createSMPQueue smp nm nonce_ rKeys dhKey auth subMode (queueReqData cqrd) -- TODO [certs rcv] validate that serviceId is the same as in the client session liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] shortLink <- mkShortLinkCreds r @@ -1493,7 +1496,7 @@ subscribeQueues c qs = do env <- ask -- only "checked" queues are subscribed session <- newTVarIO Nothing - rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c qs' + rs <- sendTSessionBatches "SUB" id (subscribeQueues_ env session) c NRMBackground qs' (errs <> rs,) <$> readTVarIO session where checkQueue rq = do @@ -1503,7 +1506,7 @@ subscribeQueues c qs = do subscribeQueues_ env session smp qs' = do let (userId, srv, _) = transportSession' smp atomically $ incSMPServerStat' c userId srv connSubAttempts $ length qs' - rs <- sendBatch subscribeSMPQueues smp qs' + rs <- sendBatch (\smp' _ -> subscribeSMPQueues smp') smp NRMBackground qs' active <- atomically $ ifM @@ -1534,8 +1537,8 @@ type BatchResponses q e r = NonEmpty (q, Either e r) -- Please note: this function does not preserve order of results to be the same as the order of arguments, -- it includes arguments in the results instead. -sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> [q] -> AM' [(q, Either AgentErrorType r)] -sendTSessionBatches statCmd toRQ action c qs = +sendTSessionBatches :: forall q r. ByteString -> (q -> RcvQueue) -> (SMPClient -> NonEmpty q -> IO (BatchResponses q SMPClientError r)) -> AgentClient -> NetworkRequestMode -> [q] -> AM' [(q, Either AgentErrorType r)] +sendTSessionBatches statCmd toRQ action c nm qs = concatMap L.toList <$> (mapConcurrently sendClientBatch =<< batchQueues) where batchQueues :: AM' [(SMPTransportSession, NonEmpty q)] @@ -1548,7 +1551,7 @@ sendTSessionBatches statCmd toRQ action c qs = in M.alter (Just . maybe [q] (q <|)) tSess m sendClientBatch :: (SMPTransportSession, NonEmpty q) -> AM' (BatchResponses q AgentErrorType r) sendClientBatch (tSess@(_, srv, _), qs') = - tryAgentError' (getSMPServerClient c tSess) >>= \case + tryAgentError' (getSMPServerClient c nm tSess) >>= \case Left e -> pure $ L.map (,Left e) qs' Right (SMPConnectedClient smp _) -> liftIO $ do logServer' "-->" c srv (bshow (length qs') <> " queues") statCmd @@ -1556,8 +1559,8 @@ sendTSessionBatches statCmd toRQ action c qs = where agentError = second . first $ protocolClientError SMP $ clientServer smp -sendBatch :: (SMPClient -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a) -sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs) +sendBatch :: (SMPClient -> NetworkRequestMode -> NonEmpty (SMP.RecipientId, SMP.RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError a))) -> SMPClient -> NetworkRequestMode -> NonEmpty RcvQueue -> IO (BatchResponses RcvQueue SMPClientError a) +sendBatch smpCmdFunc smp nm qs = L.zip qs <$> smpCmdFunc smp nm (L.map queueCreds qs) where queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvId, rcvPrivateKey) @@ -1626,18 +1629,18 @@ logSecret' :: ByteString -> ByteString logSecret' = B64.encode . B.take 3 {-# INLINE logSecret' #-} -sendConfirmation :: AgentClient -> SndQueue -> ByteString -> AM (Maybe SMPServer) -sendConfirmation c sq@SndQueue {userId, server, connId, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do +sendConfirmation :: AgentClient -> NetworkRequestMode -> SndQueue -> ByteString -> AM (Maybe SMPServer) +sendConfirmation c nm sq@SndQueue {userId, server, connId, sndId, queueMode, sndPublicKey, sndPrivateKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation = do let (privHdr, spKey) = if senderCanSecure queueMode 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 connId "" spKey sndId (MsgFlags {notification = True}) msg -sendConfirmation _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" + sendOrProxySMPMessage c nm userId server connId "" spKey sndId (MsgFlags {notification = True}) msg +sendConfirmation _ _ _ _ = throwE $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database" -sendInvitation :: AgentClient -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer) -sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do +sendInvitation :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Compatible SMPQueueInfo -> Compatible VersionSMPA -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM (Maybe SMPServer) +sendInvitation c nm userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer, senderId, dhPublicKey})) (Compatible agentVersion) connReq connInfo = do msg <- mkInvitation - sendOrProxySMPMessage c userId smpServer connId "" Nothing senderId (MsgFlags {notification = True}) msg + sendOrProxySMPMessage c nm userId smpServer connId "" Nothing senderId (MsgFlags {notification = True}) msg where mkInvitation :: AM ByteString -- this is only encrypted with per-queue E2E, not with double ratchet @@ -1649,7 +1652,7 @@ sendInvitation c userId connId (Compatible (SMPQueueInfo v SMPQueueAddress {smpS getQueueMessage :: AgentClient -> RcvQueue -> AM (Maybe SMPMsgMeta) getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do atomically createTakeGetLock - msg_ <- withSMPClient c rq "GET" $ \smp -> + msg_ <- withSMPClient c NRMInteractive rq "GET" $ \smp -> getSMPMessage smp rcvPrivateKey rcvId mapM decryptMeta msg_ where @@ -1668,44 +1671,44 @@ decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} = where decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId) -secureQueue :: AgentClient -> RcvQueue -> SndPublicAuthKey -> AM () -secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = - withSMPClient c rq "KEY " $ \smp -> - secureSMPQueue smp rcvPrivateKey rcvId senderKey +secureQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> SndPublicAuthKey -> AM () +secureQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = + withSMPClient c nm rq "KEY " $ \smp -> + secureSMPQueue smp nm rcvPrivateKey rcvId senderKey -secureSndQueue :: AgentClient -> SndQueue -> AM () -secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} = - void $ sendOrProxySMPCommand c userId server connId "SKEY " sndId secureViaProxy secureDirectly +secureSndQueue :: AgentClient -> NetworkRequestMode -> SndQueue -> AM () +secureSndQueue c nm SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPublicKey} = + void $ sendOrProxySMPCommand c nm userId server connId "SKEY " sndId secureViaProxy secureDirectly where -- TODO track statistics - secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey - secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey + secureViaProxy smp proxySess = proxySecureSndSMPQueue smp nm proxySess sndPrivateKey sndId sndPublicKey + secureDirectly smp = secureSndSMPQueue smp nm sndPrivateKey sndId sndPublicKey -addQueueLink :: AgentClient -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM () -addQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d = - withSMPClient c rq "LSET" $ \smp -> addSMPQueueLink smp rcvPrivateKey rcvId lnkId d +addQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM () +addQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d = + withSMPClient c nm rq "LSET" $ \smp -> addSMPQueueLink smp nm rcvPrivateKey rcvId lnkId d -deleteQueueLink :: AgentClient -> RcvQueue -> AM () -deleteQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} = - withSMPClient c rq "LDEL" $ \smp -> deleteSMPQueueLink smp rcvPrivateKey rcvId +deleteQueueLink :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM () +deleteQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} = + withSMPClient c nm rq "LDEL" $ \smp -> deleteSMPQueueLink smp nm rcvPrivateKey rcvId -secureGetQueueLink :: AgentClient -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData) -secureGetQueueLink c userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} = - snd <$> sendOrProxySMPCommand c userId server (unEntityId linkId) "LKEY " linkId secureGetViaProxy secureGetDirectly +secureGetQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData) +secureGetQueueLink c nm userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} = + snd <$> sendOrProxySMPCommand c nm userId server (unEntityId linkId) "LKEY " linkId secureGetViaProxy secureGetDirectly where - secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp proxySess sndPrivateKey linkId sndPublicKey - secureGetDirectly smp = secureGetSMPQueueLink smp sndPrivateKey linkId sndPublicKey + secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp nm proxySess sndPrivateKey linkId sndPublicKey + secureGetDirectly smp = secureGetSMPQueueLink smp nm sndPrivateKey linkId sndPublicKey -getQueueLink :: AgentClient -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData) -getQueueLink c userId server lnkId = - snd <$> sendOrProxySMPCommand c userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly +getQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData) +getQueueLink c nm userId server lnkId = + snd <$> sendOrProxySMPCommand c nm userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly where - getViaProxy smp proxySess = proxyGetSMPQueueLink smp proxySess lnkId - getDirectly smp = getSMPQueueLink smp lnkId + getViaProxy smp proxySess = proxyGetSMPQueueLink smp nm proxySess lnkId + getDirectly smp = getSMPQueueLink smp nm lnkId 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 -> + withSMPClient c NRMBackground rq "NKEY " $ \smp -> enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey data EnableQueueNtfReq = EnableQueueNtfReq @@ -1716,7 +1719,7 @@ data EnableQueueNtfReq = EnableQueueNtfReq } enableQueuesNtfs :: AgentClient -> [EnableQueueNtfReq] -> AM' [(EnableQueueNtfReq, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))] -enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_ +enableQueuesNtfs c = sendTSessionBatches "NKEY" eqnrRq enableQueues_ c NRMBackground where enableQueues_ :: SMPClient -> NonEmpty EnableQueueNtfReq -> IO (NonEmpty (EnableQueueNtfReq, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey))) enableQueues_ smp qs' = L.zip qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs') @@ -1729,13 +1732,13 @@ enableQueuesNtfs = sendTSessionBatches "NKEY" eqnrRq enableQueues_ disableQueueNotifications :: AgentClient -> RcvQueue -> AM () disableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} = - withSMPClient c rq "NDEL" $ \smp -> + withSMPClient c NRMBackground rq "NDEL" $ \smp -> disableSMPQueueNotifications smp rcvPrivateKey rcvId type DisableQueueNtfReq = (NtfSubscription, RcvQueue) disableQueuesNtfs :: AgentClient -> [DisableQueueNtfReq] -> AM' [(DisableQueueNtfReq, Either AgentErrorType ())] -disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_ +disableQueuesNtfs c = sendTSessionBatches "NDEL" snd disableQueues_ c NRMBackground where disableQueues_ :: SMPClient -> NonEmpty DisableQueueNtfReq -> IO (NonEmpty (DisableQueueNtfReq, Either (ProtocolClientError ErrorType) ())) disableQueues_ smp qs' = L.zip qs' <$> disableSMPQueuesNtfs smp (L.map queueCreds qs') @@ -1744,7 +1747,7 @@ disableQueuesNtfs = sendTSessionBatches "NDEL" snd disableQueues_ sendAck :: AgentClient -> RcvQueue -> MsgId -> AM () sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = - withSMPClient c rq ("ACK:" <> logSecret' msgId) $ \smp -> + withSMPClient c NRMBackground rq ("ACK:" <> logSecret' msgId) $ \smp -> ackSMPMessage smp rcvPrivateKey rcvId msgId hasGetLock :: AgentClient -> RcvQueue -> IO Bool @@ -1757,32 +1760,33 @@ releaseGetLock c RcvQueue {server, rcvId} = TM.lookup (server, rcvId) (getMsgLocks c) >>= mapM_ (`tryPutTMVar` ()) {-# INLINE releaseGetLock #-} -suspendQueue :: AgentClient -> RcvQueue -> AM () -suspendQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = - withSMPClient c rq "OFF" $ \smp -> - suspendSMPQueue smp rcvPrivateKey rcvId +suspendQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM () +suspendQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} = + withSMPClient c nm rq "OFF" $ \smp -> + suspendSMPQueue smp nm rcvPrivateKey rcvId -deleteQueue :: AgentClient -> RcvQueue -> AM () -deleteQueue c rq@RcvQueue {rcvId, rcvPrivateKey} = do - withSMPClient c rq "DEL" $ \smp -> - deleteSMPQueue smp rcvPrivateKey rcvId +deleteQueue :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM () +deleteQueue c nm rq@RcvQueue {rcvId, rcvPrivateKey} = do + withSMPClient c nm rq "DEL" $ \smp -> + deleteSMPQueue smp nm rcvPrivateKey rcvId -deleteQueues :: AgentClient -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())] -deleteQueues c = sendTSessionBatches "DEL" id deleteQueues_ c +deleteQueues :: AgentClient -> NetworkRequestMode -> [RcvQueue] -> AM' [(RcvQueue, Either AgentErrorType ())] +deleteQueues c nm = sendTSessionBatches "DEL" id deleteQueues_ c nm where deleteQueues_ smp rqs = do let (userId, srv, _) = transportSession' smp atomically $ incSMPServerStat' c userId srv connDelAttempts $ length rqs - rs <- sendBatch deleteSMPQueues smp rqs + rs <- sendBatch deleteSMPQueues smp nm 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 +-- This is only used in background sendAgentMessage :: AgentClient -> SndQueue -> MsgFlags -> ByteString -> AM (Maybe SMPServer) sendAgentMessage c sq@SndQueue {userId, server, connId, sndId, sndPrivateKey} msgFlags agentMsg = do let clientMsg = SMP.ClientMessage SMP.PHEmpty agentMsg msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg - sendOrProxySMPMessage c userId server connId "" (Just sndPrivateKey) sndId msgFlags msg + sendOrProxySMPMessage c NRMBackground userId server connId "" (Just sndPrivateKey) sndId msgFlags msg data ServerQueueInfo = ServerQueueInfo { server :: SMPServer, @@ -1794,50 +1798,50 @@ data ServerQueueInfo = ServerQueueInfo } 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 +getQueueInfo :: AgentClient -> NetworkRequestMode -> RcvQueue -> AM ServerQueueInfo +getQueueInfo c nm rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clientNtfCreds} = + withSMPClient c nm rq "QUE" $ \smp -> do + info <- getSMPQueueInfo smp nm 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 . unEntityId -agentNtfRegisterToken :: AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519) -agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = - withClient c (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) +agentNtfRegisterToken :: AgentClient -> NetworkRequestMode -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519) +agentNtfRegisterToken c nm NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = + withClient c nm (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf nm ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) -agentNtfVerifyToken :: AgentClient -> NtfTokenId -> NtfToken -> NtfRegCode -> AM () -agentNtfVerifyToken c tknId NtfToken {ntfServer, ntfPrivKey} code = - withNtfClient c ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf ntfPrivKey tknId code +agentNtfVerifyToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> NtfRegCode -> AM () +agentNtfVerifyToken c nm tknId NtfToken {ntfServer, ntfPrivKey} code = + withNtfClient c nm ntfServer tknId "TVFY" $ \ntf -> ntfVerifyToken ntf nm ntfPrivKey tknId code -agentNtfCheckToken :: AgentClient -> NtfTokenId -> NtfToken -> AM NtfTknStatus -agentNtfCheckToken c tknId NtfToken {ntfServer, ntfPrivKey} = - withNtfClient c ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf ntfPrivKey tknId +agentNtfCheckToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> AM NtfTknStatus +agentNtfCheckToken c nm tknId NtfToken {ntfServer, ntfPrivKey} = + withNtfClient c nm ntfServer tknId "TCHK" $ \ntf -> ntfCheckToken ntf nm ntfPrivKey tknId -agentNtfReplaceToken :: AgentClient -> NtfTokenId -> NtfToken -> DeviceToken -> AM () -agentNtfReplaceToken c tknId NtfToken {ntfServer, ntfPrivKey} token = - withNtfClient c ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf ntfPrivKey tknId token +agentNtfReplaceToken :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> DeviceToken -> AM () +agentNtfReplaceToken c nm tknId NtfToken {ntfServer, ntfPrivKey} token = + withNtfClient c nm ntfServer tknId "TRPL" $ \ntf -> ntfReplaceToken ntf nm ntfPrivKey tknId token -agentNtfDeleteToken :: AgentClient -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM () -agentNtfDeleteToken c ntfServer ntfPrivKey tknId = - withNtfClient c ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf ntfPrivKey tknId +agentNtfDeleteToken :: AgentClient -> NetworkRequestMode -> NtfServer -> C.APrivateAuthKey -> NtfTokenId -> AM () +agentNtfDeleteToken c nm ntfServer ntfPrivKey tknId = + withNtfClient c nm ntfServer tknId "TDEL" $ \ntf -> ntfDeleteToken ntf nm ntfPrivKey tknId -- set to 0 to disable -agentNtfSetCronInterval :: AgentClient -> NtfTokenId -> NtfToken -> Word16 -> AM () -agentNtfSetCronInterval c tknId NtfToken {ntfServer, ntfPrivKey} interval = - withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf ntfPrivKey tknId interval +agentNtfSetCronInterval :: AgentClient -> NetworkRequestMode -> NtfTokenId -> NtfToken -> Word16 -> AM () +agentNtfSetCronInterval c nm tknId NtfToken {ntfServer, ntfPrivKey} interval = + withNtfClient c nm ntfServer tknId "TCRN" $ \ntf -> ntfSetCronInterval ntf nm ntfPrivKey tknId interval agentNtfCreateSubscription :: AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> AM NtfSubscriptionId agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey = - withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey) + withNtfClient c NRMBackground ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey) agentNtfCreateSubscriptions :: AgentClient -> NtfToken -> NonEmpty (NewNtfEntity 'Subscription) -> AM' (NonEmpty (Either AgentErrorType NtfSubscriptionId)) agentNtfCreateSubscriptions = withNtfBatch "SNEW" ntfCreateSubscriptions agentNtfCheckSubscription :: AgentClient -> NtfToken -> NtfSubscriptionId -> AM NtfSubStatus agentNtfCheckSubscription c NtfToken {ntfServer, ntfPrivKey} subId = - withNtfClient c ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId + withNtfClient c NRMBackground ntfServer subId "SCHK" $ \ntf -> ntfCheckSubscription ntf ntfPrivKey subId agentNtfCheckSubscriptions :: AgentClient -> NtfToken -> NonEmpty NtfSubscriptionId -> AM' (NonEmpty (Either AgentErrorType NtfSubStatus)) agentNtfCheckSubscriptions = withNtfBatch "SCHK" ntfCheckSubscriptions @@ -1852,7 +1856,7 @@ withNtfBatch :: AM' (NonEmpty (Either AgentErrorType r)) withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do let tSess = (0, ntfServer, Nothing) - tryAgentError' (getNtfServerClient c tSess) >>= \case + tryAgentError' (getNtfServerClient c NRMBackground tSess) >>= \case Left e -> pure $ L.map (\_ -> Left e) subs Right ntf -> liftIO $ do logServer' "-->" c ntfServer (bshow (length subs) <> " subscriptions") cmdStr @@ -1862,7 +1866,7 @@ withNtfBatch cmdStr action c NtfToken {ntfServer, ntfPrivKey} subs = do agentNtfDeleteSubscription :: AgentClient -> NtfSubscriptionId -> NtfToken -> AM () agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} = - withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId + withNtfClient c NRMBackground ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId agentXFTPDownloadChunk :: AgentClient -> UserId -> FileDigest -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> AM () agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = do @@ -1876,7 +1880,7 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest - (sndId, rIds) <- withClient c tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth + (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 3da1b74b6..e31ddfba9 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -45,6 +45,7 @@ import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.AgentStore import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Client (NetworkRequestMode (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Types @@ -572,7 +573,7 @@ runNtfTknDelWorker c srv Worker {doWork} = notifyInternalError' c (show e) processTknToDelete :: NtfTokenToDelete -> AM () processTknToDelete (tknDbId, ntfPrivKey, tknId) = do - agentNtfDeleteToken c srv ntfPrivKey tknId + agentNtfDeleteToken c NRMBackground srv ntfPrivKey tknId withStore' c $ \db -> deleteNtfTokenToDelete db tknDbId closeNtfSupervisor :: NtfSupervisor -> IO () diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 16b1169d4..4290aa2e7 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -8,6 +8,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -81,12 +82,16 @@ module Simplex.Messaging.Client unexpectedResponse, ProtocolClientConfig (..), NetworkConfig (..), + NetworkTimeout (..), + NetworkRequestMode (..), + pattern NRMInteractive, TransportSessionMode (..), HostMode (..), SocksMode (..), SMPProxyMode (..), SMPProxyFallback (..), SMPWebPortServers (..), + netTimeoutInt, defaultClientConfig, defaultSMPClientConfig, defaultNetworkConfig, @@ -154,7 +159,7 @@ import Simplex.Messaging.Server.QueueStore.QueueInfo import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport -import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, defaultTcpConnectTimeout, runTransportClient) +import Simplex.Messaging.Transport.Client (SocksAuth (..), SocksProxyWithAuth (..), TransportClientConfig (..), TransportHost (..), defaultSMPPort, runTransportClient) import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Util import Simplex.Messaging.Version @@ -175,8 +180,8 @@ data PClient v err msg = PClient { connected :: TVar Bool, transportSession :: TransportSession msg, transportHost :: TransportHost, - tcpConnectTimeout :: Int, - tcpTimeout :: Int, + tcpConnectTimeout :: NetworkTimeout, + tcpTimeout :: NetworkTimeout, sendPings :: TVar Bool, lastReceived :: TVar UTCTime, timeoutErrorCount :: TVar Int, @@ -198,6 +203,7 @@ smpClientStub g sessionId thVersion thAuth = do timeoutErrorCount <- newTVarIO 0 sndQ <- newTBQueueIO 100 rcvQ <- newTBQueueIO 100 + let NetworkConfig {tcpConnectTimeout, tcpTimeout} = defaultNetworkConfig return ProtocolClient { action = Nothing, @@ -219,8 +225,8 @@ smpClientStub g sessionId thVersion thAuth = do { connected, transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing), transportHost = "localhost", - tcpConnectTimeout = 20_000_000, - tcpTimeout = 15_000_000, + tcpConnectTimeout, + tcpTimeout, sendPings, lastReceived, timeoutErrorCount, @@ -298,9 +304,9 @@ data NetworkConfig = NetworkConfig -- | use web port 443 for SMP protocol smpWebPortServers :: SMPWebPortServers, -- | timeout for the initial client TCP/TLS connection (microseconds) - tcpConnectTimeout :: Int, + tcpConnectTimeout :: NetworkTimeout, -- | timeout of protocol commands (microseconds) - tcpTimeout :: Int, + tcpTimeout :: NetworkTimeout, -- | additional timeout per kilobyte (1024 bytes) to be sent tcpTimeoutPerKb :: Int64, -- | break response timeouts into groups, so later responses get later deadlines @@ -315,6 +321,28 @@ data NetworkConfig = NetworkConfig } deriving (Eq, Show) +data NetworkTimeout = NetworkTimeout {backgroundTimeout :: Int, interactiveTimeout :: Int} + deriving (Eq, Show) + +data NetworkRequestMode + = NRMBackground + | NRMInteractive' {retryCount :: Int} + +pattern NRMInteractive :: NetworkRequestMode +pattern NRMInteractive = NRMInteractive' 0 + +netTimeoutInt :: NetworkTimeout -> NetworkRequestMode -> Int +netTimeoutInt NetworkTimeout {backgroundTimeout, interactiveTimeout} = \case + NRMBackground -> backgroundTimeout + NRMInteractive' n + | n <= 0 -> interactiveTimeout + | otherwise -> + let (m, d) + | n == 1 = (3, 2) + | n == 2 = (9, 4) + | otherwise = (27, 8) + in (interactiveTimeout * m) `div` d + data TransportSessionMode = TSMUser | TSMSession | TSMServer | TSMEntity deriving (Eq, Show) @@ -387,8 +415,8 @@ defaultNetworkConfig = smpProxyMode = SPMNever, smpProxyFallback = SPFAllow, smpWebPortServers = SWPPreset, - tcpConnectTimeout = defaultTcpConnectTimeout, - tcpTimeout = 15_000_000, + tcpConnectTimeout = NetworkTimeout {backgroundTimeout = 45_000000, interactiveTimeout = 15_000000}, + tcpTimeout = NetworkTimeout {backgroundTimeout = 30_000000, interactiveTimeout = 10_000000}, tcpTimeoutPerKb = 5_000, rcvConcurrency = 8, tcpKeepAlive = Just defaultKeepAliveOpts, @@ -397,10 +425,11 @@ defaultNetworkConfig = logTLSErrors = False } -transportClientConfig :: NetworkConfig -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig -transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} host useSNI clientALPN = - TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI} +transportClientConfig :: NetworkConfig -> NetworkRequestMode -> TransportHost -> Bool -> Maybe [ALPN] -> TransportClientConfig +transportClientConfig NetworkConfig {socksProxy, socksMode, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} nm host useSNI clientALPN = + TransportClientConfig {socksProxy = useSocksProxy socksMode, tcpConnectTimeout = tOut, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, clientALPN, useSNI} where + tOut = netTimeoutInt tcpConnectTimeout nm socksProxy' = (\(SocksProxyWithAuth _ proxy) -> proxy) <$> socksProxy useSocksProxy SMAlways = socksProxy' useSocksProxy SMOnion = case host of @@ -523,8 +552,8 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe ByteString) -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) -getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do +getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) +getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost) @@ -562,12 +591,12 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg)) runClient (port', ATransport t) useHost c = do cVar <- newEmptyTMVarIO - let tcConfig = (transportClientConfig networkConfig useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials} + let tcConfig = (transportClientConfig networkConfig nm useHost useSNI clientALPN) {clientCredentials = serviceCreds <$> serviceCredentials} socksCreds = clientSocksCredentials networkConfig proxySessTs transportSession tId <- runTransportClient tcConfig socksCreds useHost port' (Just $ keyHash srv) (client t c cVar) `forkFinally` \_ -> void (atomically . tryPutTMVar cVar $ Left PCENetworkError) - c_ <- tcpConnectTimeout `timeout` atomically (takeTMVar cVar) + c_ <- netTimeoutInt tcpConnectTimeout nm `timeout` atomically (takeTMVar cVar) case c_ of Just (Right c') -> mkWeakThreadId tId >>= \tId' -> pure $ Right c' {action = Just tId'} Just (Left e) -> pure $ Left e @@ -631,7 +660,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize if remaining > 1_000_000 -- delay pings only for significant time then loop remaining else do - whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing NoEntity (protocolPing @v @err @msg) + whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c NRMBackground Nothing NoEntity (protocolPing @v @err @msg) -- sendProtocolCommand/getResponse updates counter for each command cnt <- readTVarIO timeoutErrorCount -- drop client when maxCnt of commands have timed out in sequence, but only after some time has passed after last received response @@ -757,6 +786,7 @@ smpProxyError = \case -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command createSMPQueue :: SMPClient -> + NetworkRequestMode -> Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair RcvPublicDhKey -> @@ -766,29 +796,32 @@ createSMPQueue :: -- TODO [notifications] -- Maybe NewNtfCreds -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd = - sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case +createSMPQueue c nm nonce_ (rKey, rpKey) dhKey auth subMode qrd = + sendProtocolCommand_ c nm nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case IDS qik -> pure qik r -> throwE $ unexpectedResponse r -- | Subscribe to the SMP queue. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue +-- This command is always sent in background request mode subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe ServiceId) subscribeSMPQueue c rpKey rId = do liftIO $ enablePings c - sendSMPCommand c (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except + sendSMPCommand c NRMBackground (Just rpKey) rId SUB >>= liftIO . processSUBResponse_ c rId >>= except -- | Subscribe to multiple SMP queues batching commands if supported. +-- This command is always sent in background request mode subscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId))) subscribeSMPQueues c qs = do liftIO $ enablePings c - sendProtocolCommands c cs >>= mapM (processSUBResponse c) + sendProtocolCommands c NRMBackground cs >>= mapM (processSUBResponse c) where cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs +-- This command is always sent in background request mode streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> ([(RecipientId, Either SMPClientError (Maybe ServiceId))] -> IO ()) -> IO () -streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb +streamSubscribeSMPQueues c qs cb = streamProtocolCommands c NRMBackground cs $ mapM process >=> cb where cs = L.map (\(rId, rpKey) -> (rId, Just rpKey, Cmd SRecipient SUB)) qs process r@(Response rId _) = (rId,) <$> processSUBResponse c r @@ -813,9 +846,10 @@ serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionI -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue -- -- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue +-- This command is always sent in interactive request mode, as NSE has limited time getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage) getSMPMessage c rpKey rId = - sendSMPCommand c (Just rpKey) rId GET >>= \case + sendSMPCommand c NRMInteractive (Just rpKey) rId GET >>= \case OK -> pure Nothing cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg r -> throwE $ unexpectedResponse r @@ -824,16 +858,18 @@ getSMPMessage c rpKey rId = -- | Subscribe to the SMP queue notifications. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications +-- This command is always sent in background request mode subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO (Maybe ServiceId) subscribeSMPQueueNotifications c npKey nId = do liftIO $ enablePings c - sendSMPCommand c (Just npKey) nId NSUB >>= except . nsubResponse_ + sendSMPCommand c NRMBackground (Just npKey) nId NSUB >>= except . nsubResponse_ -- | Subscribe to multiple SMP queues notifications batching commands if supported. +-- This command is always sent in background request mode subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError (Maybe ServiceId))) subscribeSMPQueuesNtfs c qs = do liftIO $ enablePings c - L.map nsubResponse <$> sendProtocolCommands c cs + L.map nsubResponse <$> sendProtocolCommands c NRMBackground cs where cs = L.map (\(nId, npKey) -> (nId, Just npKey, Cmd SNotifier NSUB)) qs @@ -848,11 +884,12 @@ nsubResponse_ = \case r' -> Left $ unexpectedResponse r' {-# INLINE nsubResponse_ #-} +-- This command is always sent in background request mode subscribeService :: forall p. (PartyI p, ServiceParty p) => SMPClient -> SParty p -> ExceptT SMPClientError IO Int64 subscribeService c party = case smpClientService c of Just THClientService {serviceId, serviceKey} -> do liftIO $ enablePings c - sendSMPCommand c (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case + sendSMPCommand c NRMBackground (Just (C.APrivateAuthKey C.SEd25519 serviceKey)) serviceId subCmd >>= \case SOKS n -> pure n r -> throwE $ unexpectedResponse r where @@ -873,53 +910,54 @@ enablePings ProtocolClient {client_ = PClient {sendPings}} = atomically $ writeT -- | Secure the SMP queue by adding a sender public key. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command -secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO () -secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId +secureSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO () +secureSMPQueue c nm rpKey rId senderKey = okSMPCommand (KEY senderKey) c nm 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 +secureSndSMPQueue :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO () +secureSndSMPQueue c nm spKey sId senderKey = okSMPCommand (SKEY senderKey) c nm spKey sId {-# INLINE secureSndSMPQueue #-} -proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ()) -proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxyOKSMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey) +proxySecureSndSMPQueue :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxySecureSndSMPQueue c nm proxiedRelay spKey sId senderKey = proxyOKSMPCommand c nm proxiedRelay (Just spKey) sId (SKEY senderKey) {-# INLINE proxySecureSndSMPQueue #-} -- | Add or update date for queue link -addSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO () -addSMPQueueLink c rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c rpKey rId +addSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO () +addSMPQueueLink c nm rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c nm rpKey rId {-# INLINE addSMPQueueLink #-} -- | Delete queue link -deleteSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () +deleteSMPQueueLink :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () deleteSMPQueueLink = okSMPCommand LDEL {-# INLINE deleteSMPQueueLink #-} -- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID. -secureGetSMPQueueLink :: SMPClient -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData) -secureGetSMPQueueLink c spKey lnkId senderKey = - sendSMPCommand c (Just spKey) lnkId (LKEY senderKey) >>= \case +secureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData) +secureGetSMPQueueLink c nm spKey lnkId senderKey = + sendSMPCommand c nm (Just spKey) lnkId (LKEY senderKey) >>= \case LNK sId d -> pure (sId, d) r -> throwE $ unexpectedResponse r -proxySecureGetSMPQueueLink :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData)) -proxySecureGetSMPQueueLink c proxiedRelay spKey lnkId senderKey = - proxySMPCommand c proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case +proxySecureGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData)) +proxySecureGetSMPQueueLink c nm proxiedRelay spKey lnkId senderKey = + proxySMPCommand c nm proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case Right (LNK sId d) -> pure $ Right (sId, d) Right r -> throwE $ unexpectedResponse r Left e -> pure $ Left e -- | Get contact address SMP queue link data. -getSMPQueueLink :: SMPClient -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData) -getSMPQueueLink c lnkId = - sendSMPCommand c Nothing lnkId LGET >>= \case +getSMPQueueLink :: SMPClient -> NetworkRequestMode -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData) +getSMPQueueLink c nm lnkId = + sendSMPCommand c nm Nothing lnkId LGET >>= \case LNK sId d -> pure (sId, d) r -> throwE $ unexpectedResponse r -proxyGetSMPQueueLink :: SMPClient -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData)) -proxyGetSMPQueueLink c proxiedRelay lnkId = - proxySMPCommand c proxiedRelay Nothing lnkId LGET >>= \case +-- LGET command - get short link data +proxyGetSMPQueueLink :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData)) +proxyGetSMPQueueLink c nm proxiedRelay lnkId = + proxySMPCommand c nm proxiedRelay Nothing lnkId LGET >>= \case Right (LNK sId d) -> pure $ Right (sId, d) Right r -> throwE $ unexpectedResponse r Left e -> pure $ Left e @@ -929,13 +967,14 @@ proxyGetSMPQueueLink c proxiedRelay lnkId = -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey) enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey = - sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case + sendSMPCommand c NRMBackground (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey) r -> throwE $ unexpectedResponse r -- | Enable notifications for the multiple queues for push notifications server. +-- This command is always sent in background request mode enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey))) -enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs +enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c NRMBackground cs where cs = L.map (\(rId, rpKey, notifierKey, rcvNtfPublicDhKey) -> (rId, Just rpKey, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs process (Response _ r) = case r of @@ -946,33 +985,36 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs -- | Disable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command +-- This command is always sent in background request mode disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () -disableSMPQueueNotifications = okSMPCommand NDEL +disableSMPQueueNotifications c = okSMPCommand NDEL c NRMBackground {-# INLINE disableSMPQueueNotifications #-} -- | Disable notifications for multiple queues for push notifications server. +-- This command is always sent in background request mode disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ())) -disableSMPQueuesNtfs = okSMPCommands NDEL +disableSMPQueuesNtfs c = okSMPCommands NDEL c NRMBackground {-# INLINE disableSMPQueuesNtfs #-} -- | Send SMP message. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message -sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO () -sendSMPMessage c spKey sId flags msg = - sendSMPCommand c spKey sId (SEND flags msg) >>= \case +sendSMPMessage :: SMPClient -> NetworkRequestMode -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO () +sendSMPMessage c nm spKey sId flags msg = + sendSMPCommand c nm spKey sId (SEND flags msg) >>= \case 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 = proxyOKSMPCommand c proxiedRelay spKey sId (SEND flags msg) +proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm 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 +-- This command is always sent in background request mode ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO () ackSMPMessage c rpKey rId msgId = - sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case + sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case OK -> return () cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd r -> throwE $ unexpectedResponse r @@ -981,28 +1023,28 @@ ackSMPMessage c rpKey rId msgId = -- The existing messages from the queue will still be delivered. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue -suspendSMPQueue :: SMPClient -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () +suspendSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () suspendSMPQueue = okSMPCommand OFF {-# INLINE suspendSMPQueue #-} -- | Irreversibly delete SMP queue and all messages in it. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue -deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () +deleteSMPQueue :: SMPClient -> NetworkRequestMode -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () deleteSMPQueue = okSMPCommand DEL {-# INLINE deleteSMPQueue #-} -- | Delete multiple SMP queues batching commands if supported. -deleteSMPQueues :: SMPClient -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ())) +deleteSMPQueues :: SMPClient -> NetworkRequestMode -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ())) deleteSMPQueues = okSMPCommands DEL {-# INLINE deleteSMPQueues #-} -- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender -- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg -connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay -connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth +connectSMPProxiedRelay :: SMPClient -> NetworkRequestMode -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay +connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, tcpTimeout}} nm relayServ@ProtocolServer {keyHash = C.KeyHash kh} proxyAuth | thVersion (thParams c) >= sendingProxySMPVersion = - sendProtocolCommand_ c Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case + sendProtocolCommand_ c nm Nothing tOut Nothing NoEntity (Cmd SProxiedClient (PRXY relayServ proxyAuth)) >>= \case PKEY sId vr (CertChainPubKey chain key) -> case supportedClientSMPRelayVRange `compatibleVersion` vr of Nothing -> throwE $ transportErr TEVersion @@ -1010,7 +1052,7 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t r -> throwE $ unexpectedResponse r | otherwise = throwE $ PCETransportError TEVersion where - tOut = Just $ tcpConnectTimeout + tcpTimeout + tOut = Just $ netTimeoutInt tcpConnectTimeout nm + netTimeoutInt tcpTimeout nm transportErr = PCEProtocolError . PROXY . BROKER . TRANSPORT validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> Either String C.PublicKeyX25519 validateRelay (X.CertificateChain cert) exact = do @@ -1076,9 +1118,9 @@ instance StrEncoding ProxyClientError where -- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError -- This function proxies Sender commands that return OK or ERR -proxyOKSMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ()) -proxyOKSMPCommand c proxiedRelay spKey sId command = - proxySMPCommand c proxiedRelay spKey sId command >>= \case +proxyOKSMPCommand :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ()) +proxyOKSMPCommand c nm proxiedRelay spKey sId command = + proxySMPCommand c nm proxiedRelay spKey sId command >>= \case Right OK -> pure $ Right () Right r -> throwE $ unexpectedResponse r Left e -> pure $ Left e @@ -1087,6 +1129,7 @@ proxySMPCommand :: forall p. PartyI p => SMPClient -> + NetworkRequestMode -> -- proxy session from PKEY ProxiedRelay -> -- message to deliver @@ -1094,7 +1137,7 @@ proxySMPCommand :: SenderId -> Command p -> ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg) -proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do +proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nm (ProxiedRelay sessionId v _ serverKey) spKey sId command = do -- prepare params let serverThAuth = (\ta -> ta {peerServerPubKey = serverKey}) <$> thAuth proxyThParams serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth} @@ -1112,8 +1155,8 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c TBTransmissions s _ _ : _ -> pure s 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 (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case + let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm + tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case Right r -> case r of PRES (EncResponse er) -> do -- server interaction errors are thrown directly @@ -1137,6 +1180,7 @@ proxySMPCommand 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 +-- Always uses background timeout mode 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 @@ -1148,7 +1192,7 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr let fwdT = FwdTransmission {fwdCorrId, fwdVersion, fwdKey, fwdTransmission} eft = EncFwdTransmission $ C.cbEncryptNoPad sessSecret nonce (smpEncode fwdT) -- send - sendProtocolCommand_ c (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case + sendProtocolCommand_ c NRMBackground (Just nonce) Nothing Nothing NoEntity (Cmd SProxyService (RFWD eft)) >>= \case RRES (EncFwdResponse efr) -> do -- unwrap r' <- liftEitherWith PCECryptoError $ C.cbDecryptNoPad sessSecret (C.reverseNonce nonce) efr @@ -1156,20 +1200,21 @@ forwardSMPTransmission c@ProtocolClient {thParams, client_ = PClient {clientCorr pure fwdResponse r -> throwE $ unexpectedResponse r -getSMPQueueInfo :: SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo -getSMPQueueInfo c pKey qId = - sendSMPCommand c (Just pKey) qId QUE >>= \case +-- get queue information - always sent interactively +getSMPQueueInfo :: SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO QueueInfo +getSMPQueueInfo c nm pKey qId = + sendSMPCommand c nm (Just pKey) qId QUE >>= \case INFO info -> pure info r -> throwE $ unexpectedResponse r -okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () -okSMPCommand cmd c pKey qId = - sendSMPCommand c (Just pKey) qId cmd >>= \case +okSMPCommand :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () +okSMPCommand cmd c nm pKey qId = + sendSMPCommand c nm (Just pKey) qId cmd >>= \case OK -> return () r -> throwE $ unexpectedResponse r -okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ())) -okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs +okSMPCommands :: PartyI p => Command p -> SMPClient -> NetworkRequestMode -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (Either SMPClientError ())) +okSMPCommands cmd c nm qs = L.map process <$> sendProtocolCommands c nm cs where aCmd = Cmd sParty cmd cs = L.map (\(qId, pKey) -> (qId, Just pKey, aCmd)) qs @@ -1179,17 +1224,17 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs Left e -> Left e -- | Send SMP command -sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg -sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd) +sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg +sendSMPCommand c nm pKey qId cmd = sendProtocolCommand c nm pKey qId (Cmd sParty cmd) {-# INLINE sendSMPCommand #-} type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg) -- | Send multiple commands with batching and collect responses -sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg)) -sendProtocolCommands c@ProtocolClient {thParams} cs = do +sendProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg)) +sendProtocolCommands c@ProtocolClient {thParams} nm cs = do bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs - validate . concat =<< mapM (sendBatch c) bs + validate . concat =<< mapM (sendBatch c nm) bs where validate :: [Response err msg] -> IO (NonEmpty (Response err msg)) validate rs @@ -1203,13 +1248,13 @@ sendProtocolCommands c@ProtocolClient {thParams} cs = do where diff = L.length cs - length rs -streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO () -streamProtocolCommands c@ProtocolClient {thParams} cs cb = do +streamProtocolCommands :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO () +streamProtocolCommands c@ProtocolClient {thParams} nm cs cb = do bs <- batchTransmissions' thParams <$> mapM (mkTransmission c) cs - mapM_ (cb <=< sendBatch c) bs + mapM_ (cb <=< sendBatch c nm) bs -sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg] -sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do +sendBatch :: ProtocolClient v err msg -> NetworkRequestMode -> TransportBatch (Request err msg) -> IO [Response err msg] +sendBatch c@ProtocolClient {client_ = PClient {sndQ}} nm b = do case b of TBError e Request {entityId} -> do putStrLn "send error: large message" @@ -1217,15 +1262,15 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do TBTransmissions s n rs | n > 0 -> do nonBlockingWriteTBQueue sndQ (Nothing, s) -- do not expire batched responses - mapConcurrently (getResponse c Nothing) rs + mapConcurrently (getResponse c nm Nothing) rs | otherwise -> pure [] TBTransmission s r -> do nonBlockingWriteTBQueue sndQ (Nothing, s) - (: []) <$> getResponse c Nothing r + (: []) <$> getResponse c nm Nothing r -- | Send Protocol command -sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg -sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing +sendProtocolCommand :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg +sendProtocolCommand c nm = sendProtocolCommand_ c nm Nothing Nothing -- Currently there is coupling - batch commands do not expire, and individually sent commands do. -- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it. @@ -1233,8 +1278,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing -- But a better solution is to process delayed delete responses. -- -- Please note: if nonce is passed it is also used as a correlation ID -sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg -sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nonce_ tOut pKey entId cmd = +sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> NetworkRequestMode -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg +sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize, serviceAuth}} nm nonce_ tOut pKey entId cmd = ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (entId, pKey, cmd) where -- two separate "atomically" needed to avoid blocking @@ -1245,7 +1290,7 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg | otherwise -> do nonBlockingWriteTBQueue sndQ (Just r, s) - response <$> getResponse c tOut r + response <$> getResponse c nm tOut r where s | batch = tEncodeBatch1 serviceAuth t @@ -1256,9 +1301,9 @@ nonBlockingWriteTBQueue q x = do sent <- atomically $ tryWriteTBQueue q x unless sent $ void $ forkIO $ atomically $ writeTBQueue q x -getResponse :: ProtocolClient v err msg -> Maybe Int -> Request err msg -> IO (Response err msg) -getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} tOut Request {entityId, pending, responseVar} = do - r <- fromMaybe tcpTimeout tOut `timeout` atomically (takeTMVar responseVar) +getResponse :: ProtocolClient v err msg -> NetworkRequestMode -> Maybe Int -> Request err msg -> IO (Response err msg) +getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount}} nm tOut Request {entityId, pending, responseVar} = do + r <- fromMaybe (netTimeoutInt tcpTimeout nm) tOut `timeout` atomically (takeTMVar responseVar) response <- atomically $ do writeTVar pending False -- Try to read response again in case it arrived after timeout expired @@ -1345,6 +1390,8 @@ $(J.deriveJSON (enumJSON $ dropPrefix "SPF") ''SMPProxyFallback) $(J.deriveJSON (enumJSON $ dropPrefix "SWP") ''SMPWebPortServers) +$(J.deriveJSON defaultJSON ''NetworkTimeout) + $(J.deriveJSON defaultJSON ''NetworkConfig) $(J.deriveJSON (sumTypeJSON $ dropPrefix "Proxy") ''ProxyClientError) diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 998be2797..31b611c17 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -203,7 +203,7 @@ getSMPServerClient'' ca@SMPClientAgent {agentCfg, smpClients, smpSessions, worke waitForSMPClient :: SMPClientVar -> ExceptT SMPClientError IO (OwnServer, SMPClient) waitForSMPClient v = do let ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg - smpClient_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) + smpClient_ <- liftIO $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` atomically (readTMVar $ sessionVar v) case smpClient_ of Just (Right smpClient) -> pure smpClient Just (Left (e, ts_)) -> case ts_ of @@ -249,7 +249,7 @@ isOwnServer SMPClientAgent {agentCfg} ProtocolServer {host} = -- | Run an SMP client for SMPClientVar connectClient :: SMPClientAgent p -> SMPServer -> SMPClientVar -> IO (Either SMPClientError SMPClient) connectClient ca@SMPClientAgent {agentCfg, smpClients, smpSessions, msgQ, randomDrg, startedAt} srv v = - getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected + getProtocolClient randomDrg NRMBackground (1, srv, Nothing) (smpCfg agentCfg) [] (Just msgQ) startedAt clientDisconnected where clientDisconnected :: SMPClient -> IO () clientDisconnected smp = do @@ -313,7 +313,7 @@ reconnectClient ca@SMPClientAgent {active, agentCfg, smpSubWorkers, workerSeq} s withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> do subs <- getPending TM.lookupIO readTVarIO unless (noPending subs) $ whenM (readTVarIO active) $ do - void $ tcpConnectTimeout `timeout` runExceptT (reconnectSMPClient ca srv subs) + void $ netTimeoutInt tcpConnectTimeout NRMBackground `timeout` runExceptT (reconnectSMPClient ca srv subs) loop ProtocolClientConfig {networkConfig = NetworkConfig {tcpConnectTimeout}} = smpCfg agentCfg noPending (sSub, qSubs) = isNothing sSub && maybe True M.null qSubs diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index ecfe02c86..a5c8f555a 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -28,39 +28,39 @@ defaultNTFClientConfig = {defaultTransport = ("443", transport @TLS)} {-# INLINE defaultNTFClientConfig #-} -ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) -ntfRegisterToken c pKey newTkn = - sendNtfCommand c (Just pKey) NoEntity (TNEW newTkn) >>= \case +ntfRegisterToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) +ntfRegisterToken c nm pKey newTkn = + sendNtfCommand c nm (Just pKey) NoEntity (TNEW newTkn) >>= \case NRTknId tknId dhKey -> pure (tknId, dhKey) r -> throwE $ unexpectedResponse r -ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO () -ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId +ntfVerifyToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO () +ntfVerifyToken c nm pKey tknId code = okNtfCommand (TVFY code) c nm pKey tknId -ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus -ntfCheckToken c pKey tknId = - sendNtfCommand c (Just pKey) tknId TCHK >>= \case +ntfCheckToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus +ntfCheckToken c nm pKey tknId = + sendNtfCommand c nm (Just pKey) tknId TCHK >>= \case NRTkn stat -> pure stat r -> throwE $ unexpectedResponse r -ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () -ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId +ntfReplaceToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () +ntfReplaceToken c nm pKey tknId token = okNtfCommand (TRPL token) c nm pKey tknId -ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO () +ntfDeleteToken :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO () ntfDeleteToken = okNtfCommand TDEL -- set to 0 to disable -ntfSetCronInterval :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () -ntfSetCronInterval c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId +ntfSetCronInterval :: NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () +ntfSetCronInterval c nm pKey tknId int = okNtfCommand (TCRN int) c nm pKey tknId ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId ntfCreateSubscription c pKey newSub = - sendNtfCommand c (Just pKey) NoEntity (SNEW newSub) >>= \case + sendNtfCommand c NRMBackground (Just pKey) NoEntity (SNEW newSub) >>= \case NRSubId subId -> pure subId r -> throwE $ unexpectedResponse r ntfCreateSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty (NewNtfEntity 'Subscription) -> IO (NonEmpty (Either NtfClientError NtfSubscriptionId)) -ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c cs +ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c NRMBackground cs where cs = L.map (\newSub -> (NoEntity, Just pKey, NtfCmd SSubscription $ SNEW newSub)) newSubs process (Response _ r) = case r of @@ -70,12 +70,12 @@ ntfCreateSubscriptions c pKey newSubs = L.map process <$> sendProtocolCommands c ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus ntfCheckSubscription c pKey subId = - sendNtfCommand c (Just pKey) subId SCHK >>= \case + sendNtfCommand c NRMBackground (Just pKey) subId SCHK >>= \case NRSub stat -> pure stat r -> throwE $ unexpectedResponse r ntfCheckSubscriptions :: NtfClient -> C.APrivateAuthKey -> NonEmpty NtfSubscriptionId -> IO (NonEmpty (Either NtfClientError NtfSubStatus)) -ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c cs +ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c NRMBackground cs where cs = L.map (\subId -> (subId, Just pKey, NtfCmd SSubscription SCHK)) subIds process (Response _ r) = case r of @@ -84,14 +84,14 @@ ntfCheckSubscriptions c pKey subIds = L.map process <$> sendProtocolCommands c c Left e -> Left e ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO () -ntfDeleteSubscription = okNtfCommand SDEL +ntfDeleteSubscription c = okNtfCommand SDEL c NRMBackground -- | Send notification server command -sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse -sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd) +sendNtfCommand :: NtfEntityI e => NtfClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse +sendNtfCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (NtfCmd sNtfEntity cmd) -okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO () -okNtfCommand cmd c pKey entId = - sendNtfCommand c (Just pKey) entId cmd >>= \case +okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> NetworkRequestMode -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO () +okNtfCommand cmd c nm pKey entId = + sendNtfCommand c nm (Just pKey) entId cmd >>= \case NROk -> return () r -> throwE $ unexpectedResponse r diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 445d087cb..5340b19a4 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -81,7 +81,7 @@ import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient import SMPClient -import Simplex.Messaging.Agent hiding (createConnection, joinConnection, subscribeConnection, sendMessage) +import Simplex.Messaging.Agent hiding (acceptContact, createConnection, deleteConnection, deleteConnections, getConnShortLink, joinConnection, sendMessage, setConnShortLink, subscribeConnection, suspendConnection) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Env (..), InitialAgentServers (..), createAgentStore) @@ -91,7 +91,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) import Simplex.Messaging.Agent.Store.Interface import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError (..)) -import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig) +import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR @@ -276,15 +276,18 @@ inAnyOrder g rs = withFrozenCallStack $ do createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c) createConnection c userId enableNtfs cMode clientData subMode = do - (connId, (CCLink cReq _, Nothing)) <- A.createConnection c userId enableNtfs cMode Nothing clientData IKPQOn subMode + (connId, (CCLink cReq _, Nothing)) <- A.createConnection c NRMInteractive userId enableNtfs cMode Nothing clientData IKPQOn subMode pure (connId, cReq) joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured) joinConnection c userId enableNtfs cReq connInfo subMode = do connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn - (sndSecure, Nothing) <- A.joinConnection c userId connId enableNtfs cReq connInfo PQSupportOn subMode + (sndSecure, Nothing) <- A.joinConnection c NRMInteractive userId connId enableNtfs cReq connInfo PQSupportOn subMode pure (connId, sndSecure) +acceptContact :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE (SndQueueSecured, Maybe ClientServiceId) +acceptContact c = A.acceptContact c NRMInteractive + subscribeConnection :: AgentClient -> ConnId -> AE () subscribeConnection c = void . A.subscribeConnection c @@ -294,6 +297,21 @@ sendMessage c connId msgFlags msgBody = do liftIO $ pqEnc `shouldBe` PQEncOn pure msgId +deleteConnection :: AgentClient -> ConnId -> AE () +deleteConnection c = A.deleteConnection c NRMInteractive + +deleteConnections :: AgentClient -> [ConnId] -> AE (M.Map ConnId (Either AgentErrorType ())) +deleteConnections c = A.deleteConnections c NRMInteractive + +getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c) +getConnShortLink c = A.getConnShortLink c NRMInteractive + +setConnShortLink :: AgentClient -> ConnId -> SConnectionMode c -> UserLinkData -> Maybe CRClientData -> AE (ConnShortLink c) +setConnShortLink c = A.setConnShortLink c NRMInteractive + +suspendConnection :: AgentClient -> ConnId -> AE () +suspendConnection c = A.suspendConnection c NRMInteractive + functionalAPITests :: (ASrvTransport, AStoreType) -> Spec functionalAPITests ps = do describe "Establishing duplex connection" $ do @@ -680,9 +698,9 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId = runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe + (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ - (sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe + (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecured' `shouldBe` sqSecured ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ @@ -882,9 +900,9 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId = runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do - (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe + (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ - (sqSecuredJoin, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe + (sqSecuredJoin, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` reqPQSupport @@ -926,7 +944,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do - (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe + (_, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing aPQ SMSubscribe (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo sentMessages abPQEnc alice bobId bob bAliceId (tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo @@ -935,7 +953,7 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId msgId = subtract baseId . fst connectViaContact b pq qInfo = do aId <- A.prepareConnectionToJoin b 1 True qInfo pq - (sqSecuredJoin, Nothing) <- A.joinConnection b 1 aId True qInfo "bob's connInfo" pq SMSubscribe + (sqSecuredJoin, Nothing) <- A.joinConnection b NRMInteractive 1 aId True qInfo "bob's connInfo" pq SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn @@ -979,9 +997,9 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () testRejectContactRequest :: HasCallStack => IO () testRejectContactRequest = withAgentClients2 $ \alice bob -> runRight_ $ do - (_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe + (_addrConnId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice rejectContact alice invId @@ -994,7 +1012,7 @@ testUpdateConnectionUserId = newUserId <- createUser alice [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] _ <- changeConnectionUser alice 1 connId newUserId aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - (sqSecured', Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured' `shouldBe` True ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn @@ -1154,13 +1172,13 @@ testInvitationErrors ps restart = do ("", "", DOWN _ [_]) <- nGet a aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn -- fails to secure the queue on testPort - BROKER srv NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + BROKER srv NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe (testPort `isSuffixOf` srv) `shouldBe` True withServer1 ps $ do ("", "", UP _ [_]) <- nGet a let loopSecure = do -- secures the queue on testPort, but fails to create reply queue on testPort2 - BROKER srv2 NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + BROKER srv2 NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe unless (testPort2 `isSuffixOf` srv2) $ putStrLn "retrying secure" >> threadDelay 200000 >> loopSecure loopSecure ("", "", DOWN _ [_]) <- nGet a @@ -1168,7 +1186,7 @@ testInvitationErrors ps restart = do threadDelay 200000 let loopCreate = do -- creates the reply queue on testPort2, but fails to send it to testPort - BROKER srv' NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + BROKER srv' NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create" >> threadDelay 200000 >> loopCreate loopCreate restartAgentB restart b [aId] @@ -1177,7 +1195,7 @@ testInvitationErrors ps restart = do ("", "", UP _ [_]) <- nGet a threadDelay 200000 let loopConfirm n = - runExceptT (A.joinConnection b' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case + runExceptT (A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case Right (True, Nothing) -> pure n Right r -> error $ "unexpected result " <> show r Left _ -> putStrLn "retrying confirm" >> threadDelay 200000 >> loopConfirm (n + 1) @@ -1224,12 +1242,12 @@ testContactErrors ps restart = do ("", "", DOWN _ [_]) <- nGet a aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn -- fails to create queue on testPort2 - BROKER srv2 NETWORK <- runLeft $ A.joinConnection b 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + BROKER srv2 NETWORK <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe (testPort2 `isSuffixOf` srv2) `shouldBe` True b' <- restartAgentB restart b [aId] let loopCreate2 = do -- creates the reply queue on testPort2, but fails to send invitation to testPort - BROKER srv' NETWORK <- runLeft $ A.joinConnection b' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe + BROKER srv' NETWORK <- runLeft $ A.joinConnection b' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe unless (testPort `isSuffixOf` srv') $ putStrLn "retrying create 2" >> threadDelay 200000 >> loopCreate2 b'' <- withServer2 ps $ do loopCreate2 @@ -1239,7 +1257,7 @@ testContactErrors ps restart = do ("", "", UP _ [_]) <- nGet a let loopSend = do -- sends the invitation to testPort - runExceptT (A.joinConnection b'' 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case + runExceptT (A.joinConnection b'' NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe) >>= \case Right (False, Nothing) -> pure () Right r -> error $ "unexpected result " <> show r Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend @@ -1305,7 +1323,7 @@ testInviationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> testInviationShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = UserLinkData "some user data" - (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1327,7 +1345,7 @@ testInviationShortLink viaProxy a b = testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO () testJoinConn_ viaProxy sndSecure a bId b connReq = do aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn - (sndSecure', Nothing) <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe + (sndSecure', Nothing) <- A.joinConnection b NRMInteractive 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sndSecure' `shouldBe` sndSecure ("", _, CONF confId _ "bob's connInfo") <- get a allowConnection a bId confId "alice's connInfo" @@ -1340,13 +1358,13 @@ testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> Age testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do let userData = UserLinkData "some user data" -- can't create short link with previous version - (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe + (bId, (CCLink connReq Nothing, Nothing)) <- A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe testJoinConn_ viaProxy sndSecure a bId b connReq testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testInviationShortLinkAsync viaProxy a b = do let userData = UserLinkData "some user data" - (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (bId, (CCLink connReq (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1365,7 +1383,7 @@ testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO testContactShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = UserLinkData "some user data" - (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink @@ -1403,14 +1421,14 @@ testContactShortLink viaProxy a b = shortLink2 <- runRight $ setConnShortLink a contactId SCMContact updatedData Nothing shortLink2 `shouldBe` shortLink -- delete short link - runRight_ $ deleteConnShortLink a contactId SCMContact + runRight_ $ deleteConnShortLink a NRMInteractive contactId SCMContact Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink pure () testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testAddContactShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do - (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe + (contactId, (CCLink connReq0 Nothing, Nothing)) <- runRight $ A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) -- let userData = UserLinkData "some user data" shortLink <- runRight $ setConnShortLink a contactId SCMContact userData Nothing @@ -1451,7 +1469,7 @@ testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do let userData = UserLinkData "some user data" (bId, (CCLink connReq (Just shortLink), Nothing)) <- withSmpServer ps $ - runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate + runRight $ A.createConnection a NRMInteractive 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate withSmpServer ps $ do runRight_ $ subscribeConnection a bId (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink @@ -1463,7 +1481,7 @@ testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do let userData = UserLinkData "some user data" (contactId, (CCLink connReq0 (Just shortLink), Nothing)) <- withSmpServer ps $ - runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate + runRight $ A.createConnection a NRMInteractive 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMOnlyCreate Right connReq <- pure $ smpDecode (smpEncode connReq0) let updatedData = UserLinkData "updated user data" withSmpServer ps $ do @@ -1483,7 +1501,7 @@ testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do let userData = UserLinkData "some user data" ((contactId, (CCLink connReq0 Nothing, Nothing)), shortLink) <- withSmpServer ps $ runRight $ do - r@(contactId, _) <- A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate + r@(contactId, _) <- A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate (r,) <$> setConnShortLink a contactId SCMContact userData Nothing Right connReq <- pure $ smpDecode (smpEncode connReq0) let updatedData = UserLinkData "updated user data" @@ -1503,7 +1521,7 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do (contactId, (CCLink connReq Nothing, Nothing)) <- withSmpServer ps $ runRight $ - A.createConnection a 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate + A.createConnection a NRMInteractive 1 True SCMContact Nothing Nothing CR.IKPQOn SMOnlyCreate -- make it an "old" queue let updateStoreLog f = replaceSubstringInFile f " queue_mode=C" "" () <- case testServerStoreConfig msType of @@ -2234,9 +2252,9 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do - (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe + (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive aliceUserId True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) SMSubscribe aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport - (sqSecured', Nothing) <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe + (sqSecured', Nothing) <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe liftIO $ sqSecured' `shouldBe` sqSecured ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` pqSupport @@ -3383,7 +3401,7 @@ testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv = withSmpServerConfigOn t cfg' testPort2 $ \_ -> do -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a 1 srv + testProtocolServer a NRMInteractive 1 srv where cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth} @@ -3781,7 +3799,7 @@ testServerQueueInfo = do liftIO $ isJust r `shouldBe` True pure r checkQ c cId qiSnd' qiSubThread_ qiSize' msgType_ = do - ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c cId + ServerQueueInfo {info = QueueInfo {qiSnd, qiNtf, qiSub, qiSize, qiMsg}} <- getConnectionQueueInfo c NRMInteractive cId liftIO $ do qiSnd `shouldBe` qiSnd' qiNtf `shouldBe` False diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 463977331..c7be1a3e2 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -61,7 +61,8 @@ import qualified Database.PostgreSQL.Simple as PSQL import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2) import SMPClient -import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) +import Simplex.Messaging.Agent hiding (checkNtfToken, createConnection, joinConnection, registerNtfToken, sendMessage, verifyNtfToken) +import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore') import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT) @@ -69,6 +70,7 @@ import Simplex.Messaging.Agent.Store.AgentStore (getSavedNtfToken) import Simplex.Messaging.Agent.Store.Common (withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore) +import Simplex.Messaging.Client (pattern NRMInteractive) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol @@ -194,6 +196,15 @@ testNtfMatrix ps@(_, msType) runTest = do cfg' = cfgMS msType cfgVPrev' = cfgVPrev msType +registerNtfToken :: AgentClient -> DeviceToken -> NotificationsMode -> AE NtfTknStatus +registerNtfToken c = A.registerNtfToken c NRMInteractive + +checkNtfToken :: AgentClient -> DeviceToken -> AE NtfTknStatus +checkNtfToken c = A.checkNtfToken c NRMInteractive + +verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE () +verifyNtfToken c = A.verifyNtfToken c NRMInteractive + runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType @@ -529,7 +540,7 @@ testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFai testRunNTFServerTests t srv = withNtfServer t $ withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing + testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do diff --git a/tests/CoreTests/SOCKSSettings.hs b/tests/CoreTests/SOCKSSettings.hs index 2c8e4454c..3dbf5e5e7 100644 --- a/tests/CoreTests/SOCKSSettings.hs +++ b/tests/CoreTests/SOCKSSettings.hs @@ -91,7 +91,7 @@ testSocksMode = do where transportSocks proxy socksMode = transportSocksCfg defaultNetworkConfig {socksProxy = proxy, socksMode} transportSocksCfg cfg host = - let TransportClientConfig {socksProxy} = transportClientConfig cfg host False Nothing + let TransportClientConfig {socksProxy} = transportClientConfig cfg NRMInteractive host False Nothing in socksProxy testSocksProxyEncoding :: Spec diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 1c256c092..b6b9fd26f 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -19,7 +19,7 @@ import SMPClient (proxyVRangeV8, ntfTestPort, testPort) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval -import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig) +import Simplex.Messaging.Client (NetworkTimeout (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer) import Simplex.Messaging.Transport @@ -64,7 +64,7 @@ initAgentServers = { smp = userServers [testSMPServer], ntf = [testNtfServer], xftp = userServers [testXFTPServer], - netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000}, + netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000}, presetDomains = [] } @@ -96,7 +96,7 @@ agentCfg = certificateFile = "tests/fixtures/server.crt" } where - networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000} + networkConfig = defaultNetworkConfig {tcpConnectTimeout = NetworkTimeout 1_000000 1_000000, tcpTimeout = NetworkTimeout 2_000000 2_000000} agentProxyCfgV8 :: AgentConfig agentProxyCfgV8 = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRangeV8}} diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 313bbde13..42f81d45b 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -167,37 +167,37 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do g <- C.newRandom -- set up proxy ts <- getCurrentTime - pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ()) + pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- set up relay msgQ <- newTBQueueIO 1024 - rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ()) + rc' <- getProtocolClient g NRMInteractive (2, relayServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion} [] (Just msgQ) ts (\_ -> pure ()) rc <- either (fail . show) pure rc' -- prepare receiving queue (rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g (rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) + SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv -- get proxy session - sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") - sess <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct") + sess0 <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct") + sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct") sess0 `shouldBe` sess -- send via proxy to unsecured queue forM_ unsecuredMsgs $ \msg -> do - runExceptT' (proxySMPMessage pc sess Nothing sndId noMsgFlags msg) `shouldReturn` Right () - runExceptT' (proxySMPMessage pc sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION) + runExceptT' (proxySMPMessage pc NRMInteractive sess Nothing sndId noMsgFlags msg) `shouldReturn` Right () + runExceptT' (proxySMPMessage pc NRMInteractive sess {prSessionId = "bad session"} Nothing sndId noMsgFlags msg) `shouldReturn` Left (ProxyProtocolError $ SMP.PROXY SMP.NO_SESSION) -- receive 1 (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody})))]) <- atomically $ readTBQueue msgQ dec msgId encBody `shouldBe` Right msg runExceptT' $ ackSMPMessage rc rPriv rcvId msgId -- secure queue (sPub, sPriv) <- atomically $ C.generateAuthKeyPair alg g - runExceptT' $ secureSMPQueue rc rPriv rcvId sPub + runExceptT' $ secureSMPQueue rc NRMInteractive rPriv rcvId sPub -- send via proxy to secured queue waitSendRecv ( forM_ securedMsgs $ \msg' -> - runExceptT' (proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right () + runExceptT' (proxySMPMessage pc NRMInteractive sess (Just sPriv) sndId noMsgFlags msg') `shouldReturn` Right () ) ( forM_ securedMsgs $ \msg' -> do (_tSess, _v, _sid, [(_entId, STEvent (Right (SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'})))]) <- atomically $ readTBQueue msgQ @@ -210,12 +210,12 @@ proxyConnectDeadRelay n d proxyServ = do g <- C.newRandom -- set up proxy ts <- getCurrentTime - pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ()) + pc' <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} [] Nothing ts (\_ -> pure ()) pc <- either (fail . show) pure pc' THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc -- get proxy session replicateM_ n $ do - sess0 <- runExceptT $ connectSMPProxiedRelay pc (SMPServer testHost "45678" testKeyHash) (Just "correct") + sess0 <- runExceptT $ connectSMPProxiedRelay pc NRMInteractive (SMPServer testHost "45678" testKeyHash) (Just "correct") case sess0 of Right !_noWay -> error "got unexpected client" Left !_err -> threadDelay d @@ -224,9 +224,9 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId = withAgent 1 aCfg (servers aTestCfg) testDB $ \alice -> withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do - (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn @@ -280,9 +280,9 @@ agentDeliverMessagesViaProxyConc agentServers msgs = -- agent connections have to be set up in advance -- otherwise the CONF messages would get mixed with MSG prePair alice bob = do - (bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + (bobId, (CCLink qInfo Nothing, Nothing)) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - (sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (sqSecured, Nothing) <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True confId <- get alice >>= \case @@ -331,9 +331,9 @@ agentViaProxyVersionError = withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do Left (A.BROKER _ (TRANSPORT TEVersion)) <- withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do - (_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + (_bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe pure () where servers srvs = (initAgentServersProxy_ SPMUnknown SPFProhibit) {smp = userServers srvs} @@ -351,9 +351,9 @@ agentViaProxyRetryOffline = do let pqEnc = CR.PQEncOn withServer $ \_ -> do (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do - (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe + (bobId, (CCLink qInfo Nothing, Nothing)) <- A.createConnection alice NRMInteractive 1 True SCMInvitation Nothing Nothing CR.IKPQOn SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn - (sqSecured, Nothing) <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe + (sqSecured, Nothing) <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` True ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 53985715d..d19705a37 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -33,6 +33,7 @@ import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFi import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg) import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv) +import Simplex.Messaging.Client (pattern NRMInteractive) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF @@ -674,4 +675,4 @@ testXFTPServerTest newFileBasicAuth srv = withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> - testProtocolServer a 1 srv + testProtocolServer a NRMInteractive 1 srv From 1062ccc5c3d915fc620a4c0080e82d28a401839b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 7 Jul 2025 10:07:54 +0100 Subject: [PATCH 15/22] 6.4.0.11.2 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index 106d9a41e..b64d66f65 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.4.0.11.1 +version: 6.4.0.11.2 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From ba3c75e58c8a44e710e3d6b1d9681ebe628e47d7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 7 Jul 2025 18:49:47 +0100 Subject: [PATCH 16/22] smp server: correctly track if ntf service is subscribed and total subscribed queues count (fixes race condition between NSUB and NSUBS from notification server) (#1583) --- src/Simplex/Messaging/Server.hs | 19 ++++++++++--------- src/Simplex/Messaging/Server/Env/STM.hs | 6 ++++++ 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 03a672408..7c0237e18 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1321,7 +1321,7 @@ client -- TODO [certs rcv] rcv subscriptions Server {subscribers, ntfSubscribers} ms - clnt@Client {clientId, subscriptions, ntfSubscriptions, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do + clnt@Client {clientId, subscriptions, ntfSubscriptions, ntfServiceSubscribed, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" let THandleParams {thVersion} = thParams' service = peerClientService =<< thAuth thParams' @@ -1721,18 +1721,19 @@ client subscribeServiceNotifications :: THPeerClientService -> M s BrokerMsg subscribeServiceNotifications THClientService {serviceId} = do - srvSubs <- readTVarIO ntfServiceSubsCount - if srvSubs == 0 - then + subscribed <- readTVarIO ntfServiceSubscribed + if subscribed + then SOKS <$> readTVarIO ntfServiceSubsCount + else liftIO (getNtfServiceQueueCount @(StoreQueue s) (queueStore ms) serviceId) >>= \case Left e -> pure $ ERR e - Right count -> do + Right !count' -> do atomically $ do - modifyTVar' ntfServiceSubsCount (+ count) -- service count - modifyTVar' (totalServiceSubs ntfSubscribers) (+ count) -- server count for all services + writeTVar ntfServiceSubscribed True + count <- swapTVar ntfServiceSubsCount count' + modifyTVar' (totalServiceSubs ntfSubscribers) (+ (count' - count)) -- server count for all services atomically $ writeTQueue (subQ ntfSubscribers) (CSService serviceId, clientId) - pure $ SOKS count - else pure $ SOKS srvSubs + pure $ SOKS count' acknowledgeMsg :: MsgId -> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg) acknowledgeMsg msgId q qr = time "ACK" $ do diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index a04a8acd8..8039a252e 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -389,6 +389,8 @@ data Client s = Client { clientId :: ClientId, subscriptions :: TMap RecipientId Sub, ntfSubscriptions :: TMap NotifierId (), + serviceSubscribed :: TVar Bool, -- set independently of serviceSubsCount, to track whether service subscription command was received + ntfServiceSubscribed :: TVar Bool, serviceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count ntfServiceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count rcvQ :: TBQueue (NonEmpty (VerifiedTransmission s)), @@ -458,6 +460,8 @@ newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemT newClient clientId qSize clientTHParams createdAt = do subscriptions <- TM.emptyIO ntfSubscriptions <- TM.emptyIO + serviceSubscribed <- newTVarIO False + ntfServiceSubscribed <- newTVarIO False serviceSubsCount <- newTVarIO 0 ntfServiceSubsCount <- newTVarIO 0 rcvQ <- newTBQueueIO qSize @@ -474,6 +478,8 @@ newClient clientId qSize clientTHParams createdAt = do { clientId, subscriptions, ntfSubscriptions, + serviceSubscribed, + ntfServiceSubscribed, serviceSubsCount, ntfServiceSubsCount, rcvQ, From 7a04fdff2e0a899d2006f7c2666eca2cdeedc019 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 7 Jul 2025 18:50:31 +0100 Subject: [PATCH 17/22] 6.4.0.11.3 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index b64d66f65..cc2b382fc 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.4.0.11.2 +version: 6.4.0.11.3 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From 384a3352cf61a1a23c49abe29be6848f3138b5ad Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 8 Jul 2025 23:01:57 +0100 Subject: [PATCH 18/22] ntf server: more efficient status update query (#1584) --- src/Simplex/Messaging/Notifications/Server.hs | 22 +++++++++---------- .../Messaging/Notifications/Server/Env.hs | 1 + .../Notifications/Server/Store/Postgres.hs | 12 +++++----- 3 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 6fe13dc65..c856b5249 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -480,8 +480,8 @@ subscribeSrvSubs ca st batchSize (srv, srvId, service_) = do -- this function is concurrency-safe - only onle subscriber per server can be created at a time, -- other threads would wait for the first thread to create it. -subscribeNtfs :: NtfSubscriber -> NtfPostgresStore -> SMPServer -> ServerNtfSub -> IO () -subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer ntfSub = +subscribeNtfs :: NtfSubscriber -> NtfPostgresStore -> SMPServer -> Int64 -> ServerNtfSub -> IO () +subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st smpServer srvId ntfSub = getSubscriberVar >>= either createSMPSubscriber waitForSMPSubscriber >>= mapM_ (\sub -> atomically $ writeTQueue (subscriberSubQ sub) ntfSub) @@ -493,8 +493,8 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm createSMPSubscriber v = E.handle (\(e :: SomeException) -> logError ("SMP subscriber exception: " <> tshow e) >> removeSubscriber v) $ do q <- newTQueueIO - tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber q) - let sub = SMPSubscriber {smpServer, subscriberSubQ = q, subThreadId = tId} + tId <- mkWeakThreadId =<< forkIO (runSMPSubscriber smpServer srvId q) + let sub = SMPSubscriber {smpServer, smpServerId = srvId, subscriberSubQ = q, subThreadId = tId} atomically $ putTMVar (sessionVar v) sub -- this makes it available for other threads pure $ Just sub @@ -510,13 +510,13 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm atomically $ removeSessVar v smpServer smpSubscribers pure Nothing - runSMPSubscriber :: TQueue ServerNtfSub -> IO () - runSMPSubscriber q = forever $ do + runSMPSubscriber :: SMPServer -> Int64 -> TQueue ServerNtfSub -> IO () + runSMPSubscriber smpServer' srvId' q = forever $ do -- TODO [ntfdb] possibly, the subscriptions can be batched here and sent every say 5 seconds -- this should be analysed once we have prometheus stats (nId, sub) <- atomically $ readTQueue q - void $ updateSubStatus st nId NSPending - subscribeQueuesNtfs ca smpServer [sub] + void $ updateSubStatus st srvId' nId NSPending + subscribeQueuesNtfs ca smpServer' [sub] ntfSubscriber :: NtfSubscriber -> M () ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} = @@ -866,12 +866,12 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ let sub = mkNtfSubRec subId newSub resp <- withNtfStore (`addNtfSubscription` sub) $ \case - True -> do + (srvId, True) -> do st <- asks store - liftIO $ subscribeNtfs ns st srv (subId, (nId, nKey)) + liftIO $ subscribeNtfs ns st srv srvId (subId, (nId, nKey)) incNtfStat subCreated pure $ NRSubId subId - False -> pure $ NRErr AUTH + (_, False) -> pure $ NRErr AUTH pure (corrId, NoEntity, resp) NtfReqCmd SSubscription (NtfSub NtfSubRec {ntfSubId, smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do (corrId,subId,) <$> case cmd of diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index b07b74c6c..b0eafbc63 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -141,6 +141,7 @@ newNtfSubscriber smpAgentCfg random = do data SMPSubscriber = SMPSubscriber { smpServer :: SMPServer, + smpServerId :: Int64, subscriberSubQ :: TQueue ServerNtfSub, subThreadId :: Weak ThreadId } diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 8df158182..b6f23047f 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -401,13 +401,13 @@ updateTokenCronSentAt st tknId now = withDB' "updateTokenCronSentAt" st $ \db -> void $ DB.execute db "UPDATE tokens t SET cron_sent_at = ? WHERE token_id = ?" (now, tknId) -addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType Bool) +addNtfSubscription :: NtfPostgresStore -> NtfSubRec -> IO (Either ErrorType (Int64, Bool)) addNtfSubscription st sub = withFastDB "addNtfSubscription" st $ \db -> runExceptT $ do srvId :: Int64 <- ExceptT $ upsertServer db $ ntfSubServer' sub n <- liftIO $ DB.execute db insertNtfSubQuery $ ntfSubToRow srvId sub withLog "addNtfSubscription" st (`logCreateSubscription` sub) - pure $ n > 0 + pure (srvId, n > 0) where -- It is possible to combine these two statements into one with CTEs, -- to reduce roundtrips in case of `insert`, but it would be making 2 queries in all cases. @@ -454,8 +454,8 @@ deleteNtfSubscription st subId = DB.execute db "DELETE FROM subscriptions WHERE subscription_id = ?" (Only subId) withLog "deleteNtfSubscription" st (`logDeleteSubscription` subId) -updateSubStatus :: NtfPostgresStore -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ()) -updateSubStatus st nId status = +updateSubStatus :: NtfPostgresStore -> Int64 -> NotifierId -> NtfSubStatus -> IO (Either ErrorType ()) +updateSubStatus st srvId nId status = withFastDB' "updateSubStatus" st $ \db -> do sub_ :: Maybe (NtfSubscriptionId, NtfAssociatedService) <- maybeFirstRow id $ @@ -463,10 +463,10 @@ updateSubStatus st nId status = db [sql| UPDATE subscriptions SET status = ? - WHERE smp_notifier_id = ? AND status != ? + WHERE smp_server_id = ? AND smp_notifier_id = ? AND status != ? RETURNING subscription_id, ntf_service_assoc |] - (status, nId, status) + (status, srvId, nId, status) forM_ sub_ $ \(subId, serviceAssoc) -> withLog "updateSubStatus" st $ \sl -> logSubscriptionStatus sl (subId, status, serviceAssoc) From 99e59b73a32400067a8ac630ca4ad27f27bba0ef Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 10 Jul 2025 10:21:12 +0100 Subject: [PATCH 19/22] agent: fix message delivery in case one of the connections has no snd queue for any reason - it could break delivery to all connections (#1585) * agent: fix message delivery in case one of the connections has no snd queue for any reason - it could break delivery to all connections * simplify * comment * refactor, also postpone failing on ratchet sync send prohibited errors * postpone failing on connection errors to allow subsequent connections succeed --- src/Simplex/Messaging/Agent.hs | 75 +++++++++++++++++++++------------- 1 file changed, 46 insertions(+), 29 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 41a4e347a..255e56800 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1412,37 +1412,39 @@ sendMessagesB' c reqs = do sendMessagesB_ :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType MsgReq) -> Set ConnId -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption))) sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do prev <- newTVarIO Nothing - reqs' <- withStoreBatch c $ \db -> fmap (bindRight $ getConn_ db prev) reqs + reqs' <- withStoreBatch c $ \db -> fmap (mapM $ getConn_ db prev) reqs let (toEnable, reqs'') = mapAccumL prepareConn [] reqs' void $ withStoreBatch' c $ \db -> map (\connId -> setConnPQSupport db connId PQSupportOn) $ S.toList toEnable enqueueMessagesB c reqs'' where - getConn_ :: DB.Connection -> TVar (Maybe (Either AgentErrorType SomeConn)) -> MsgReq -> IO (Either AgentErrorType (MsgReq, SomeConn)) + getConn_ :: DB.Connection -> TVar (Maybe (Either AgentErrorType SomeConn)) -> MsgReq -> IO (MsgReq, Either AgentErrorType SomeConn) getConn_ db prev req@(connId, _, _, _) = (req,) - <$$> if B.null connId + <$> if B.null connId then fromMaybe (Left $ INTERNAL "sendMessagesB_: empty prev connId") <$> readTVarIO prev else do conn <- first storeError <$> getConn db connId conn <$ atomically (writeTVar prev $ Just conn) - prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, SomeConn) -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) + prepareConn :: Set ConnId -> Either AgentErrorType (MsgReq, Either AgentErrorType SomeConn) -> (Set ConnId, Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) prepareConn s (Left e) = (s, Left e) - prepareConn s (Right ((_, pqEnc, msgFlags, msgOrRef), SomeConn _ conn)) = case conn of - DuplexConnection cData _ sqs -> prepareMsg cData sqs - SndConnection cData sq -> prepareMsg cData [sq] - _ -> (s, Left $ CONN SIMPLEX "sendMessagesB_") + prepareConn s (Right ((_, pqEnc, msgFlags, msgOrRef), conn_)) = case conn_ of + Right (SomeConn cType conn) -> case conn of + DuplexConnection cData _ sqs -> prepareMsg cData sqs + SndConnection cData sq -> prepareMsg cData [sq] + -- we can't fail here, as it may prevent delivery of subsequent messages that reference the body of the failed message. + _ -> (s, mkReq $ Left $ CONN SIMPLEX $ "sendMessagesB_ " <> show (connType cType)) + Left e -> (s, mkReq $ Left e) where - prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) + prepareMsg :: ConnData -> NonEmpty SndQueue -> (Set ConnId, Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) prepareMsg cData@ConnData {connId, pqSupport} sqs - | ratchetSyncSendProhibited cData = (s, Left $ CMD PROHIBITED "sendMessagesB: send prohibited") + | ratchetSyncSendProhibited cData = (s, mkReq $ Left $ CMD PROHIBITED "sendMessagesB: send prohibited") -- connection is only updated if PQ encryption was disabled, and now it has to be enabled. -- support for PQ encryption (small message envelopes) will not be disabled when message is sent. | pqEnc == PQEncOn && pqSupport == PQSupportOff = let cData' = cData {pqSupport = PQSupportOn} :: ConnData - in (S.insert connId s, mkReq cData') - | otherwise = (s, mkReq cData) - where - mkReq cData' = Right (cData', sqs, Just pqEnc, msgFlags, A_MSG <$> msgOrRef) + in (S.insert connId s, mkReq $ Right (cData', sqs)) + | otherwise = (s, mkReq $ Right (cData, sqs)) + mkReq csqs_ = Right (csqs_, Just pqEnc, msgFlags, A_MSG <$> msgOrRef) -- / async command processing v v v @@ -1626,10 +1628,10 @@ enqueueMessages c cData sqs msgFlags aMessage = do enqueueMessages' :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, CR.PQEncryption) enqueueMessages' c cData sqs msgFlags aMessage = - ExceptT $ runIdentity <$> enqueueMessagesB c (Identity (Right (cData, sqs, Nothing, msgFlags, vrValue aMessage))) + ExceptT $ runIdentity <$> enqueueMessagesB c (Identity (Right (Right (cData, sqs), Nothing, msgFlags, vrValue aMessage))) {-# INLINE enqueueMessages' #-} -enqueueMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption))) +enqueueMessagesB :: Traversable t => AgentClient -> t (Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType (AgentMsgId, PQEncryption))) enqueueMessagesB c reqs = do reqs' <- enqueueMessageB c reqs enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs' @@ -1641,35 +1643,50 @@ isActiveSndQ SndQueue {status} = status == Secured || status == Active enqueueMessage :: AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption) enqueueMessage c cData sq msgFlags aMessage = - ExceptT $ fmap fst . runIdentity <$> enqueueMessageB c (Identity (Right (cData, [sq], Nothing, msgFlags, vrValue aMessage))) + ExceptT $ fmap fst . runIdentity <$> enqueueMessageB c (Identity (Right (Right (cData, [sq]), Nothing, msgFlags, vrValue aMessage))) {-# INLINE enqueueMessage #-} -- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries -enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) +enqueueMessageB :: forall t. Traversable t => AgentClient -> t (Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage)) -> AM' (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) enqueueMessageB c reqs = do cfg <- asks config (_, reqMids) <- unsafeWithStore c $ \db -> do mapAccumLM (\ids r -> storeSentMsg db cfg ids r `E.catchAny` \e -> (ids,) <$> handleInternal e) IM.empty reqs - forME reqMids $ \((cData, sq :| sqs, _, _, _), InternalId msgId, pqSecr) -> do + forME reqMids $ \((csqs_, _, _, _), InternalId msgId, pqSecr) -> forM csqs_ $ \(cData, sq :| sqs) -> do submitPendingMsg c cData sq let sqs' = filter isActiveSndQ sqs - pure $ Right ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId)) + pure ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId)) where - storeSentMsg :: DB.Connection -> AgentConfig -> IntMap (Int64, AMessage) -> Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage) -> IO (IntMap (Int64, AMessage), Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, ValueOrRef AMessage), InternalId, PQEncryption)) + storeSentMsg :: + DB.Connection -> + AgentConfig -> + IntMap (Maybe Int64, AMessage) -> + Either AgentErrorType (Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage) -> + IO (IntMap (Maybe Int64, AMessage), Either AgentErrorType ((Either AgentErrorType (ConnData, NonEmpty SndQueue), Maybe PQEncryption, MsgFlags, ValueOrRef AMessage), InternalId, PQEncryption)) storeSentMsg db cfg aMessageIds = \case Left e -> pure (aMessageIds, Left e) - Right req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, mbr) -> case mbr of + Right req@(csqs_, pqEnc_, msgFlags, mbr) -> case mbr of VRValue i_ aMessage -> case i_ >>= (`IM.lookup` aMessageIds) of Just _ -> pure (aMessageIds, Left $ INTERNAL "enqueueMessageB: storeSentMsg duplicate saved message body") Nothing -> do - mbId <- createSndMsgBody db aMessage - let aMessageIds' = maybe id (`IM.insert` (mbId, aMessage)) i_ aMessageIds - (aMessageIds',) <$> storeSentMsg_ mbId aMessage - VRRef i -> (aMessageIds,) <$> case IM.lookup i aMessageIds of - Just (mbId, aMessage) -> storeSentMsg_ mbId aMessage - Nothing -> pure $ Left $ INTERNAL "enqueueMessageB: storeSentMsg missing saved message body id" + (mbId_, r) <- case csqs_ of + Left e -> pure (Nothing, Left e) + Right (cData, sq :| _) -> do + mbId <- createSndMsgBody db aMessage + (Just mbId,) <$> storeSentMsg_ cData sq mbId aMessage + let aMessageIds' = maybe id (`IM.insert` (mbId_, aMessage)) i_ aMessageIds + pure (aMessageIds', r) + VRRef i -> case csqs_ of + Left e -> pure $ (aMessageIds, Left e) + Right (cData, sq :| _) -> case IM.lookup i aMessageIds of + Just (Just mbId, aMessage) -> (aMessageIds,) <$> storeSentMsg_ cData sq mbId aMessage + Just (Nothing, aMessage) -> do + mbId <- createSndMsgBody db aMessage + let aMessageIds' = IM.insert i (Just mbId, aMessage) aMessageIds + (aMessageIds',) <$> storeSentMsg_ cData sq mbId aMessage + Nothing -> pure (aMessageIds, Left $ INTERNAL "enqueueMessageB: storeSentMsg missing saved message body id") where - storeSentMsg_ sndMsgBodyId aMessage = fmap (first storeError) $ runExceptT $ do + storeSentMsg_ cData@ConnData {connId} sq sndMsgBodyId aMessage = fmap (first storeError) $ runExceptT $ do let AgentConfig {e2eEncryptVRange} = cfg internalTs <- liftIO getCurrentTime (internalId, internalSndId, prevMsgHash) <- ExceptT $ updateSndIds db connId From 62733ef4c139da106b135eee1e3ce07c77ba43bf Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 12 Jul 2025 14:18:38 +0100 Subject: [PATCH 20/22] smp server: refactor subscriptions and delivery in order to always response SOK on subscription with an optional message to follow. (#1573) * smp server: refactor subscriptions and delivery * metric for time between MSG and ACK * cleanup * refactor pattern match for ghc 8.10.7 * time buckets * split max time metric * histogram * fix --- src/Simplex/Messaging/Client.hs | 4 +- src/Simplex/Messaging/Protocol.hs | 4 + src/Simplex/Messaging/Server.hs | 320 +++++++++--------- src/Simplex/Messaging/Server/Env/STM.hs | 13 +- .../Messaging/Server/MsgStore/Journal.hs | 4 +- .../Messaging/Server/QueueStore/Postgres.hs | 21 +- .../Messaging/Server/QueueStore/STM.hs | 11 +- .../Messaging/Server/QueueStore/Types.hs | 2 +- tests/CoreTests/BatchingTests.hs | 31 ++ tests/ServerTests.hs | 62 +++- 10 files changed, 275 insertions(+), 197 deletions(-) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 4290aa2e7..5787db46b 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -1224,8 +1224,8 @@ okSMPCommands cmd c nm qs = L.map process <$> sendProtocolCommands c nm cs Left e -> Left e -- | Send SMP command -sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg -sendSMPCommand c nm pKey qId cmd = sendProtocolCommand c nm pKey qId (Cmd sParty cmd) +sendSMPCommand :: PartyI p => SMPClient -> NetworkRequestMode -> Maybe C.APrivateAuthKey -> EntityId -> Command p -> ExceptT SMPClientError IO BrokerMsg +sendSMPCommand c nm pKey entId cmd = sendProtocolCommand c nm pKey entId (Cmd sParty cmd) {-# INLINE sendSMPCommand #-} type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index b3a76f37e..4d5a2f551 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -114,6 +114,7 @@ module Simplex.Messaging.Protocol BasicAuth (..), SrvLoc (..), CorrId (..), + pattern NoCorrId, EntityId (..), pattern NoEntity, QueueId, @@ -1370,6 +1371,9 @@ newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show) deriving newtype (Encoding) +pattern NoCorrId :: CorrId +pattern NoCorrId = CorrId "" + instance IsString CorrId where fromString = CorrId . fromString {-# INLINE fromString #-} diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 7c0237e18..b440dfd7f 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -61,17 +61,18 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Constraint (Dict (..)) import Data.Dynamic (toDyn) import Data.Either (fromRight, partitionEithers) +import Data.Foldable (foldrM) import Data.Functor (($>)) import Data.IORef import Data.Int (Int64) import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS -import Data.List (foldl', intercalate, mapAccumR) +import Data.List (foldl', intercalate) 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 (catMaybes, fromMaybe, isJust, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Semigroup (Sum (..)) import qualified Data.Set as S import Data.Text (Text) @@ -271,6 +272,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt as'' <- if prevServiceId == serviceId_ then pure [] else endServiceSub prevServiceId qId END case serviceId_ of Just serviceId -> do + modifyTVar' totalServiceSubs (+ 1) -- server count for all services as <- endQueueSub qId END as' <- cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers pure $ as ++ as' ++ as'' @@ -282,8 +284,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt as <- endQueueSub qId DELD as' <- endServiceSub serviceId qId DELD pure $ as ++ as' - CSService serviceId -> do + CSService serviceId count -> do modifyTVar' subClients $ IS.insert clntId -- add ID to server's subscribed cients + modifyTVar' totalServiceSubs (+ count) -- server count for all services cancelServiceSubs serviceId =<< upsertSubscribedClient serviceId c serviceSubscribers updateSubDisconnected = case clntSub of -- do not insert client if it is already disconnected, but send END/DELD to any other client subscribed to this queue or service @@ -296,7 +299,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt as <- endQueueSub qId DELD as' <- endServiceSub serviceId qId DELD pure $ as ++ as' - CSService serviceId -> cancelServiceSubs serviceId =<< lookupSubscribedClient serviceId serviceSubscribers + CSService serviceId _ -> cancelServiceSubs serviceId =<< lookupSubscribedClient serviceId serviceSubscribers endQueueSub :: QueueId -> BrokerMsg -> STM [PrevClientSub s] endQueueSub qId msg = prevSub qId msg (CSAEndSub qId) =<< lookupDeleteSubscribedClient qId queueSubscribers endServiceSub :: Maybe ServiceId -> QueueId -> BrokerMsg -> STM [PrevClientSub s] @@ -382,7 +385,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt let cancelNtfs s = throwSTM $ userError $ s <> ", " <> show (length ts_) <> " ntfs kept" unlessM (currentClient readTVar c) $ cancelNtfs "not current client" whenM (isFullTBQueue sndQ) $ cancelNtfs "sending queue full" - writeTBQueue sndQ ts + writeTBQueue sndQ (ts, []) pure $ length ts_ currentClient :: Monad m => (forall a. TVar a -> m a) -> Client s' -> m Bool currentClient rd Client {clientId, connected} = (&&) <$> rd connected <*> (IS.member clientId <$> rd subClients) @@ -393,7 +396,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ntfs -> do writeTVar v [] pure $ foldl' (\acc' ntf -> nmsg nId ntf : acc') acc ntfs -- reverses, to order by time - nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (CorrId "", nId, NMSG ntfNonce ntfEncMeta) + nmsg nId MsgNtf {ntfNonce, ntfEncMeta} = (NoCorrId, nId, NMSG ntfNonce ntfEncMeta) updateNtfStats :: Client s' -> Either SomeException Int -> IO () updateNtfStats Client {clientId} = \case Right 0 -> pure () @@ -419,14 +422,14 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt where enqueueEvts evts c@Client {connected, sndQ} = whenM (readTVarIO connected) $ do - sent <- atomically $ tryWriteTBQueue sndQ ts + sent <- atomically $ tryWriteTBQueue sndQ (ts, []) if sent then updateEndStats else -- if queue is full it can block - forkClient c ("sendPendingEvtsThread.queueEvts") $ - atomically (writeTBQueue sndQ ts) >> updateEndStats + forkClient c "sendPendingEvtsThread.queueEvts" $ + atomically (writeTBQueue sndQ (ts, [])) >> updateEndStats where - ts = L.map (\(entId, evt) -> (CorrId "", entId, evt)) evts + ts = L.map (\(entId, evt) -> (NoCorrId, entId, evt)) evts -- this accounts for both END and DELD events updateEndStats = do let len = L.length evts @@ -703,7 +706,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt then (metrics {subsCount = subsCount metrics + cnt, subClientsCount = subClientsCount metrics + 1}, times') else acc countSubs acc@(!cnt, times) Sub {delivered} = do - delivered_ <- atomically $ tryReadTMVar delivered + delivered_ <- readTVarIO delivered pure $ case delivered_ of Nothing -> acc Just (_, ts) -> (cnt + 1, updateTimeBuckets ts ts' times) @@ -1095,7 +1098,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime let (es, ts') = partitionEithers $ L.toList ts errs = map (second ERR) es - case ts' of + errs' <- case ts' of (_, _, (_, _, Cmd p cmd)) : rest -> do let service = peerClientService =<< thAuth (errs', cmds) <- partitionEithers <$> case batchParty p of @@ -1105,9 +1108,10 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, qs <- getQueueRecs ms p $ map queueId ts' zipWithM (\t -> verified stats t . verifyLoadedQueue service thAuth t) ts' qs _ -> mapM (\t -> verified stats t =<< verifyTransmission ms service thAuth t) ts' - write rcvQ cmds - write sndQ $ errs ++ errs' - [] -> write sndQ errs + mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds + pure $ errs ++ errs' + [] -> pure errs + mapM_ (atomically . writeTBQueue sndQ . (,[])) $ L.nonEmpty errs' where sameParty :: SParty p -> SignedTransmission Cmd -> Bool sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p' @@ -1129,32 +1133,27 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, NSUB -> incStat $ ntfSubAuth stats GET -> incStat $ msgGetAuth stats _ -> pure () - write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO () send th c@Client {sndQ, msgQ, clientTHParams = THandleParams {sessionId}} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send" forever $ atomically (readTBQueue sndQ) >>= sendTransmissions where - sendTransmissions :: NonEmpty (Transmission BrokerMsg) -> IO () - sendTransmissions ts - | L.length ts <= 2 = tSend th c ts + -- If the request had batched subscriptions + -- this will reply SOKs to all SUBs in the first batched transmission, + -- to reduce client timeouts. + -- After that all messages will be sent in separate transmissions, + -- without any client response timeouts, and allowing them to interleave + -- with other requests responses. + sendTransmissions :: (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO () + sendTransmissions (ts, []) = tSend th c ts + sendTransmissions (ts, msg : msgs) + | length ts <= 4 = do -- up to 4 SOKs can be in one block with MSG (see testBatchSubResponses test) + tSend th c $ ts <> [msg] + mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs | otherwise = do - let (msgs_, ts') = mapAccumR splitMessages [] ts - -- If the request had batched subscriptions and L.length ts > 2 - -- this will reply OK to all SUBs in the first batched transmission, - -- to reduce client timeouts. - tSend th c ts' - -- After that all messages will be sent in separate transmissions, - -- without any client response timeouts, and allowing them to interleave - -- with other requests responses. - mapM_ (atomically . writeTBQueue msgQ) $ L.nonEmpty msgs_ - where - splitMessages :: [Transmission BrokerMsg] -> Transmission BrokerMsg -> ([Transmission BrokerMsg], Transmission BrokerMsg) - splitMessages msgs t@(corrId, entId, cmd) = case cmd of - -- replace MSG response with OK, accumulating MSG in a separate list. - MSG {} -> ((CorrId "", entId, cmd) : msgs, (corrId, entId, OK)) - _ -> (msgs, t) + tSend th c ts + atomically $ writeTBQueue msgQ (msg :| msgs) sendMsg :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO () sendMsg th c@Client {msgQ, clientTHParams = THandleParams {sessionId}} = do @@ -1200,7 +1199,7 @@ verifyLoadedQueue service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case Left e -> VRFailed e verifyQueueTransmission :: forall s. Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s -verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, command@(Cmd p cmd))) q_ +verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_ | not checkRole = VRFailed $ CMD PROHIBITED | not verifyServiceSig = VRFailed SERVICE | otherwise = vc p cmd @@ -1226,8 +1225,8 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, _, command@( verify = verifyCmdAuthorization thAuth tAuth authorized' corrId verifyServiceCmd :: VerificationResult s verifyServiceCmd = case (service, tAuth) of - (Just THClientService {serviceKey = k}, Just (TASignature (C.ASignature C.SEd25519 s), Nothing)) - | C.verify' k s authorized -> VRVerified Nothing + (Just THClientService {serviceId, serviceKey = k}, Just (TASignature (C.ASignature C.SEd25519 s), Nothing)) + | entId == serviceId && C.verify' k s authorized -> VRVerified Nothing _ -> VRFailed SERVICE -- this function verify service signature for commands that use it in service sessions verifyServiceSig @@ -1321,19 +1320,20 @@ client -- TODO [certs rcv] rcv subscriptions Server {subscribers, ntfSubscribers} ms - clnt@Client {clientId, subscriptions, ntfSubscriptions, ntfServiceSubscribed, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do + clnt@Client {clientId, ntfSubscriptions, ntfServiceSubscribed, serviceSubsCount = _todo', ntfServiceSubsCount, rcvQ, sndQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" let THandleParams {thVersion} = thParams' - service = peerClientService =<< thAuth thParams' + clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams') + process t acc@(rs, msgs) = + (maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_))) + <$> processCommand clntServiceId thVersion t forever $ atomically (readTBQueue rcvQ) - >>= mapM (processCommand service thVersion) - >>= mapM_ reply . L.nonEmpty . catMaybes . L.toList + >>= foldrM process ([], []) + >>= \(rs_, msgs) -> mapM_ (atomically . writeTBQueue sndQ . (,msgs)) (L.nonEmpty rs_) where - reply :: MonadIO m => NonEmpty (Transmission BrokerMsg) -> m () - reply = atomically . writeTBQueue sndQ - processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M s (Maybe (Transmission BrokerMsg)) - processProxiedCmd (corrId, EntityId sessId, command) = (corrId,EntityId sessId,) <$$> case command of + processProxiedCmd :: Transmission (Command 'ProxiedClient) -> M s (Maybe ResponseAndMessage) + processProxiedCmd (corrId, EntityId sessId, command) = (\t -> ((corrId, EntityId sessId, t), Nothing)) <$$> case command of PRXY srv auth -> ifM allowProxy getRelay (pure $ Just $ ERR $ PROXY BASIC_AUTH) where allowProxy = do @@ -1396,7 +1396,7 @@ client forkProxiedCmd cmdAction = do bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do -- commands MUST be processed under a reasonable timeout or the client would halt - cmdAction >>= \t -> reply [(corrId, EntityId sessId, t)] + cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, EntityId sessId, t)], []) pure Nothing where wait = do @@ -1412,32 +1412,32 @@ client mkIncProxyStats ps psOwn own sel = do incStat $ sel ps when own $ incStat $ sel psOwn - processCommand :: Maybe THPeerClientService -> VersionSMP -> VerifiedTransmission s -> M s (Maybe (Transmission BrokerMsg)) - processCommand service clntVersion (q_, (corrId, entId, cmd)) = case cmd of + processCommand :: Maybe ServiceId -> VersionSMP -> VerifiedTransmission s -> M s (Maybe ResponseAndMessage) + processCommand clntServiceId clntVersion (q_, (corrId, entId, cmd)) = case cmd of Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command) - Cmd SSender command -> Just <$> case command of + Cmd SSender command -> case command of SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k - SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody - Cmd SIdleClient PING -> pure $ Just (corrId, NoEntity, PONG) - Cmd SProxyService (RFWD encBlock) -> Just . (corrId,NoEntity,) <$> processForwardedCommand encBlock - Cmd SSenderLink command -> Just <$> case command of + SEND flags msgBody -> response <$> withQueue_ False err (sendMessage flags msgBody) + Cmd SIdleClient PING -> pure $ response (corrId, NoEntity, PONG) + Cmd SProxyService (RFWD encBlock) -> response . (corrId,NoEntity,) <$> processForwardedCommand encBlock + Cmd SSenderLink command -> case command of LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr - Cmd SNotifier NSUB -> Just . (corrId,entId,) <$> case q_ of + Cmd SNotifier NSUB -> response . (corrId,entId,) <$> case q_ of Just (q, QueueRec {notifier = Just ntfCreds}) -> subscribeNotifications q ntfCreds _ -> pure $ ERR INTERNAL - Cmd SNotifierService NSUBS -> Just . (corrId,entId,) <$> case service of - Just s -> subscribeServiceNotifications s + Cmd SNotifierService NSUBS -> response . (corrId,entId,) <$> case clntServiceId of + Just serviceId -> subscribeServiceNotifications serviceId Nothing -> pure $ ERR INTERNAL Cmd SCreator (NEW nqr@NewQueueReq {auth_}) -> - Just <$> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH)) + response <$> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH)) where allowNew = do ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config pure $ allowNewQueues && maybe True ((== auth_) . Just) newQueueBasicAuth Cmd SRecipient command -> - Just <$> case command of - SUB -> withQueue subscribeQueue + case command of + SUB -> withQueue' subscribeQueueAndDeliver GET -> withQueue getMessage ACK msgId -> withQueue $ acknowledgeMsg msgId KEY sKey -> withQueue $ \q _ -> either err (corrId,entId,) <$> secureQueue_ q sKey @@ -1453,15 +1453,15 @@ client Nothing -> pure ok NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q - OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_ - DEL -> maybe (pure $ err INTERNAL) delQueueAndMsgs q_ + OFF -> response <$> maybe (pure $ err INTERNAL) suspendQueue_ q_ + DEL -> response <$> maybe (pure $ err INTERNAL) delQueueAndMsgs q_ QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr - Cmd SRecipientService SUBS -> pure $ Just $ err (CMD PROHIBITED) -- "TODO [certs rcv]" + Cmd SRecipientService SUBS -> pure $ response $ err (CMD PROHIBITED) -- "TODO [certs rcv]" where createQueue :: NewQueueReq -> M s (Transmission BrokerMsg) createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData} - | isJust service && subMode == SMOnlyCreate = pure (corrId, entId, ERR $ CMD PROHIBITED) - | otherwise = time "NEW" $ do + | isJust clntServiceId && subMode == SMOnlyCreate = pure (corrId, entId, ERR $ CMD PROHIBITED) + | otherwise = do g <- asks random idSize <- asks $ queueIdBytes . config updatedAt <- Just <$> liftIO getSystemDate @@ -1491,7 +1491,6 @@ client -- notifierId <- randId -- pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey) let queueMode = queueReqMode <$> queueReqData - rcvServiceId = (\THClientService {serviceId} -> serviceId) <$> service qr = QueueRec { senderId = sndId, @@ -1504,7 +1503,7 @@ client notifier = Nothing, -- fst <$> ntf, status = EntityActive, updatedAt, - rcvServiceId + rcvServiceId = clntServiceId } liftIO (addQueue ms rcvId qr) >>= \case Left DUPLICATE_ -- TODO [short links] possibly, we somehow need to understand which IDs caused collision to retry if it's not client-supplied? @@ -1519,8 +1518,8 @@ client -- when (isJust ntf) $ incStat $ ntfCreated stats case subMode of SMOnlyCreate -> pure () - SMSubscribe -> void $ subscribeNewQueue rcvId qr -- no need to check if message is available, it's a new queue - pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = rcvServiceId} -- , serverNtfCreds = snd <$> ntf + SMSubscribe -> subscribeNewQueue rcvId qr -- no need to check if message is available, it's a new queue + pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = clntServiceId} -- , serverNtfCreds = snd <$> ntf (corrId,entId,) <$> tryCreate (3 :: Int) -- this check allows to support contact queues created prior to SKEY, @@ -1544,7 +1543,7 @@ client getQueueLink_ q qr = liftIO $ LNK (senderId qr) <$$> getQueueLinkData (queueStore ms) q entId addQueueNotifier_ :: StoreQueue s -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M s (Transmission BrokerMsg) - addQueueNotifier_ q notifierKey dhKey = time "NKEY" $ do + addQueueNotifier_ q notifierKey dhKey = do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvNtfDhSecret = C.dh' dhKey privDhKey (corrId,entId,) <$> addNotifierRetry 3 rcvPublicDhKey rcvNtfDhSecret @@ -1581,47 +1580,60 @@ client suspendQueue_ (q, _) = liftIO $ either err (const ok) <$> suspendQueue (queueStore ms) q -- TODO [certs rcv] if serviceId is passed, associate with the service and respond with SOK - subscribeQueue :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg) - subscribeQueue q qr = - liftIO (TM.lookupIO rId subscriptions) >>= \case - Nothing -> subscribeNewQueue rId qr >>= deliver True + subscribeQueueAndDeliver :: StoreQueue s -> QueueRec -> M s ResponseAndMessage + subscribeQueueAndDeliver q qr = + liftIO (TM.lookupIO entId $ subscriptions clnt) >>= \case + Nothing -> subscribeRcvQueue qr >>= deliver True Just s@Sub {subThread} -> do stats <- asks serverStats case subThread of ProhibitSub -> do -- cannot use SUB in the same connection where GET was used incStat $ qSubProhibited stats - pure (corrId, rId, ERR $ CMD PROHIBITED) + pure (err (CMD PROHIBITED), Nothing) _ -> do incStat $ qSubDuplicate stats - atomically (tryTakeTMVar $ delivered s) >> deliver False s + atomically (writeTVar (delivered s) Nothing) >> deliver False s where - rId = recipientId q - deliver :: Bool -> Sub -> M s (Transmission BrokerMsg) - deliver inc sub = do + deliver :: Bool -> Sub -> M s ResponseAndMessage + deliver hasSub sub = do stats <- asks serverStats - fmap (either (\e -> (corrId, rId, ERR e)) id) $ liftIO $ runExceptT $ do + fmap (either ((,Nothing) . err) id) $ liftIO $ runExceptT $ do msg_ <- tryPeekMsg ms q - liftIO $ when (inc && isJust msg_) $ incStat (qSub stats) - liftIO $ deliverMessage "SUB" qr rId sub msg_ + msg' <- forM msg_ $ \msg -> liftIO $ do + ts <- getSystemSeconds + atomically $ setDelivered sub msg ts + unless hasSub $ incStat $ qSub stats + pure (NoCorrId, entId, MSG (encryptMsg qr msg)) + pure ((corrId, entId, SOK clntServiceId), msg') - subscribeNewQueue :: RecipientId -> QueueRec -> M s Sub - subscribeNewQueue rId QueueRec {rcvServiceId} = time "SUB newSub" . atomically $ do - writeTQueue (subQ subscribers) (CSClient rId rcvServiceId Nothing, clientId) + -- TODO [certs rcv] combine with subscribing ntf queues + subscribeRcvQueue :: QueueRec -> M s Sub + subscribeRcvQueue QueueRec {rcvServiceId} = atomically $ do + writeTQueue (subQ subscribers) (CSClient entId rcvServiceId Nothing, clientId) sub <- newSubscription NoSub - TM.insert rId sub subscriptions + TM.insert entId sub $ subscriptions clnt pure sub + subscribeNewQueue :: RecipientId -> QueueRec -> M s () + subscribeNewQueue rId QueueRec {rcvServiceId} = do + case rcvServiceId of + Just _ -> atomically $ modifyTVar' (serviceSubsCount clnt) (+ 1) + Nothing -> do + sub <- atomically $ newSubscription NoSub + atomically $ TM.insert rId sub $ subscriptions clnt + atomically $ writeTQueue (subQ subscribers) (CSClient rId rcvServiceId rcvServiceId, clientId) + -- clients that use GET are not added to server subscribers getMessage :: StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg) - getMessage q qr = time "GET" $ do - atomically (TM.lookup entId subscriptions) >>= \case + getMessage q qr = do + atomically (TM.lookup entId $ subscriptions clnt) >>= \case Nothing -> atomically newSub >>= (`getMessage_` Nothing) Just s@Sub {subThread} -> case subThread of ProhibitSub -> - atomically (tryTakeTMVar $ delivered s) + atomically (swapTVar (delivered s) Nothing) >>= getMessage_ s -- cannot use GET in the same connection where there is an active subscription _ -> do @@ -1632,7 +1644,7 @@ client newSub :: STM Sub newSub = do s <- newProhibitedSub - TM.insert entId s subscriptions + TM.insert entId s $ subscriptions clnt -- Here we don't account for this client as subscribed in the server -- and don't notify other subscribed clients. -- This is tracked as "subscription" in the client to prevent these @@ -1650,27 +1662,32 @@ client atomically $ setDelivered s msg ts $> (corrId, entId, MSG encMsg) Nothing -> incStat (msgGetNoMsg stats) $> ok - withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Transmission BrokerMsg) - withQueue = withQueue_ True + withQueue :: (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Maybe ResponseAndMessage) + withQueue = fmap response . withQueue_ True err + {-# INLINE withQueue #-} + + withQueue' :: (StoreQueue s -> QueueRec -> M s ResponseAndMessage) -> M s (Maybe ResponseAndMessage) + withQueue' = fmap Just . withQueue_ True ((,Nothing) . err) + {-# INLINE withQueue' #-} -- SEND passes queueNotBlocked False here to update time, but it fails anyway on blocked queues (see code for SEND). - withQueue_ :: Bool -> (StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg)) -> M s (Transmission BrokerMsg) - withQueue_ queueNotBlocked action = case q_ of - Nothing -> pure $ err INTERNAL + withQueue_ :: Bool -> (ErrorType -> r) -> (StoreQueue s -> QueueRec -> M s r) -> M s r + withQueue_ queueNotBlocked err' action = case q_ of + Nothing -> pure $ err' INTERNAL Just (q, qr@QueueRec {status, updatedAt}) -> case status of - EntityBlocked info | queueNotBlocked -> pure $ err $ BLOCKED info + EntityBlocked info | queueNotBlocked -> pure $ err' $ BLOCKED info _ -> do t <- liftIO getSystemDate if updatedAt == Just t then action q qr - else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err) (action q) + else liftIO (updateQueueTime (queueStore ms) q t) >>= either (pure . err') (action q) subscribeNotifications :: StoreQueue s -> NtfCreds -> M s BrokerMsg subscribeNotifications q NtfCreds {ntfServiceId} = do stats <- asks serverStats let incNtfSrvStat sel = incStat $ sel $ ntfServices stats - case service of - Just THClientService {serviceId} + case clntServiceId of + Just serviceId | ntfServiceId == Just serviceId -> do -- duplicate queue-service association - can only happen in case of response error/timeout hasSub <- atomically $ ifM hasServiceSub (pure True) (False <$ newServiceQueueSub) @@ -1719,25 +1736,25 @@ client incStat $ if hasSub then ntfSubDuplicate stats else ntfSub stats pure $ SOK Nothing - subscribeServiceNotifications :: THPeerClientService -> M s BrokerMsg - subscribeServiceNotifications THClientService {serviceId} = do + subscribeServiceNotifications :: ServiceId -> M s BrokerMsg + subscribeServiceNotifications serviceId = do subscribed <- readTVarIO ntfServiceSubscribed if subscribed then SOKS <$> readTVarIO ntfServiceSubsCount else - liftIO (getNtfServiceQueueCount @(StoreQueue s) (queueStore ms) serviceId) >>= \case + liftIO (getServiceQueueCount @(StoreQueue s) (queueStore ms) SNotifierService serviceId) >>= \case Left e -> pure $ ERR e Right !count' -> do - atomically $ do + incCount <- atomically $ do writeTVar ntfServiceSubscribed True count <- swapTVar ntfServiceSubsCount count' - modifyTVar' (totalServiceSubs ntfSubscribers) (+ (count' - count)) -- server count for all services - atomically $ writeTQueue (subQ ntfSubscribers) (CSService serviceId, clientId) + pure $ count' - count + atomically $ writeTQueue (subQ ntfSubscribers) (CSService serviceId incCount, clientId) pure $ SOKS count' acknowledgeMsg :: MsgId -> StoreQueue s -> QueueRec -> M s (Transmission BrokerMsg) - acknowledgeMsg msgId q qr = time "ACK" $ do - liftIO (TM.lookupIO entId subscriptions) >>= \case + acknowledgeMsg msgId q qr = + liftIO (TM.lookupIO entId $ subscriptions clnt) >>= \case Nothing -> pure $ err NO_MSG Just sub -> atomically (getDelivered sub) >>= \case @@ -1751,16 +1768,20 @@ client pure ok _ -> do (deletedMsg_, msg_) <- tryDelPeekMsg ms q msgId - liftIO $ mapM_ (updateStats stats False ts) deletedMsg_ - liftIO $ deliverMessage "ACK" qr entId sub msg_ + liftIO $ do + mapM_ (updateStats stats False ts) deletedMsg_ + forM_ msg_ $ \msg -> do + ts <- getSystemSeconds + atomically $ setDelivered sub msg ts + pure (corrId, entId, maybe OK (MSG . encryptMsg qr) msg_) _ -> pure $ err NO_MSG where getDelivered :: Sub -> STM (Maybe (ServerSub, RoundedSystemTime)) getDelivered Sub {delivered, subThread} = do - tryTakeTMVar delivered $>>= \v@(msgId', ts) -> + readTVar delivered $>>= \(msgId', ts) -> if msgId == msgId' || B.null msgId - then pure $ Just (subThread, ts) - else putTMVar delivered v $> Nothing + then writeTVar delivered Nothing $> Just (subThread, ts) + else pure Nothing updateStats :: ServerStats -> Bool -> RoundedSystemTime -> Message -> IO () updateStats stats isGet deliveryTime = \case MessageQuota {} -> pure () @@ -1805,7 +1826,7 @@ client deleteQueueLinkData (queueStore ms) q ServerConfig {messageExpiration, msgIdBytes} <- asks config msgId <- randomId' msgIdBytes - msg_ <- liftIO $ time "SEND" $ runExceptT $ do + msg_ <- liftIO $ runExceptT $ do expireMessages messageExpiration stats msg <- liftIO $ mkMessage msgId body writeMsg ms q True msg @@ -1814,7 +1835,7 @@ client Right Nothing -> do incStat $ msgSentQuota stats pure $ err QUOTA - Right (Just (msg, wasEmpty)) -> time "SEND ok" $ do + Right (Just (msg, wasEmpty)) -> do when wasEmpty $ liftIO $ tryDeliverMessage msg when (notification msgFlags) $ do mapM_ (`enqueueNotification` msg) (notifier qr) @@ -1855,17 +1876,17 @@ client deliverToSub rcv = do ts <- getSystemSeconds atomically $ - -- reading client TVar in the same transaction, - -- so that if subscription ends, it re-evalutates - -- and delivery is cancelled - - -- the new client will receive message in response to SUB. + -- reading client TVar in the same transaction, + -- so that if subscription ends, it re-evalutates + -- and delivery is cancelled - + -- the new client will receive message in response to SUB. readTVar rcv $>>= \rc@Client {subscriptions = subs, sndQ = sndQ'} -> TM.lookup rId subs $>>= \s@Sub {subThread, delivered} -> case subThread of ProhibitSub -> pure Nothing ServerSub st -> readTVar st >>= \case NoSub -> - tryTakeTMVar delivered >>= \case + readTVar delivered >>= \case Just _ -> pure Nothing -- if a message was already delivered, should not deliver more Nothing -> ifM @@ -1875,8 +1896,8 @@ client _ -> pure Nothing deliver sndQ' s ts = do let encMsg = encryptMsg qr msg - writeTBQueue sndQ' [(CorrId "", rId, MSG encMsg)] - void $ setDelivered s msg ts + writeTBQueue sndQ' ([(NoCorrId, rId, MSG encMsg)], []) + setDelivered s msg ts forkDeliver (rc@Client {sndQ = sndQ'}, s@Sub {delivered}, st) = do t <- mkWeakThreadId =<< forkIO deliverThread atomically $ modifyTVar' st $ \case @@ -1889,10 +1910,10 @@ client -- lookup can be outside of STM transaction, -- as long as the check that it is the same client is inside. getSubscribedClient rId (queueSubscribers subscribers) >>= mapM_ deliverIfSame - deliverIfSame rcv = time "deliver" $ do + deliverIfSame rcv = do ts <- getSystemSeconds atomically $ whenM (sameClient rc rcv) $ - tryTakeTMVar delivered >>= \case + readTVar delivered >>= \case Just _ -> pure () -- if a message was already delivered, should not deliver more Nothing -> do -- a separate thread is needed because it blocks when client sndQ is full. @@ -1936,7 +1957,8 @@ client Left r -> pure r -- 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 Nothing fwdVersion t'') + -- `fst` removes empty message that is only returned for `SUB` command + Right t''@(_, (corrId', entId', _)) -> maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing fwdVersion t'') -- encode response r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right @@ -1969,22 +1991,6 @@ client VRVerified q -> Right (q, t'') VRFailed e -> Left (corrId', entId', ERR e) - deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> IO (Transmission BrokerMsg) - deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") $ - case subThread of - ProhibitSub -> pure resp - _ -> case msg_ of - Just msg -> do - ts <- getSystemSeconds - let encMsg = encryptMsg qr msg - atomically (setDelivered s msg ts) $> (corrId, rId, MSG encMsg) - _ -> pure resp - where - resp = (corrId, rId, OK) - - time :: MonadIO m => T.Text -> m a -> m a - time name = timed name entId - encryptMsg :: QueueRec -> Message -> RcvMessage encryptMsg qr msg = encrypt . encodeRcvMsgBody $ case msg of Message {msgFlags, msgBody} -> RcvMsgBody {msgTs = msgTs', msgFlags, msgBody} @@ -1995,21 +2001,21 @@ client msgId' = messageId msg msgTs' = messageTs msg - setDelivered :: Sub -> Message -> RoundedSystemTime -> STM Bool + setDelivered :: Sub -> Message -> RoundedSystemTime -> STM () setDelivered Sub {delivered} msg !ts = do let !msgId = messageId msg - tryPutTMVar delivered (msgId, ts) + writeTVar delivered $ Just (msgId, ts) delQueueAndMsgs :: (StoreQueue s, QueueRec) -> M s (Transmission BrokerMsg) delQueueAndMsgs (q, QueueRec {rcvServiceId}) = do liftIO (deleteQueue ms q) >>= \case Right qr -> do -- Possibly, the same should be done if the queue is suspended, but currently we do not use it - atomically $ do - writeTQueue (subQ subscribers) (CSDeleted entId rcvServiceId, clientId) - -- queue is usually deleted by the same client that is currently subscribed, - -- we delete subscription here, so the client with no subscriptions can be disconnected. - TM.delete entId subscriptions + -- queue is usually deleted by the same client that is currently subscribed, + -- we delete subscription here, so the client with no subscriptions can be disconnected. + sub <- atomically $ TM.lookupDelete entId $ subscriptions clnt + liftIO $ mapM_ cancelSub sub + atomically $ writeTQueue (subQ subscribers) (CSDeleted entId rcvServiceId, clientId) forM_ (notifier qr) $ \NtfCreds {notifierId = nId, ntfServiceId} -> do -- queue is deleted by a different client from the one subscribed to notifications, -- so we don't need to remove subscription from the current client. @@ -2024,7 +2030,7 @@ client getQueueInfo :: StoreQueue s -> QueueRec -> M s BrokerMsg getQueueInfo q QueueRec {senderKey, notifier} = do fmap (either ERR INFO) $ liftIO $ runExceptT $ do - qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub + qiSub <- liftIO $ TM.lookupIO entId (subscriptions clnt) >>= mapM mkQSub qiSize <- getQueueSize ms q qiMsg <- toMsgInfo <$$> tryPeekMsg ms q let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg} @@ -2039,14 +2045,20 @@ client SubPending -> QSubPending SubThread _ -> QSubThread ProhibitSub -> pure QProhibitSub - qDelivered <- atomically $ decodeLatin1 . encode . fst <$$> tryReadTMVar delivered + qDelivered <- decodeLatin1 . encode . fst <$$> readTVarIO delivered pure QSub {qSubThread, qDelivered} ok :: Transmission BrokerMsg ok = (corrId, entId, OK) + {-# INLINE ok #-} err :: ErrorType -> Transmission BrokerMsg err e = (corrId, entId, ERR e) + {-# INLINE err #-} + + response :: Transmission BrokerMsg -> Maybe ResponseAndMessage + response = Just . (,Nothing) + {-# INLINE response #-} updateDeletedStats :: QueueRec -> M s () updateDeletedStats q = do @@ -2060,18 +2072,6 @@ incStat :: MonadIO m => IORef Int -> m () incStat r = liftIO $ atomicModifyIORef'_ r (+ 1) {-# INLINE incStat #-} -timed :: MonadIO m => T.Text -> RecipientId -> m a -> m a -timed name (EntityId qId) a = do - t <- liftIO getSystemTime - r <- a - t' <- liftIO getSystemTime - let int = diff t t' - when (int > sec) . logDebug $ T.unwords [name, tshow $ encode qId, tshow int] - pure r - where - diff t t' = (systemSeconds t' - systemSeconds t) * sec + fromIntegral (systemNanoseconds t' - systemNanoseconds t) - sec = 1000_000000 - randomId' :: Int -> M s ByteString randomId' n = atomically . C.randomBytes n =<< asks random diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 8039a252e..4d0de07a6 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -40,6 +40,7 @@ module Simplex.Messaging.Server.Env.STM MsgStore (..), AStoreType (..), VerifiedTransmission, + ResponseAndMessage, newEnv, mkJournalStoreConfig, msgStore, @@ -377,7 +378,7 @@ sameClient c cv = maybe False (sameClientId c) <$> readTVar cv data ClientSub = CSClient QueueId (Maybe ServiceId) (Maybe ServiceId) -- includes previous and new associated service IDs | CSDeleted QueueId (Maybe ServiceId) -- includes previously associated service IDs - | CSService ServiceId -- only send END to idividual client subs on message delivery, not of SSUB/NSSUB + | CSService ServiceId Int64 -- only send END to idividual client subs on message delivery, not of SSUB/NSSUB newtype ProxyAgent = ProxyAgent { smpAgent :: SMPClientAgent 'Sender @@ -394,7 +395,7 @@ data Client s = Client serviceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count ntfServiceSubsCount :: TVar Int64, -- only one service can be subscribed, based on its certificate, this is subscription count rcvQ :: TBQueue (NonEmpty (VerifiedTransmission s)), - sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)), + sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]), msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)), procThreads :: TVar Int, endThreads :: TVar (IntMap (Weak ThreadId)), @@ -408,13 +409,15 @@ data Client s = Client type VerifiedTransmission s = (Maybe (StoreQueue s, QueueRec), Transmission Cmd) +type ResponseAndMessage = (Transmission BrokerMsg, Maybe (Transmission BrokerMsg)) + data ServerSub = ServerSub (TVar SubscriptionThread) | ProhibitSub data SubscriptionThread = NoSub | SubPending | SubThread (Weak ThreadId) data Sub = Sub { subThread :: ServerSub, -- Nothing value indicates that sub - delivered :: TMVar (MsgId, RoundedSystemTime) + delivered :: TVar (Maybe (MsgId, RoundedSystemTime)) } newServer :: IO (Server s) @@ -497,13 +500,13 @@ newClient clientId qSize clientTHParams createdAt = do newSubscription :: SubscriptionThread -> STM Sub newSubscription st = do - delivered <- newEmptyTMVar + delivered <- newTVar Nothing subThread <- ServerSub <$> newTVar st return Sub {subThread, delivered} newProhibitedSub :: STM Sub newProhibitedSub = do - delivered <- newEmptyTMVar + delivered <- newTVar Nothing return Sub {subThread = ProhibitSub, delivered} newEnv :: ServerConfig s -> IO (Env s) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 59357f0af..78f9c1393 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -356,8 +356,8 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where {-# INLINE setQueueService #-} getQueueNtfServices = withQS (getQueueNtfServices @(JournalQueue s)) {-# INLINE getQueueNtfServices #-} - getNtfServiceQueueCount = withQS (getNtfServiceQueueCount @(JournalQueue s)) - {-# INLINE getNtfServiceQueueCount #-} + getServiceQueueCount = withQS (getServiceQueueCount @(JournalQueue s)) + {-# INLINE getServiceQueueCount #-} makeQueue_ :: JournalMsgStore s -> RecipientId -> QueueRec -> Lock -> IO (JournalQueue s) makeQueue_ JournalMsgStore {sharedLock} rId qr queueLock = do diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index aa1a006e2..6dd286620 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -43,14 +43,13 @@ import qualified Data.ByteString.Builder as BB import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy as LB import Data.Bitraversable (bimapM) -import Data.Either (fromRight, lefts, rights) +import Data.Either (fromRight, lefts) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (foldl', intersperse, partition) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Set as S import Data.Text (Text) import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -65,7 +64,7 @@ import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation) import Database.PostgreSQL.Simple.SqlQQ (sql) import GHC.IO (catchAny) -import Simplex.Messaging.Agent.Client (withLockMap, withLocksMap) +import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.AgentStore () import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) @@ -84,7 +83,7 @@ import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (SMPServiceRole (..)) -import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, tshow, (<$$>), ($>>=)) +import Simplex.Messaging.Util (eitherToMaybe, firstRow, ifM, maybeFirstRow, tshow, (<$$>)) import System.Exit (exitFailure) import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM @@ -485,11 +484,15 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs' in ((serviceId, sNtfs) : ssNtfs, restNtfs) - getNtfServiceQueueCount :: PostgresQueueStore q -> ServiceId -> IO (Either ErrorType Int64) - getNtfServiceQueueCount st serviceId = - E.uninterruptibleMask_ $ runExceptT $ withDB' "getNtfServiceQueueCount" st $ \db -> + getServiceQueueCount :: (PartyI p, ServiceParty p) => PostgresQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64) + getServiceQueueCount st party serviceId = + E.uninterruptibleMask_ $ runExceptT $ withDB' "getServiceQueueCount" st $ \db -> fmap (fromMaybe 0) $ maybeFirstRow fromOnly $ - DB.query db "SELECT count(1) FROM msg_queues WHERE ntf_service_id = ? AND deleted_at IS NULL" (Only serviceId) + DB.query db query (Only serviceId) + where + query = case party of + SRecipientService -> "SELECT count(1) FROM msg_queues WHERE rcv_service_id = ? AND deleted_at IS NULL" + SNotifierService -> "SELECT count(1) FROM msg_queues WHERE ntf_service_id = ? AND deleted_at IS NULL" batchInsertServices :: [STMService] -> PostgresQueueStore q -> IO Int64 batchInsertServices services' toStore = diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index 5c16825d2..4dd6240a8 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -346,10 +346,15 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where let (sNtfs, restNtfs) = partition (\(nId, _) -> S.member nId snIds) ntfs' pure ((Just serviceId, sNtfs) : ssNtfs, restNtfs) - getNtfServiceQueueCount :: STMQueueStore q -> ServiceId -> IO (Either ErrorType Int64) - getNtfServiceQueueCount st serviceId = + getServiceQueueCount :: (PartyI p, ServiceParty p) => STMQueueStore q -> SParty p -> ServiceId -> IO (Either ErrorType Int64) + getServiceQueueCount st party serviceId = TM.lookupIO serviceId (services st) >>= - maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceNtfQueues) + maybe (pure $ Left AUTH) (fmap (Right . fromIntegral . S.size) . readTVarIO . serviceSel) + where + serviceSel :: STMService -> TVar (Set QueueId) + serviceSel = case party of + SRecipientService -> serviceRcvQueues + SNotifierService -> serviceNtfQueues withQueueRec :: TVar (Maybe QueueRec) -> (QueueRec -> STM a) -> IO (Either ErrorType a) withQueueRec qr a = atomically $ readQueueRec qr >>= mapM a diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs index 104d62267..55be4d21d 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Types.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -48,7 +48,7 @@ class StoreQueueClass q => QueueStoreClass q s where getCreateService :: s -> ServiceRec -> IO (Either ErrorType ServiceId) setQueueService :: (PartyI p, ServiceParty p) => s -> q -> SParty p -> Maybe ServiceId -> IO (Either ErrorType ()) getQueueNtfServices :: s -> [(NotifierId, a)] -> IO (Either ErrorType ([(Maybe ServiceId, [(NotifierId, a)])], [(NotifierId, a)])) - getNtfServiceQueueCount :: s -> ServiceId -> IO (Either ErrorType Int64) + getServiceQueueCount :: (PartyI p, ServiceParty p) => s -> SParty p -> ServiceId -> IO (Either ErrorType Int64) data EntityCounts = EntityCounts { queueCount :: Int, diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 9069cfc89..d013c0db4 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -47,6 +47,7 @@ batchingTests = do it "should batch with 135 subscriptions per batch" testClientBatchSubscriptions it "should batch with 255 ENDs per batch" testClientBatchENDs it "should batch with 80 NMSGs per batch" testClientBatchNMSGs + it "should batch subscription responses with message" testBatchSubResponses it "should break on message that does not fit" testClientBatchWithMessage it "should break on large message" testClientBatchWithLargeMessage @@ -207,6 +208,20 @@ testClientBatchNMSGs = do (length rs1, length rs2, length rs3) `shouldBe` (40, 80, 80) all lenOk [s1, s2, s3] `shouldBe` True +-- 4 responses are used in Simplex.Messaging.Server / `send` +testBatchSubResponses :: IO () +testBatchSubResponses = do + client <- testClientStub + soks <- replicateM 4 $ randomSOK + msg <- randomMSG + let msgs = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) (soks <> [msg]) + batches = batchTransmissions (thParams client) $ L.fromList msgs + length batches `shouldBe` 1 + soks' <- replicateM 5 $ randomSOK + let msgs' = map (\t -> Right (Nothing, encodeTransmission (thParams client) t)) (soks' <> [msg]) + batches' = batchTransmissions (thParams client) $ L.fromList msgs' + length batches' `shouldBe` 2 + testClientBatchWithMessageV6 :: IO () testClientBatchWithMessageV6 = do client <- testClientStubV6 @@ -361,6 +376,22 @@ randomNMSGCmd ts = do Right encNMsgMeta <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode msgMeta) 128 pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta) +randomSOK :: IO (Transmission BrokerMsg) +randomSOK = do + g <- C.newRandom + corrId <- atomically $ C.randomBytes 24 g + rId <- atomically $ C.randomBytes 24 g + pure (CorrId corrId, EntityId rId, SOK Nothing) + +randomMSG :: IO (Transmission BrokerMsg) +randomMSG = do + g <- C.newRandom + corrId <- atomically $ C.randomBytes 24 g + rId <- atomically $ C.randomBytes 24 g + msgId <- atomically $ C.randomBytes 24 g + msg <- atomically $ C.randomBytes (maxMessageLength currentClientSMPRelayVersion) g + pure (CorrId corrId, EntityId rId, MSG RcvMessage {msgId, msgBody = EncRcvMsgBody msg}) + randomSENDv6 :: ByteString -> Int -> IO (Either TransportError (Maybe TAuthorizations, ByteString)) randomSENDv6 = randomSEND_ C.SEd25519 minServerSMPRelayVersion diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 354573852..70fdf5983 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -18,6 +18,7 @@ module ServerTests where import Control.Concurrent (ThreadId, killThread, threadDelay) +import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM import Control.Exception (SomeException, throwIO, try) import Control.Monad @@ -29,6 +30,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Hashable (hash) import qualified Data.IntSet as IS +import Data.List.NonEmpty (NonEmpty) import Data.String (IsString (..)) import Data.Type.Equality import qualified Data.X509.Validation as XV @@ -75,6 +77,7 @@ serverTests = do describe "GET command" testGetCommand describe "GET & SUB commands" testGetSubCommands describe "Exceeding queue quota" testExceedQueueQuota + describe "Concurrent sending and delivery" testConcurrentSendDelivery describe "Store log" testWithStoreLog describe "Restore messages" testRestoreMessages describe "Restore messages (old / v2)" testRestoreExpireMessages @@ -111,16 +114,25 @@ sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do tGet1 h signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg)) -signSendRecv h pk = signSendRecv_ h pk Nothing +signSendRecv h pk t = do + [r] <- signSendRecv_ h pk Nothing t + pure r + +signSendRecv2 :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg), Transmission (Either ErrorType BrokerMsg)) +signSendRecv2 h pk t = do + [r1, r2] <- signSendRecv_ h pk Nothing t + pure (r1, r2) serviceSignSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg)) -serviceSignSendRecv h pk = signSendRecv_ h pk . Just +serviceSignSendRecv h pk serviceKey t = do + [r] <- signSendRecv_ h pk (Just serviceKey) t + pure r -signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg)) +signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg))) signSendRecv_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) Right () <- tPut1 h (authorize tForAuth, tToSend) - tGet1 h + liftIO $ tGetClient h where authorize t = (,(`C.sign'` t) <$> serviceKey_) <$> case a of C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t' @@ -365,7 +377,7 @@ testCreateDelete = Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF) (ok4, OK) #== "accepts OFF when suspended" - Resp "cdab" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("cdab", rId, SUB) + (Resp "cdab" _ (SOK Nothing), Resp "" _ (Msg mId2 msg2)) <- signSendRecv2 rh rKey ("cdab", rId, SUB) (dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)" Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL) @@ -404,7 +416,7 @@ stressTest = Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, New rPub dhPub) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do - Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) + Resp "" rId' (SOK Nothing) <- signSendRecv h rKey ("", rId, SUB) rId' `shouldBe` rId closeConnection $ connection h1 subscribeQueues h2 @@ -497,7 +509,7 @@ testSwitchSub = Resp "abcd" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1) (dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK" - Resp "bcda" _ (Msg mId2' msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB) + (Resp "bcda" _ (SOK Nothing), Resp "" _ (Msg mId2' msg2')) <- signSendRecv2 rh2 rKey ("bcda", rId, SUB) (dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)" Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2') @@ -620,6 +632,27 @@ testExceedQueueQuota = Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4) pure () +testConcurrentSendDelivery :: SpecWith (ASrvTransport, AStoreType) +testConcurrentSendDelivery = + it "should continue delivering messages if message is sent before it is acknowledged" $ \(ATransport t, msType) -> do + g <- C.newRandom + smpTest3 t msType $ \rh sh1 sh2 -> do + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub + let dec = decryptMsgV3 dhShared + sndMsg sh n = do + Resp (CorrId n') _ OK <- signSendRecv sh sKey (n, sId, _SEND ("msg " <> n)) + n' `shouldBe` n + isMsg1or2 mId msg = dec mId msg == Right "msg 1" || dec mId msg == Right "msg 2" `shouldBe` True + replicateM_ 50 $ do + concurrently_ (sndMsg sh1 "1") (sndMsg sh2 "2") + Resp "" _ (Msg mId1 msg1) <- tGet1 rh + isMsg1or2 mId1 msg1 + Resp "3" _ (Msg mId2 msg2) <- signSendRecv rh rKey ("3", rId, ACK mId1) + isMsg1or2 mId2 msg2 + Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, ACK mId2) + pure () + testWithStoreLog :: SpecWith (ASrvTransport, AStoreType) testWithStoreLog = it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do @@ -684,7 +717,7 @@ testWithStoreLog = nId <- readTVarIO notifierId Resp "dabc" _ (SOK Nothing) <- signSendRecv h1 nKey ("dabc", nId, NSUB) Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello") - Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB) + (Resp "cdab" _ (SOK Nothing), Resp "" _ (Msg mId3 msg3)) <- signSendRecv2 h rKey1 ("cdab", rId1, SUB) (decryptMsgV3 dh1 mId3 msg3, Right "hello") #== "delivered from restored queue" Resp "" _ (NMSG _ _) <- tGet1 h1 -- this queue is removed - not restored @@ -769,7 +802,7 @@ testRestoreMessages = Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh - Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB) + (Resp "2" _ (SOK Nothing), Resp "" _ (Msg mId2 msg2)) <- signSendRecv2 h rKey ("2", rId, SUB) (dec mId2 msg2, Right "hello 2") #== "restored message delivered" Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2) (dec mId3 msg3, Right "hello 3") #== "restored message delivered" @@ -786,7 +819,7 @@ testRestoreMessages = Just rKey <- readTVarIO recipientKey Just dh <- readTVarIO dhShared let dec = decryptMsgV3 dh - Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB) + (Resp "4" _ (SOK Nothing), Resp "" _ (Msg mId4 msg4)) <- signSendRecv2 h rKey ("4", rId, SUB) (dec mId4 msg4, Right "hello 4") #== "restored message delivered" Resp "5" _ (Msg mId5 msg5) <- signSendRecv h rKey ("5", rId, ACK mId4) (dec mId5 msg5, Right "hello 5") #== "restored message delivered" @@ -1131,7 +1164,7 @@ testMsgExpireOnSend = threadDelay 2500000 Resp "2" _ OK <- signSendRecv sh sKey ("2", sId, _SEND "hello (should NOT expire)") testSMPClient @c $ \rh -> do - Resp "3" _ (Msg mId msg) <- signSendRecv rh rKey ("3", rId, SUB) + (Resp "3" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("3", rId, SUB) (dec mId msg, Right "hello (should NOT expire)") #== "delivered" 1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case Nothing -> return () @@ -1139,8 +1172,7 @@ testMsgExpireOnSend = testMsgExpireOnInterval :: SpecWith (ASrvTransport, AStoreType) testMsgExpireOnInterval = - -- fails on ubuntu - xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do + it "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do g <- C.newRandom (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1} @@ -1151,7 +1183,7 @@ testMsgExpireOnInterval = threadDelay 3000000 testSMPClient @c $ \rh -> do signSendRecv rh rKey ("2", rId, SUB) >>= \case - Resp "2" _ OK -> pure () + Resp "2" _ (SOK Nothing) -> pure () r -> unexpected r 1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case Nothing -> return () @@ -1170,7 +1202,7 @@ testMsgNOTExpireOnInterval = Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello (should NOT expire)") threadDelay 2500000 testSMPClient @c $ \rh -> do - Resp "2" _ (Msg mId msg) <- signSendRecv rh rKey ("2", rId, SUB) + (Resp "2" _ (SOK Nothing), Resp "" _ (Msg mId msg)) <- signSendRecv2 rh rKey ("2", rId, SUB) (dec mId msg, Right "hello (should NOT expire)") #== "delivered" 1000 `timeout` tGetClient @SMPVersion @ErrorType @BrokerMsg rh >>= \case Nothing -> return () From 85a7fbf5381e71e605757e399791db9d58b71a1d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 12 Jul 2025 14:19:32 +0100 Subject: [PATCH 21/22] 6.4.0.12 --- simplexmq.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index cc2b382fc..bfe546485 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: simplexmq -version: 6.4.0.11.3 +version: 6.4.0.12 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and From d3e2d9ac5b37272d3b822f2536e85cc9347c1e5e Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 13 Jul 2025 15:20:26 +0100 Subject: [PATCH 22/22] docs: changelog v6.4 --- CHANGELOG.md | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4c1d6426d..1a8b1f210 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +# 6.4.0 + +SMP protocol (server/client): +- support associated queue data and short connection links (see [RFC](./rfcs/2025-03-16-smp-queues.md)). +- service certificates to optimize subscriptions. + +SMP agent: +- support retries for interactive connection handshakes. +- use web port 443 by default for preset servers. +- use static RNG function to avoid creating dynamic C stubs when generating sntrup keys (it was detected as Dynamic Code Loading in GrapheneOS). +- different timeouts for interactive and background operations. + +Ntf server: +- PostgreSQL storage. +- Prometheus metrics. +- use service certificates. +- fix repeat token registration. + # 6.3.2 Servers: @@ -18,7 +36,7 @@ Servers: - update script (simplex-servers-update) downloads scripts from the specified or the latest stable tag. SMP server: -- support for PostrgreSQL database for queue records for higher traffic servers. +- support for PostgreSQL database for queue records for higher traffic servers. - fix old clients sending messages to new servers (#1443) - remove empty journals when opening message queues and expiring idle queues (#1456, #1458). - additional start options (#1465): @@ -74,7 +92,7 @@ Servers: more reliable restoring of state. SMP server: reduced memory usage and faster start. -Notifications: compensate for iOS notifications being droppted by Apple while device is offline (#1378): +Notifications: compensate for iOS notifications being dropped by Apple while device is offline (#1378): - Ntf server: send multiple SMP notifications in one iOS notification. - Agent: get multiple messages for one iOS notification.