diff --git a/CHANGELOG.md b/CHANGELOG.md index e06ac1caa..ad8862b0f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,23 @@ +# 5.7.0 + +Version 5.7.0.4 + +_Please note_: the earliest SimpleX Chat clients supported by this version of the servers is 5.5.3 (released on February 11, 2024). + +SMP server: +- increase max SMP protocol version to 7 (support for deniable authenticators). + +NTF server: +- increase max NTF protocol version to 2 (support for deniable authenticators). + +XFTP server: +- version handshake using ALPN. + +SMP agent: +- increase timeouts for XFTP files. +- don't send commands after timeout. +- PQ encryption support. + # 5.6.2 Version 5.6.2.2. diff --git a/package.yaml b/package.yaml index c68416384..084fe3a8f 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 5.6.2.2 +version: 5.7.0.4 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, diff --git a/simplexmq.cabal b/simplexmq.cabal index a90997528..4a8baed9b 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 5.6.2.2 +version: 5.7.0.4 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 91ba17ff3..d53b3f4fa 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -19,7 +19,7 @@ import Options.Applicative import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) -import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) @@ -180,7 +180,8 @@ xftpServerCLI cfgPath logPath = do serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log", transportConfig = defaultTransportServerConfig - { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini + { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini, + alpn = Just supportedXFTPhandshakes } } diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 600396700..e3b48ba78 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -618,14 +618,14 @@ newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do newConnNoQueues :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId newConnNoQueues c userId connId enableNtfs cMode pqSupport = do g <- asks random - connAgentVersion <- asks $ maxVersion . ($ pqSupport) . smpAgentVRange . config + connAgentVersion <- asks $ maxVersion . smpAgentVRange . config let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} withStore c $ \db -> createNewConn db g cData cMode joinConnAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do withInvLock c (strEncode cReqUri) "joinConnAsync" $ do - lift (compatibleInvitationUri cReqUri pqSup) >>= \case + lift (compatibleInvitationUri cReqUri) >>= \case Just (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) @@ -729,16 +729,14 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv when enableNtfs $ do ns <- asks ntfSupervisor atomically $ sendNtfSubCommand ns (connId, NSCCreate) - let pqEnc = CR.connPQEncryption pqInitKeys - crData = ConnReqUriData SSSimplex (smpAgentVRange pqEnc) [qUri] clientData - e2eVRange = e2eEncryptVRange pqEnc + let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData case cMode of SCMContact -> pure (connId, CRContactUri crData) SCMInvitation -> do g <- asks random - (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eVRange) (CR.initialPQEncryption pqInitKeys) + (pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys) withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem - pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eVRange) + pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange) joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do @@ -750,14 +748,14 @@ joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do startJoinInvitation :: UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (Compatible VersionSMPA, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) startJoinInvitation userId connId enableNtfs cReqUri pqSup = - lift (compatibleInvitationUri cReqUri pqSup) >>= \case + lift (compatibleInvitationUri cReqUri) >>= \case Just (qInfo, (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), aVersion@(Compatible connAgentVersion)) -> do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) (_, rcDHRs) <- atomically $ C.generateKeyPair g rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams - maxSupported <- asks $ maxVersion . ($ pqSup) . e2eEncryptVRange . config + maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let rcVs = CR.RatchetVersions {current = v, maxSupported} rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams q <- lift $ newSndQueue userId "" qInfo @@ -767,29 +765,29 @@ startJoinInvitation userId connId enableNtfs cReqUri pqSup = connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport)) connRequestPQSupport c pqSup cReq = withAgentEnv' c $ case cReq of - CRInvitationUri {} -> invPQSupported <$$> compatibleInvitationUri cReq pqSup + CRInvitationUri {} -> invPQSupported <$$> compatibleInvitationUri cReq where invPQSupported (_, Compatible (CR.E2ERatchetParams e2eV _ _ _), Compatible agentV) = (agentV, pqSup `CR.pqSupportAnd` versionPQSupport_ agentV (Just e2eV)) - CRContactUri {} -> ctPQSupported <$$> compatibleContactUri cReq pqSup + CRContactUri {} -> ctPQSupported <$$> compatibleContactUri cReq where ctPQSupported (_, Compatible agentV) = (agentV, pqSup `CR.pqSupportAnd` versionPQSupport_ agentV Nothing) -compatibleInvitationUri :: ConnectionRequestUri 'CMInvitation -> PQSupport -> AM' (Maybe (Compatible SMPQueueInfo, Compatible (CR.RcvE2ERatchetParams 'C.X448), Compatible VersionSMPA)) -compatibleInvitationUri (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) pqSup = do +compatibleInvitationUri :: ConnectionRequestUri 'CMInvitation -> AM' (Maybe (Compatible SMPQueueInfo, Compatible (CR.RcvE2ERatchetParams 'C.X448), Compatible VersionSMPA)) +compatibleInvitationUri (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) = do AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config pure $ (,,) <$> (qUri `compatibleVersion` smpClientVRange) - <*> (e2eRcvParamsUri `compatibleVersion` e2eEncryptVRange pqSup) - <*> (crAgentVRange `compatibleVersion` smpAgentVRange pqSup) + <*> (e2eRcvParamsUri `compatibleVersion` e2eEncryptVRange) + <*> (crAgentVRange `compatibleVersion` smpAgentVRange) -compatibleContactUri :: ConnectionRequestUri 'CMContact -> PQSupport -> AM' (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)) -compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) pqSup = do +compatibleContactUri :: ConnectionRequestUri 'CMContact -> AM' (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA)) +compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) = do AgentConfig {smpClientVRange, smpAgentVRange} <- asks config pure $ (,) - <$> (qUri `compatibleVersion` smpClientVRange) - <*> (crAgentVRange `compatibleVersion` smpAgentVRange pqSup) + <$> (qUri `compatibleVersion` smpClientVRange) + <*> (crAgentVRange `compatibleVersion` smpAgentVRange) versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_ @@ -812,7 +810,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod void $ withStore' c $ \db -> deleteConn db Nothing connId' throwError e joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = - lift (compatibleContactUri cReqUri pqSup) >>= \case + lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn) -> do (connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv void $ sendInvitation c userId qInfo vrsn cReq cInfo @@ -1219,7 +1217,7 @@ enqueueMessageB c reqs = do pure $ Right ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId)) where storeSentMsg :: DB.Connection -> AgentConfig -> (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage), InternalId, PQEncryption)) - storeSentMsg db cfg req@(cData@ConnData {connId, pqSupport}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do + storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg internalTs <- liftIO getCurrentTime (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId @@ -1227,10 +1225,9 @@ enqueueMessageB c reqs = do agentMsg = AgentMessage privHeader aMessage agentMsgStr = smpEncode agentMsg internalHash = C.sha256Hash agentMsgStr - currentE2EVersion = maxVersion $ e2eEncryptVRange PQSupportOff - (encAgentMessage, pqEnc) <- agentRatchetEncrypt db cData agentMsgStr e2eEncUserMsgLength pqEnc_ currentE2EVersion - -- agent version range is determined by the connection suppport of PQ encryption, that is may be enabled when message is sent - let agentVersion = maxVersion $ smpAgentVRange pqSupport + currentE2EVersion = maxVersion e2eEncryptVRange + (encAgentMessage, pqEnc) <- agentRatchetEncrypt db cData agentMsgStr e2eEncAgentMsgLength pqEnc_ currentE2EVersion + let agentVersion = maxVersion smpAgentVRange msgBody = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage} msgType = agentMessageType agentMsg msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, pqEncryption = pqEnc, internalHash, prevMsgHash} @@ -1520,7 +1517,7 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni let cData' = cData {pqSupport = pqSupport'} :: ConnData AgentConfig {e2eEncryptVRange} <- asks config g <- asks random - (pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion $ e2eEncryptVRange pqSupport') pqSupport' + (pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqSupport' enqueueRatchetKeyMsgs c cData' sqs e2eParams withStore' c $ \db -> do setConnRatchetSync db connId RSStarted @@ -2046,7 +2043,7 @@ data ACKd = ACKd | ACKPending -- | make sure to ACK or throw in each message processing branch -- it cannot be finally, unfortunately, as sometimes it needs to be ACK+DEL processSMPTransmission :: AgentClient -> ServerTransmission SMPVersion BrokerMsg -> AM () -processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, sessId, rId, cmd) = do +processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, sessId, isResponse, rId, cmd) = do (rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId) processSMP rq conn $ toConnData conn where @@ -2189,8 +2186,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, _ -> prohibited >> ack _ -> prohibited >> ack updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c) - updateConnVersion conn' cData'@ConnData {pqSupport} msgAgentVersion = do - aVRange <- asks $ ($ pqSupport) . smpAgentVRange . config + updateConnVersion conn' cData' msgAgentVersion = do + aVRange <- asks $ smpAgentVRange . config let msgAVRange = fromMaybe (versionToRange msgAgentVersion) $ safeVersionRange (minVersion aVRange) msgAgentVersion case msgAVRange `compatibleVersion` aVRange of Just (Compatible av) @@ -2221,7 +2218,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, ignored = pure "END from disconnected client - ignored" _ -> do logServer "<--" c srv rId $ "unexpected: " <> bshow cmd - notify . ERR $ BROKER (B.unpack $ strEncode srv) UNEXPECTED + notify . ERR $ BROKER (B.unpack $ strEncode srv) $ if isResponse then TIMEOUT else UNEXPECTED where notify :: forall e m. MonadIO m => AEntityI e => ACommand 'Agent e -> m () notify = atomically . notify' @@ -2256,19 +2253,17 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config let ConnData {pqSupport} = toConnData conn' - aVRange = smpAgentVRange pqSupport - e2eVRange = e2eEncryptVRange pqSupport unless - (agentVersion `isCompatible` aVRange && smpClientVersion `isCompatible` smpClientVRange) + (agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange) (throwError $ AGENT A_VERSION) case status of New -> case (conn', e2eEncryption) of -- party initiating connection (RcvConnection _ _, Just (CR.AE2ERatchetParams _ e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _ _))) -> do - unless (e2eVersion `isCompatible` e2eVRange) (throwError $ AGENT A_VERSION) + unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION) (pk1, rcDHRs, pKem) <- withStore c (`getRatchetX3dhKeys` connId) rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 rcDHRs pKem e2eSndParams - let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eVRange} + let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange} pqSupport' = pqSupport `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just e2eVersion) rc = CR.initRcvRatchet rcVs rcDHRs rcParams pqSupport' g <- asks random @@ -2450,7 +2445,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, ContactConnection {} -> do -- show connection request even if invitaion via contact address is not compatible. -- in case invitation not compatible, assume there is no PQ encryption support. - pqSupport <- lift $ maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq PQSupportOn + pqSupport <- lift $ maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq g <- asks random let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo} invId <- withStore c $ \db -> createInvitation db g newInv @@ -2470,10 +2465,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv _) conn'@(DuplexConnection cData'@ConnData {lastExternalSndId, pqSupport} _ sqs) = unlessM ratchetExists $ do AgentConfig {e2eEncryptVRange} <- asks config - let connE2EVRange = e2eEncryptVRange pqSupport - unless (e2eVersion `isCompatible` connE2EVRange) (throwError $ AGENT A_VERSION) + unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION) keys <- getSendRatchetKeys - let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion connE2EVRange} + let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange} initRatchet rcVs keys notifyAgreed where @@ -2579,8 +2573,7 @@ confirmQueue (Compatible agentVersion) c cData@ConnData {connId, pqSupport} sq s where mkConfirmation :: AgentMessage -> AM MsgBody mkConfirmation aMessage = do - -- the version to be used when PQSupport is disabled - currentE2EVersion <- asks $ maxVersion . ($ PQSupportOff) . e2eEncryptVRange . config + currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config withStore c $ \db -> runExceptT $ do void . liftIO $ updateSndIds db connId let pqEnc = CR.pqSupportToEnc pqSupport @@ -2599,8 +2592,7 @@ enqueueConfirmation c cData sq connInfo e2eEncryption_ = do storeConfirmation :: AgentClient -> ConnData -> SndQueue -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> AgentMessage -> AM () storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq e2eEncryption_ agentMsg = do - -- the version to be used when PQSupport is disabled - currentE2EVersion <- asks $ maxVersion . ($ PQSupportOff) . e2eEncryptVRange . config + currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config withStore c $ \db -> runExceptT $ do internalTs <- liftIO getCurrentTime (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId @@ -2620,8 +2612,8 @@ enqueueRatchetKeyMsgs c cData (sq :| sqs) e2eEncryption = do mapM_ (lift . enqueueSavedMessage c cData msgId) $ filter isActiveSndQ sqs enqueueRatchetKey :: AgentClient -> ConnData -> SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> AM AgentMsgId -enqueueRatchetKey c cData@ConnData {connId, pqSupport} sq e2eEncryption = do - aVRange <- asks $ ($ pqSupport) . smpAgentVRange . config +enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do + aVRange <- asks $ smpAgentVRange . config msgId <- storeRatchetKey $ maxVersion aVRange lift $ submitPendingMsg c cData sq pure $ unId msgId diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 02a28ba95..f91144fdc 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -56,7 +56,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (PQSupport, VersionRangeE2E, supportedE2EEncryptVRange) +import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Notifications.Transport (NTFVersion) import Simplex.Messaging.Notifications.Types @@ -117,8 +117,8 @@ data AgentConfig = AgentConfig caCertificateFile :: FilePath, privateKeyFile :: FilePath, certificateFile :: FilePath, - e2eEncryptVRange :: PQSupport -> VersionRangeE2E, - smpAgentVRange :: PQSupport -> VersionRangeSMPA, + e2eEncryptVRange :: VersionRangeE2E, + smpAgentVRange :: VersionRangeSMPA, smpClientVRange :: VersionRangeSMPC } diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 602ffafe4..895a8ddc1 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -44,7 +44,7 @@ module Simplex.Messaging.Agent.Protocol currentSMPAgentVersion, supportedSMPAgentVRange, e2eEncConnInfoLength, - e2eEncUserMsgLength, + e2eEncAgentMsgLength, -- * SMP agent protocol types ConnInfo, @@ -272,16 +272,11 @@ deliveryRcptsSMPAgentVersion = VersionSMPA 4 pqdrSMPAgentVersion :: VersionSMPA pqdrSMPAgentVersion = VersionSMPA 5 --- TODO v5.7 increase to 5 currentSMPAgentVersion :: VersionSMPA -currentSMPAgentVersion = VersionSMPA 4 +currentSMPAgentVersion = VersionSMPA 5 --- TODO v5.7 remove dependency of version range on whether PQ support is needed -supportedSMPAgentVRange :: PQSupport -> VersionRangeSMPA -supportedSMPAgentVRange pq = - mkVersionRange duplexHandshakeSMPAgentVersion $ case pq of - PQSupportOn -> pqdrSMPAgentVersion - PQSupportOff -> currentSMPAgentVersion +supportedSMPAgentVRange :: VersionRangeSMPA +supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentSMPAgentVersion -- it is shorter to allow all handshake headers, -- including E2E (double-ratchet) parameters and @@ -292,8 +287,8 @@ e2eEncConnInfoLength v = \case PQSupportOn | v >= pqdrSMPAgentVersion -> 11122 _ -> 14848 -e2eEncUserMsgLength :: VersionSMPA -> PQSupport -> Int -e2eEncUserMsgLength v = \case +e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int +e2eEncAgentMsgLength v = \case -- reduced by 2222 (the increase of message ratchet header size) PQSupportOn | v >= pqdrSMPAgentVersion -> 13634 _ -> 15856 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index ebcfc79b2..a96de2e2a 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -105,7 +105,7 @@ import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe) -import Data.Time.Clock (UTCTime (..), getCurrentTime) +import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime) import qualified Data.X509 as X import qualified Data.X509.Validation as XV import Network.Socket (ServiceName) @@ -118,12 +118,13 @@ import Simplex.Messaging.Protocol import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport -import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient) +import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient) import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Transport.WebSockets (WS) -import Simplex.Messaging.Util (bshow, liftEitherWith, raceAny_, threadDelay') +import Simplex.Messaging.Util (bshow, diffToMicroseconds, liftEitherWith, raceAny_, threadDelay', whenM) import Simplex.Messaging.Version import System.Timeout (timeout) +import UnliftIO (pooledMapConcurrentlyN) -- | 'SMPClient' is a handle used to send commands to a specific SMP server. -- @@ -140,20 +141,26 @@ data PClient v err msg = PClient transportSession :: TransportSession msg, transportHost :: TransportHost, tcpTimeout :: Int, - pingErrorCount :: TVar Int, + rcvConcurrency :: Int, + sendPings :: TVar Bool, + lastReceived :: TVar UTCTime, + timeoutErrorCount :: TVar Int, clientCorrId :: TVar ChaChaDRG, sentCommands :: TMap CorrId (Request err msg), - sndQ :: TBQueue ByteString, + sndQ :: TBQueue (TVar Bool, ByteString), rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)), msgQ :: Maybe (TBQueue (ServerTransmission v msg)) } smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient smpClientStub g sessionId thVersion thAuth = do + let ts = UTCTime (read "2024-03-31") 0 connected <- newTVar False clientCorrId <- C.newRandomDRG g sentCommands <- TM.empty - pingErrorCount <- newTVar 0 + sendPings <- newTVar False + lastReceived <- newTVar ts + timeoutErrorCount <- newTVar 0 sndQ <- newTBQueue 100 rcvQ <- newTBQueue 100 return @@ -168,14 +175,17 @@ smpClientStub g sessionId thVersion thAuth = do implySessId = thVersion >= authCmdsSMPVersion, batch = True }, - sessionTs = UTCTime (read "2024-03-31") 0, + sessionTs = ts, client_ = PClient { connected, transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing), transportHost = "localhost", tcpTimeout = 15_000_000, - pingErrorCount, + rcvConcurrency = 8, + sendPings, + lastReceived, + timeoutErrorCount, clientCorrId, sentCommands, sndQ, @@ -190,7 +200,7 @@ type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg) -- | Type synonym for transmission from some SPM server queue. -type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, EntityId, msg) +type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, Bool, EntityId, msg) data HostMode = -- | prefer (or require) onion hosts when connecting via SOCKS proxy @@ -219,11 +229,13 @@ data NetworkConfig = NetworkConfig tcpTimeout :: Int, -- | additional timeout per kilobyte (1024 bytes) to be sent tcpTimeoutPerKb :: Int64, + -- | break response timeouts into groups, so later responses get later deadlines + rcvConcurrency :: Int, -- | TCP keep-alive options, Nothing to skip enabling keep-alive tcpKeepAlive :: Maybe KeepAliveOpts, -- | period for SMP ping commands (microseconds, 0 to disable) smpPingInterval :: Int64, - -- | the count of PING errors after which SMP client terminates (and will be reconnected), 0 to disable + -- | the count of timeout errors after which SMP client terminates (and will be reconnected), 0 to disable smpPingCount :: Int, logTLSErrors :: Bool } @@ -248,9 +260,10 @@ defaultNetworkConfig = requiredHostMode = False, sessionMode = TSMUser, smpProxyMode = SPMNever, - tcpConnectTimeout = 20_000_000, + tcpConnectTimeout = defaultTcpConnectTimeout, tcpTimeout = 15_000_000, tcpTimeoutPerKb = 5_000, + rcvConcurrency = 8, tcpKeepAlive = Just defaultKeepAliveOpts, smpPingInterval = 600_000_000, -- 10min smpPingCount = 3, @@ -258,8 +271,8 @@ defaultNetworkConfig = } transportClientConfig :: NetworkConfig -> TransportClientConfig -transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} = - TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing} +transportClientConfig NetworkConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} = + TransportClientConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing} {-# INLINE transportClientConfig #-} -- | protocol client configuration. @@ -293,7 +306,8 @@ defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange {-# INLINE defaultSMPClientConfig #-} data Request err msg = Request - { entityId :: EntityId, + { corrId :: CorrId, + entityId :: EntityId, responseVar :: TMVar (Either (ProtocolClientError err) msg) } @@ -348,15 +362,17 @@ getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> T getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, agreeSecret} msgQ disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> - (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost) + (getCurrentTime >>= atomically . mkProtocolClient useHost >>= runClient useTransport useHost) `catch` \(e :: IOException) -> pure . Left $ PCEIOError e Left e -> pure $ Left e where - NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig - mkProtocolClient :: TransportHost -> STM (PClient v err msg) - mkProtocolClient transportHost = do + NetworkConfig {tcpConnectTimeout, tcpTimeout, rcvConcurrency, smpPingInterval} = networkConfig + mkProtocolClient :: TransportHost -> UTCTime -> STM (PClient v err msg) + mkProtocolClient transportHost ts = do connected <- newTVar False - pingErrorCount <- newTVar 0 + sendPings <- newTVar False + lastReceived <- newTVar ts + timeoutErrorCount <- newTVar 0 clientCorrId <- C.newRandomDRG g sentCommands <- TM.empty sndQ <- newTBQueue qSize @@ -367,9 +383,12 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize transportSession, transportHost, tcpTimeout, - pingErrorCount, + sendPings, + lastReceived, + timeoutErrorCount, clientCorrId, sentCommands, + rcvConcurrency, sndQ, rcvQ, msgQ @@ -404,6 +423,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize Right th@THandle {params} -> do sessionTs <- getCurrentTime let c' = ProtocolClient {action = Nothing, client_ = c, thParams = params, sessionTs} + atomically $ writeTVar (lastReceived c) sessionTs atomically $ do writeTVar (connected c) True putTMVar cVar $ Right c' @@ -411,36 +431,48 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize `finally` disconnected c' send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () - send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPutLog h + send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= \(active, s) -> whenM (readTVarIO active) (void $ tPutLog h s) receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO () - receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ + receive ProtocolClient {client_ = PClient {rcvQ, lastReceived, timeoutErrorCount}} h = forever $ do + tGet h >>= atomically . writeTBQueue rcvQ + getCurrentTime >>= atomically . writeTVar lastReceived + atomically $ writeTVar timeoutErrorCount 0 ping :: ProtocolClient v err msg -> IO () - ping c@ProtocolClient {client_ = PClient {pingErrorCount}} = do - threadDelay' smpPingInterval - runExceptT (sendProtocolCommand c Nothing "" $ protocolPing @v @err @msg) >>= \case - Left PCEResponseTimeout -> do - cnt <- atomically $ stateTVar pingErrorCount $ \cnt -> (cnt + 1, cnt + 1) - when (maxCnt == 0 || cnt < maxCnt) $ ping c - _ -> ping c -- sendProtocolCommand resets pingErrorCount + ping c@ProtocolClient {client_ = PClient {sendPings, lastReceived, timeoutErrorCount}} = loop smpPingInterval where + loop :: Int64 -> IO () + loop delay = do + threadDelay' delay + diff <- diffUTCTime <$> getCurrentTime <*> readTVarIO lastReceived + let idle = diffToMicroseconds diff + remaining = smpPingInterval - idle + if remaining > 1_000_000 -- delay pings only for significant time + then loop remaining + else do + whenM (readTVarIO sendPings) $ void . runExceptT $ sendProtocolCommand c Nothing "" (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 + when (maxCnt == 0 || cnt < maxCnt || diff < recoverWindow) $ loop smpPingInterval + recoverWindow = 15 * 60 -- seconds maxCnt = smpPingCount networkConfig process :: ProtocolClient v err msg -> IO () process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c) processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO () - processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr)) = - if B.null $ bs corrId - then sendMsg respOrErr - else do + processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr)) + | isResponse = atomically (TM.lookup corrId sentCommands) >>= \case Nothing -> sendMsg respOrErr Just Request {entityId, responseVar} -> atomically $ do TM.delete corrId sentCommands putTMVar responseVar $ response entityId + | otherwise = sendMsg respOrErr where + isResponse = not $ B.null $ bs corrId response entityId | entityId == entId = case respOrErr of @@ -451,7 +483,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize | otherwise = Left . PCEUnexpectedResponse $ bshow respOrErr sendMsg :: Either err msg -> IO () sendMsg = \case - Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c entId msg) msgQ + Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c isResponse entId msg) msgQ Left e -> putStrLn $ "SMP client error: " <> show e proxyUsername :: TransportSession msg -> ByteString @@ -534,15 +566,18 @@ createSMPQueue c (rKey, rpKey) dhKey auth subMode = -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () -subscribeSMPQueue c rpKey rId = +subscribeSMPQueue c@ProtocolClient {client_ = PClient {sendPings}} rpKey rId = do + liftIO . atomically $ writeTVar sendPings True sendSMPCommand c (Just rpKey) rId SUB >>= \case - OK -> return () + OK -> pure () cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd r -> throwE . PCEUnexpectedResponse $ bshow r -- | Subscribe to multiple SMP queues batching commands if supported. subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) -subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM (processSUBResponse c) +subscribeSMPQueues c@ProtocolClient {client_ = PClient {sendPings}} qs = do + atomically $ writeTVar sendPings True + sendProtocolCommands c cs >>= mapM (processSUBResponse c) where cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs @@ -560,11 +595,11 @@ processSUBResponse c (Response rId r) = case r of Left e -> pure $ Left e writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO () -writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c) +writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c False rId msg) (msgQ $ client_ c) -serverTransmission :: ProtocolClient v err msg -> RecipientId -> msg -> ServerTransmission v msg -serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} entityId message = - (transportSession, thVersion, sessionId, entityId, message) +serverTransmission :: ProtocolClient v err msg -> Bool -> RecipientId -> msg -> ServerTransmission v msg +serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} isResponse entityId message = + (transportSession, thVersion, sessionId, isResponse, entityId, message) -- | 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 -- @@ -811,19 +846,21 @@ streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockS mapM_ (cb <=< sendBatch c) bs sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg] -sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do +sendBatch c@ProtocolClient {client_ = PClient {rcvConcurrency, sndQ}} b = do case b of TBError e Request {entityId} -> do putStrLn "send error: large message" pure [Response entityId $ Left $ PCETransportError e] TBTransmissions s n rs | n > 0 -> do - atomically $ writeTBQueue sndQ s - mapConcurrently (getResponse c) rs + active <- newTVarIO True + atomically $ writeTBQueue sndQ (active, s) + pooledMapConcurrentlyN rcvConcurrency (getResponse c active) rs | otherwise -> pure [] TBTransmission s r -> do - atomically $ writeTBQueue sndQ s - (: []) <$> getResponse c r + active <- newTVarIO True + atomically $ writeTBQueue sndQ (active, s) + (: []) <$> getResponse c active r -- | Send Protocol command sendProtocolCommand :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg @@ -839,20 +876,25 @@ sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THan Left e -> pure . Left $ PCETransportError e Right t | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg - | otherwise -> atomically (writeTBQueue sndQ s) >> response <$> getResponse c r + | otherwise -> do + active <- newTVarIO True + atomically (writeTBQueue sndQ (active, s)) + response <$> getResponse c active r where s | batch = tEncodeBatch1 t | otherwise = tEncode t -- TODO switch to timeout or TimeManager that supports Int64 -getResponse :: ProtocolClient v err msg -> Request err msg -> IO (Response err msg) -getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} Request {entityId, responseVar} = do +getResponse :: ProtocolClient v err msg -> TVar Bool -> Request err msg -> IO (Response err msg) +getResponse ProtocolClient {client_ = PClient {tcpTimeout, timeoutErrorCount, sentCommands}} active Request {corrId, entityId, responseVar} = do response <- timeout tcpTimeout (atomically (takeTMVar responseVar)) >>= \case - -- BTW: another registerDelay candidate. Also, crashes caller with BlockedIndef. - Just r -> atomically (writeTVar pingErrorCount 0) $> r - Nothing -> pure $ Left PCEResponseTimeout + Just r -> atomically (writeTVar timeoutErrorCount 0) $> r + Nothing -> do + atomically (writeTVar active False >> TM.delete corrId sentCommands) + atomically $ modifyTVar' timeoutErrorCount (+ 1) + pure $ Left PCEResponseTimeout pure Response {entityId, response} mkTransmission :: ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg) @@ -868,7 +910,7 @@ mkTransmission_ ProtocolClient {thParams, client_ = PClient {clientCorrId, sentC where mkRequest :: CorrId -> STM (Request err msg) mkRequest corrId = do - r <- Request entId <$> newEmptyTMVar + r <- Request corrId entId <$> newEmptyTMVar TM.insert corrId r sentCommands pure r diff --git a/src/Simplex/Messaging/Compression.hs b/src/Simplex/Messaging/Compression.hs index 339107bea..19d91a300 100644 --- a/src/Simplex/Messaging/Compression.hs +++ b/src/Simplex/Messaging/Compression.hs @@ -4,20 +4,9 @@ module Simplex.Messaging.Compression where import qualified Codec.Compression.Zstd as Z1 -import qualified Codec.Compression.Zstd.FFI as Z -import Control.Monad (forM) -import Control.Monad.Except -import Control.Monad.IO.Class import Data.ByteString (ByteString) import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B -import Data.Either (fromRight) -import Data.List.NonEmpty (NonEmpty) -import Foreign -import Foreign.C.Types -import GHC.IO (unsafePerformIO) import Simplex.Messaging.Encoding -import UnliftIO.Exception (bracket) data Compressed = -- | Short messages are left intact to skip copying and FFI festivities. @@ -42,49 +31,15 @@ instance Encoding Compressed where '1' -> Compressed <$> smpP x -> fail $ "unknown Compressed tag: " <> show x --- | Compress as single chunk using stack-allocated context. compress1 :: ByteString -> Compressed compress1 bs | B.length bs <= maxLengthPassthrough = Passthrough bs | otherwise = Compressed . Large $ Z1.compress compressionLevel bs -type CompressCtx = (Ptr Z.CCtx, Ptr CChar, CSize) - -withCompressCtx :: CSize -> (CompressCtx -> IO a) -> IO a -withCompressCtx scratchSize action = - bracket Z.createCCtx Z.freeCCtx $ \cctx -> - allocaBytes (fromIntegral scratchSize) $ \scratchPtr -> - action (cctx, scratchPtr, scratchSize) - --- | Compress bytes, falling back to Passthrough in case of some internal error. -compress :: CompressCtx -> ByteString -> IO Compressed -compress ctx bs = fromRight (Passthrough bs) <$> compress_ ctx bs - -compress_ :: CompressCtx -> ByteString -> IO (Either String Compressed) -compress_ (cctx, scratchPtr, scratchSize) bs - | B.length bs <= maxLengthPassthrough = pure . Right $ Passthrough bs - | otherwise = - B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> runExceptT $ do - -- should not fail, unless input buffer is too short - dstSize <- ExceptT $ Z.checkError $ Z.compressCCtx cctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize) compressionLevel - liftIO $ Compressed . Large <$> B.packCStringLen (scratchPtr, fromIntegral dstSize) - -type DecompressCtx = (Ptr Z.DCtx, Ptr CChar, CSize) - -withDecompressCtx :: Int -> (DecompressCtx -> IO a) -> IO a -withDecompressCtx maxUnpackedSize action = - bracket Z.createDCtx Z.freeDCtx $ \dctx -> - allocaBytes maxUnpackedSize $ \scratchPtr -> - action (dctx, scratchPtr, fromIntegral maxUnpackedSize) - -decompress :: DecompressCtx -> Compressed -> IO (Either String ByteString) -decompress (dctx, scratchPtr, scratchSize) = \case - Passthrough bs -> pure $ Right bs - Compressed (Large bs) -> - B.unsafeUseAsCStringLen bs $ \(sourcePtr, sourceSize) -> do - res <- Z.checkError $ Z.decompressDCtx dctx scratchPtr scratchSize sourcePtr (fromIntegral sourceSize) - forM res $ \dstSize -> B.packCStringLen (scratchPtr, fromIntegral dstSize) - -decompressBatch :: Int -> NonEmpty Compressed -> NonEmpty (Either String ByteString) -decompressBatch maxUnpackedSize items = unsafePerformIO $ withDecompressCtx maxUnpackedSize $ forM items . decompress -{-# NOINLINE decompressBatch #-} -- prevent double-evaluation under unsafePerformIO +decompress1 :: Compressed -> Either String ByteString +decompress1 = \case + Passthrough bs -> Right bs + Compressed (Large bs) -> case Z1.decompress bs of + Z1.Error e -> Left e + Z1.Skip -> Right mempty + Z1.Decompress bs' -> Right bs' diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 068f62776..6ab84aa30 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -143,16 +143,11 @@ kdfX3DHE2EEncryptVersion = VersionE2E 2 pqRatchetE2EEncryptVersion :: VersionE2E pqRatchetE2EEncryptVersion = VersionE2E 3 --- TODO v5.7 increase to 3 currentE2EEncryptVersion :: VersionE2E -currentE2EEncryptVersion = VersionE2E 2 +currentE2EEncryptVersion = VersionE2E 3 --- TODO v5.7 remove dependency of version range on whether PQ encryption is used -supportedE2EEncryptVRange :: PQSupport -> VersionRangeE2E -supportedE2EEncryptVRange pq = - mkVersionRange kdfX3DHE2EEncryptVersion $ case pq of - PQSupportOn -> pqRatchetE2EEncryptVersion - PQSupportOff -> currentE2EEncryptVersion +supportedE2EEncryptVRange :: VersionRangeE2E +supportedE2EEncryptVRange = mkVersionRange kdfX3DHE2EEncryptVersion currentE2EEncryptVersion data RatchetKEMState = RKSProposed -- only KEM encapsulation key diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 55bdb07eb..b79665c87 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -218,7 +218,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge receiveSMP :: M () receiveSMP = forever $ do - ((_, srv, _), _, _, ntfId, msg) <- atomically $ readTBQueue msgQ + ((_, srv, _), _, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ let smpQueue = SMPQueueNtf srv ntfId case msg of SMP.NMSG nmsgNonce encNMsgMeta -> do diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 022403471..e2c287437 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -47,7 +47,7 @@ currentClientNTFVersion :: VersionNTF currentClientNTFVersion = VersionNTF 1 currentServerNTFVersion :: VersionNTF -currentServerNTFVersion = VersionNTF 1 +currentServerNTFVersion = VersionNTF 2 supportedClientNTFVRange :: VersionRangeNTF supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index a353849da..6f0f04ff7 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -157,7 +157,7 @@ currentClientSMPRelayVersion :: VersionSMP currentClientSMPRelayVersion = VersionSMP 6 currentServerSMPRelayVersion :: VersionSMP -currentServerSMPRelayVersion = VersionSMP 6 +currentServerSMPRelayVersion = VersionSMP 7 -- minimal supported protocol version is 4 -- TODO remove code that supports sending commands without batching diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index daea3982e..08cff1d0d 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,6 +11,7 @@ module Simplex.Messaging.Transport.Client runTLSTransportClient, smpClientHandshake, defaultSMPPort, + defaultTcpConnectTimeout, defaultTransportClientConfig, defaultSocksProxy, TransportClientConfig (..), @@ -52,6 +54,7 @@ import Simplex.Messaging.Transport import Simplex.Messaging.Transport.KeepAlive import Simplex.Messaging.Util (bshow, (<$?>), catchAll, tshow) import System.IO.Error +import System.Timeout (timeout) import Text.Read (readMaybe) import UnliftIO.Exception (IOException) import qualified UnliftIO.Exception as E @@ -112,6 +115,7 @@ instance IsString (NonEmpty TransportHost) where fromString = parseString strDec data TransportClientConfig = TransportClientConfig { socksProxy :: Maybe SocksProxy, + tcpConnectTimeout :: Int, tcpKeepAlive :: Maybe KeepAliveOpts, logTLSErrors :: Bool, clientCredentials :: Maybe (X.CertificateChain, T.PrivKey), @@ -119,8 +123,12 @@ data TransportClientConfig = TransportClientConfig } deriving (Eq, Show) +-- time to resolve host, connect socket, set up TLS +defaultTcpConnectTimeout :: Int +defaultTcpConnectTimeout = 25_000_000 + defaultTransportClientConfig :: TransportClientConfig -defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing Nothing +defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing clientTransportConfig :: TransportClientConfig -> TransportConfig clientTransportConfig TransportClientConfig {logTLSErrors} = @@ -131,7 +139,7 @@ runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString - runTransportClient = runTLSTransportClient supportedParameters Nothing runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a -runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do +runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do serverCert <- newEmptyTMVarIO let hostName = B.unpack $ strEncode host clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert @@ -142,13 +150,19 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, sock <- connectTCP port mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e) let tCfg = clientTransportConfig cfg - connectTLS (Just hostName) tCfg clientParams sock >>= \tls -> do - chain <- atomically (tryTakeTMVar serverCert) >>= \case - Nothing -> do - logError "onServerCertificate didn't fire or failed to get cert chain" - closeTLS tls >> error "onServerCertificate failed" - Just c -> pure c - getClientConnection tCfg chain tls + tcpConnectTimeout `timeout` connectTLS (Just hostName) tCfg clientParams sock >>= \case + Nothing -> do + close sock + logError "connection timed out" + fail "connection timed out" + Just tls -> do + chain <- + atomically (tryTakeTMVar serverCert) >>= \case + Nothing -> do + logError "onServerCertificate didn't fire or failed to get cert chain" + closeTLS tls >> error "onServerCertificate failed" + Just c -> pure c + getClientConnection tCfg chain tls client c `E.finally` closeConnection c where hostAddr = \case diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index b279c1805..d701d4114 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -24,7 +24,7 @@ import Numeric.Natural (Natural) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq) -import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient) +import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTLSTransportClient) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Util (eitherToMaybe) import UnliftIO.STM @@ -70,8 +70,16 @@ defaultHTTP2ClientConfig :: HTTP2ClientConfig defaultHTTP2ClientConfig = HTTP2ClientConfig { qSize = 64, - connTimeout = 10000000, - transportConfig = TransportClientConfig Nothing Nothing True Nothing Nothing, + connTimeout = defaultTcpConnectTimeout, + transportConfig = + TransportClientConfig + { socksProxy = Nothing, + tcpConnectTimeout = defaultTcpConnectTimeout, + tcpKeepAlive = Nothing, + logTLSErrors = True, + clientCredentials = Nothing, + alpn = Nothing + }, bufferSize = defaultHTTP2BufferSize, bodyHeadSize = 16384, suportedTLSParams = http2TLSParams diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index b14917c18..d42fffdd1 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -214,14 +214,13 @@ testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, P testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO () testDuplexConnection' (alice, aPQ) (bob, bPQ) = do let pq = pqConnectionMode aPQ bPQ - pqSup = CR.pqEncToSupport pq ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) ("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:) - pqSup' `shouldBe` pqSup + pqSup' `shouldBe` CR.connPQEncryption aPQ alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) - bob <# ("", "alice", A.INFO pqSup "alice's connInfo") + bob <# ("", "alice", A.INFO bPQ "alice's connInfo") bob <# ("", "alice", CON pq) alice <# ("", "bob", CON pq) -- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4 @@ -253,15 +252,14 @@ testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) ( testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO () testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do let pq = pqConnectionMode aPQ bPQ - pqSup = CR.pqEncToSupport pq ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") ("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:) - pqSup' `shouldBe` pqSup + pqSup' `shouldBe` CR.connPQEncryption aPQ bobConn' `shouldBe` bobConn alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False - bob <# ("", aliceConn, A.INFO pqSup "alice's connInfo") + bob <# ("", aliceConn, A.INFO bPQ "alice's connInfo") bob <# ("", aliceConn, CON pq) alice <# ("", bobConn, CON pq) alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq) @@ -291,17 +289,15 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq abPQ = pqConnectionMode aPQ bPQ - abPQSup = CR.pqEncToSupport abPQ aPQMode = CR.connPQEncryption aPQ bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) - ("", "alice_contact", Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:) - pqSup' `shouldBe` bPQ + ("", "alice_contact", Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:) alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK) ("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:) - pqSup'' `shouldBe` abPQSup + pqSup'' `shouldBe` bPQ bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK) - alice <# ("", "bob", A.INFO abPQSup "bob's connInfo 2") + alice <# ("", "bob", A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2") alice <# ("", "bob", CON abPQ) bob <# ("", "alice", CON abPQ) alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ) @@ -310,15 +306,13 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK) let atPQ = pqConnectionMode aPQ tPQ - atPQSup = CR.pqEncToSupport atPQ tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK) - ("", "alice_contact", Right (A.REQ aInvId' pqSup3 _ "tom's connInfo")) <- (alice <#:) - pqSup3 `shouldBe` tPQ + ("", "alice_contact", Right (A.REQ aInvId' PQSupportOn _ "tom's connInfo")) <- (alice <#:) alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK) ("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:) - pqSup4 `shouldBe` atPQSup + pqSup4 `shouldBe` tPQ tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK) - alice <# ("", "tom", A.INFO atPQSup "tom's connInfo 2") + alice <# ("", "tom", A.INFO (CR.connPQEncryption aPQ) "tom's connInfo 2") alice <# ("", "tom", CON atPQ) tom <# ("", "alice", CON atPQ) alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ) @@ -329,22 +323,20 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO () testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do let pq = pqConnectionMode aPQ bPQ - pqSup = CR.pqEncToSupport pq ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe") let cReq' = strEncode cReq ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") - ("", aliceContact', Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:) - pqSup' `shouldBe` bPQ + ("", aliceContact', Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:) aliceContact' `shouldBe` aliceContact ("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo") ("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:) - pqSup'' `shouldBe` pqSup + pqSup'' `shouldBe` bPQ aliceConn' `shouldBe` aliceConn bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK) - alice <# ("", bobConn, A.INFO pqSup "bob's connInfo 2") + alice <# ("", bobConn, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2") alice <# ("", bobConn, CON pq) bob <# ("", aliceConn, CON pq) @@ -358,7 +350,7 @@ testRejectContactRequest _ alice bob = do ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe") let cReq' = strEncode cReq bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK) - ("", "a_contact", Right (A.REQ aInvId PQSupportOff _ "bob's info")) <- (alice <#:) + ("", "a_contact", Right (A.REQ aInvId PQSupportOn _ "bob's info")) <- (alice <#:) -- RJCT must use correct contact connection alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND) alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK) @@ -571,12 +563,11 @@ connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe") let cReq' = strEncode cReq pq = pqConnectionMode pqMode1 pqMode2 - pqSup = CR.pqEncToSupport pq h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK) ("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:) - pqSup' `shouldBe` pqSup + pqSup' `shouldBe` CR.connPQEncryption pqMode1 h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK) - h2 <# ("", name1, A.INFO pqSup "info1") + h2 <# ("", name1, A.INFO pqMode2 "info1") h2 <# ("", name1, CON pq) h1 <# ("", name2, CON pq) diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 7ab234887..20480f84c 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -68,7 +68,7 @@ testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448 testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448 -testE2ERatchetParams12 = E2ERatchetParamsUri (supportedE2EEncryptVRange PQSupportOn) testDhPubKey testDhPubKey Nothing +testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing connectionRequest :: AConnectionRequestUri connectionRequest = @@ -82,7 +82,7 @@ connectionRequestCurrentRange :: AConnectionRequestUri connectionRequestCurrentRange = ACR SCMInvitation $ CRInvitationUri - connReqData {crAgentVRange = supportedSMPAgentVRange PQSupportOn, crSmpQueues = [queueV1, queueV1]} + connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]} testE2ERatchetParams12 connectionRequestClientDataEmpty :: AConnectionRequestUri diff --git a/tests/AgentTests/DoubleRatchetTests.hs b/tests/AgentTests/DoubleRatchetTests.hs index f95f07029..c3fbf01e8 100644 --- a/tests/AgentTests/DoubleRatchetTests.hs +++ b/tests/AgentTests/DoubleRatchetTests.hs @@ -93,9 +93,9 @@ fullMsgLen :: Ratchet a -> Int fullMsgLen Ratchet {rcSupportKEM, rcVersion} = headerLenLength + fullHeaderLen v rcSupportKEM + C.authTagSize + paddedMsgLen where v = current rcVersion - headerLenLength = case rcSupportKEM of - PQSupportOn | v >= pqRatchetE2EEncryptVersion -> 3 -- two bytes are added because of two Large used in new encoding - _ -> 1 + headerLenLength + | v >= pqRatchetE2EEncryptVersion = 3 -- two bytes are added because of two Large used in new encoding + | otherwise = 1 testMessageHeader :: forall a. AlgorithmI a => VersionE2E -> C.SAlgorithm a -> Expectation testMessageHeader v _ = do @@ -520,7 +520,7 @@ initRatchets = do Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob (_, pkBob3) <- atomically $ C.generateKeyPair g - let vs = testRatchetVersions PQSupportOff + let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOff pure (alice, bob, encrypt' noSndKEM, decrypt' noRcvKEM, (\#>)) @@ -537,7 +537,7 @@ initRatchetsKEMProposed = do Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob (_, pkBob3) <- atomically $ C.generateKeyPair g - let vs = testRatchetVersions PQSupportOn + let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>)) @@ -555,7 +555,7 @@ initRatchetsKEMAccepted = do Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob (_, pkBob3) <- atomically $ C.generateKeyPair g - let vs = testRatchetVersions PQSupportOn + let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>)) @@ -572,14 +572,14 @@ initRatchetsKEMProposedAgain = do Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob (_, pkBob3) <- atomically $ C.generateKeyPair g - let vs = testRatchetVersions PQSupportOn + let vs = testRatchetVersions bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>)) -testRatchetVersions :: PQSupport -> RatchetVersions -testRatchetVersions pq = - let v = maxVersion $ supportedE2EEncryptVRange pq +testRatchetVersions :: RatchetVersions +testRatchetVersions = + let v = maxVersion supportedE2EEncryptVRange in RatchetVersions v v encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff)) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 13822650f..ff6dfeacd 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -191,9 +191,9 @@ agentCfgVPrev :: AgentConfig agentCfgVPrev = agentCfg { sndAuthAlg = C.AuthAlg C.SEd25519, - smpAgentVRange = \_ -> prevRange $ smpAgentVRange agentCfg PQSupportOff, + smpAgentVRange = prevRange $ smpAgentVRange agentCfg, smpClientVRange = prevRange $ smpClientVRange agentCfg, - e2eEncryptVRange = \_ -> prevRange $ e2eEncryptVRange agentCfg PQSupportOff, + e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg, smpCfg = smpCfgVPrev } @@ -202,14 +202,14 @@ agentCfgV7 :: AgentConfig agentCfgV7 = agentCfg { sndAuthAlg = C.AuthAlg C.SX25519, - smpAgentVRange = \_ -> V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion, - e2eEncryptVRange = \_ -> V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion, + smpAgentVRange = V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion, + e2eEncryptVRange = V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion, smpCfg = smpCfgV7, ntfCfg = ntfCfgV2 } agentCfgRatchetVPrev :: AgentConfig -agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = \_ -> prevRange $ e2eEncryptVRange agentCfg PQSupportOff} +agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} prevRange :: VersionRange v -> VersionRange v prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)} @@ -557,28 +557,27 @@ testEnablePQEncryption = (a, 4, "msg 1") \#>\ b (b, 5, "msg 2") \#>\ a -- 45 bytes is used by agent message envelope inside double ratchet message envelope - let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncUserMsgLength pqdrSMPAgentVersion pqEnc - 45) g' + let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g' lrg <- largeMsg g PQSupportOff (a, 6, lrg) \#>\ b (b, 7, lrg) \#>\ a - -- enabling PQ encryption - (a, 8, lrg) \#>! b - (b, 9, lrg) \#>! a -- switched to smaller envelopes (before reporting PQ encryption enabled) sml <- largeMsg g PQSupportOn -- fail because of message size Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg - (11, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml - get ca =##> \case ("", connId, SENT 11) -> connId == bId; _ -> False - get cb =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False - ackMessage cb aId 10 Nothing + (9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml + get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False + get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False + ackMessage cb aId 8 Nothing -- -- fail in reply to sync IDss Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg - (12, PQEncOn) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml - get cb =##> \case ("", connId, SENT 12) -> connId == aId; _ -> False - get ca =##> \case ("", connId, MsgErr' 12 MsgSkipped {} PQEncOn msg') -> connId == bId && msg' == sml; _ -> False - ackMessage ca bId 12 Nothing + (10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml + get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False + get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False + ackMessage ca bId 10 Nothing + (a, 11, sml) \#>! b -- PQ encryption now enabled + (b, 12, sml) !#>! a (a, 13, sml) !#>! b (b, 14, sml) !#>! a -- disabling PQ encryption @@ -809,8 +808,8 @@ testAllowConnectionClientRestart t = do testIncreaseConnAgentVersion :: HasCallStack => ATransport -> IO () testIncreaseConnAgentVersion t = do - alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB2 + alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB + bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2 withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob @@ -822,7 +821,7 @@ testIncreaseConnAgentVersion t = do -- version doesn't increase if incompatible disposeAgentClient alice - alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB + alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB runRight_ $ do subscribeConnection alice2 bobId @@ -833,7 +832,7 @@ testIncreaseConnAgentVersion t = do -- version increases if compatible disposeAgentClient bob - bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2 + bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 runRight_ $ do subscribeConnection bob2 aliceId @@ -844,7 +843,7 @@ testIncreaseConnAgentVersion t = do -- version doesn't decrease, even if incompatible disposeAgentClient alice2 - alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = \_ -> mkVersionRange 2 2} initAgentServers testDB + alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB runRight_ $ do subscribeConnection alice3 bobId @@ -853,7 +852,7 @@ testIncreaseConnAgentVersion t = do checkVersion bob2 aliceId 3 disposeAgentClient bob2 - bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 1} initAgentServers testDB2 + bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2 runRight_ $ do subscribeConnection bob3 aliceId @@ -870,8 +869,8 @@ checkVersion c connId v = do testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => ATransport -> IO () testIncreaseConnAgentVersionMaxCompatible t = do - alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB2 + alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB + bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2 withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob @@ -883,7 +882,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do -- version increases to max compatible disposeAgentClient alice - alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB + alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB disposeAgentClient bob bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB2 @@ -898,8 +897,8 @@ testIncreaseConnAgentVersionMaxCompatible t = do testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => ATransport -> IO () testIncreaseConnAgentVersionStartDifferentVersion t = do - alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2 + alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB + bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aliceId, bobId) <- runRight $ do (aliceId, bobId) <- makeConnection_ PQSupportOff alice bob @@ -911,7 +910,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do -- version increases to max compatible disposeAgentClient alice - alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB + alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB runRight_ $ do subscribeConnection alice2 bobId @@ -2466,8 +2465,8 @@ testDeliveryReceipts = testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO () testDeliveryReceiptsVersion t = do - a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB - b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2 + a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB + b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2 withSmpServerStoreMsgLogOn t testPort $ \_ -> do (aId, bId) <- runRight $ do (aId, bId) <- makeConnection_ PQSupportOff a b @@ -2494,8 +2493,8 @@ testDeliveryReceiptsVersion t = do subscribeConnection a' bId subscribeConnection b' aId exchangeGreetingsMsgId_ PQEncOff 6 a' bId b' aId - checkVersion a' bId 4 - checkVersion b' aId 4 + checkVersion a' bId 5 + checkVersion b' aId 5 (8, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello" get a' ##> ("", bId, SENT 8) get b' =##> \case ("", c, Msg' 8 PQEncOff "hello") -> c == aId; _ -> False diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index d509042f0..b18b264e1 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -35,7 +35,7 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Server (runSMPAgentBlocking) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') -import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyMode, chooseTransportHost, defaultSMPClientConfig, defaultNetworkConfig) +import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyMode, chooseTransportHost, defaultNetworkConfig, defaultSMPClientConfig) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth) @@ -219,7 +219,7 @@ agentCfg = certificateFile = "tests/fixtures/server.crt" } where - networkConfig = defaultNetworkConfig {tcpConnectTimeout = 3_000_000, tcpTimeout = 2_000_000} + networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000} agentProxyCfg :: AgentConfig agentProxyCfg = agentCfg {smpCfg = (smpCfg agentCfg) {serverVRange = proxyVRange}} diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index ae2a05e4d..47251a2d4 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -115,7 +115,7 @@ deliverMessageViaProxy proxyServ relayServ alg msg msg' = do -- send via proxy to unsecured queue proxySMPMessage pc sess Nothing sndId noMsgFlags msg -- receive 1 - (_tSess, _v, _sid, _ety, SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody}) <- atomically $ readTBQueue msgQ + (_tSess, _v, _sid, _isResp, _entId, SMP.MSG RcvMessage {msgId, msgBody = EncRcvMsgBody encBody}) <- atomically $ readTBQueue msgQ liftIO $ dec msgId encBody `shouldBe` Right msg ackSMPMessage rc rPriv rcvId msgId -- secure queue @@ -124,7 +124,7 @@ deliverMessageViaProxy proxyServ relayServ alg msg msg' = do -- send via proxy to secured queue proxySMPMessage pc sess (Just sPriv) sndId noMsgFlags msg' -- receive 2 - (_tSess, _v, _sid, _ety, SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'}) <- atomically $ readTBQueue msgQ + (_tSess, _v, _sid, _isResp, _entId, SMP.MSG RcvMessage {msgId = msgId', msgBody = EncRcvMsgBody encBody'}) <- atomically $ readTBQueue msgQ liftIO $ dec msgId' encBody' `shouldBe` Right msg' ackSMPMessage rc rPriv rcvId msgId'