From b435a4dacbdbda7830fe4118e1e205a104801ed9 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 6 Mar 2024 16:38:30 +0000 Subject: [PATCH] envelope sizes dependent on PQ encryption (#1028) * envelope sizes dependent on PQ encryption (WIP) * add "supported" flag to ratchets, update this flag on ratchet resync * change connection PQ status on sendMessage * comment, fix * refactor --- src/Simplex/Messaging/Agent.hs | 168 +++++++++++--------- src/Simplex/Messaging/Agent/Protocol.hs | 16 +- src/Simplex/Messaging/Agent/Store/SQLite.hs | 9 +- src/Simplex/Messaging/Crypto/Ratchet.hs | 95 +++++++---- tests/AgentTests/DoubleRatchetTests.hs | 36 +++-- 5 files changed, 191 insertions(+), 133 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 6f3099ad6..d0a232131 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -140,6 +141,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock import Data.Time.Clock.System (systemToUTCTime) +import Data.Traversable (mapAccumL) import Data.Word (Word16) import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile') import Simplex.FileTransfer.Description (ValidFileDescription) @@ -158,6 +160,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) +import Simplex.Messaging.Crypto.Ratchet (PQEncryption, pattern PQEncOn, pattern PQEncOff) import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -222,7 +225,7 @@ createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => A createConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:. newConnAsync c userId aCorrId enableNtfs -- | Join SMP agent connection (JOIN command) asynchronously, synchronous response is new connection id -joinConnectionAsync :: AgentErrorMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +joinConnectionAsync :: AgentErrorMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId joinConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:: joinConnAsync c userId aCorrId enableNtfs -- | Allow connection to continue after CONF notification (LET command), no synchronous response @@ -230,7 +233,7 @@ allowConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> allowConnectionAsync c = withAgentEnv c .:: allowConnectionAsync' c -- | Accept contact after REQ notification (ACPT command) asynchronously, synchronous response is new connection id -acceptContactAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +acceptContactAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId acceptContactAsync c aCorrId enableNtfs = withAgentEnv c .:: acceptContactAsync' c aCorrId enableNtfs -- | Acknowledge message (ACK command) asynchronously, no synchronous response @@ -254,7 +257,7 @@ createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConne createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId "" enableNtfs -- | Join SMP agent connection (JOIN command) -joinConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +joinConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId joinConnection c userId enableNtfs = withAgentEnv c .:: joinConn c userId "" enableNtfs -- | Allow connection to continue after CONF notification (LET command) @@ -262,7 +265,7 @@ allowConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId allowConnection c = withAgentEnv c .:. allowConnection' c -- | Accept contact after REQ notification (ACPT command) -acceptContact :: AgentErrorMonad m => AgentClient -> Bool -> ConfirmationId -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +acceptContact :: AgentErrorMonad m => AgentClient -> Bool -> ConfirmationId -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId acceptContact c enableNtfs = withAgentEnv c .:: acceptContact' c "" enableNtfs -- | Reject contact (RJCT command) @@ -292,16 +295,16 @@ resubscribeConnections :: AgentErrorMonad m => AgentClient -> [ConnId] -> m (Map resubscribeConnections c = withAgentEnv c . resubscribeConnections' c -- | Send message to the connection (SEND command) -sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> CR.PQEncryption -> MsgFlags -> MsgBody -> m (AgentMsgId, CR.PQEncryption) +sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> m (AgentMsgId, PQEncryption) sendMessage c = withAgentEnv c .:: sendMessage' c -type MsgReq = (ConnId, CR.PQEncryption, MsgFlags, MsgBody) +type MsgReq = (ConnId, PQEncryption, MsgFlags, MsgBody) -- | Send multiple messages to different connections (SEND command) -sendMessages :: MonadUnliftIO m => AgentClient -> [MsgReq] -> m [Either AgentErrorType (AgentMsgId, CR.PQEncryption)] +sendMessages :: MonadUnliftIO m => AgentClient -> [MsgReq] -> m [Either AgentErrorType (AgentMsgId, PQEncryption)] sendMessages c = withAgentEnv c . sendMessages' c -sendMessagesB :: (MonadUnliftIO m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType (AgentMsgId, CR.PQEncryption))) +sendMessagesB :: (MonadUnliftIO m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType (AgentMsgId, PQEncryption))) sendMessagesB c = withAgentEnv c . sendMessagesB' c ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m () @@ -316,7 +319,7 @@ abortConnectionSwitch :: AgentErrorMonad m => AgentClient -> ConnId -> m Connect abortConnectionSwitch c = withAgentEnv c . abortConnectionSwitch' c -- | Re-synchronize connection ratchet keys -synchronizeRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> CR.PQEncryption -> Bool -> m ConnectionStats +synchronizeRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> PQEncryption -> Bool -> m ConnectionStats synchronizeRatchet c = withAgentEnv c .:. synchronizeRatchet' c -- | Suspend SMP agent connection (OFF command) @@ -555,14 +558,14 @@ newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode) pqInitKeys subMode pure connId -newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> CR.PQEncryption -> m ConnId +newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQEncryption -> m ConnId newConnNoQueues c userId connId enableNtfs cMode pqEncryption = do g <- asks random connAgentVersion <- asks $ maxVersion . ($ pqEncryption) . smpAgentVRange . config let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqEncryption} withStore c $ \db -> createNewConn db g cData cMode -joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo pqEncryption subMode = do withInvLock c (strEncode cReqUri) "joinConnAsync" $ do aVRange <- asks $ ($ pqEncryption) . smpAgentVRange . config @@ -584,7 +587,7 @@ allowConnectionAsync' c corrId connId confId ownConnInfo = enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo _ -> throwError $ CMD PROHIBITED -acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId acceptContactAsync' c corrId enableNtfs invId ownConnInfo pqEnc subMode = do Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId) withStore c (`getConn` contactConnId) >>= \case @@ -678,7 +681,7 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eVRange) -joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId joinConn c userId connId enableNtfs cReq cInfo pqEnc subMode = do srv <- case cReq of CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> @@ -686,7 +689,7 @@ joinConn c userId connId enableNtfs cReq cInfo pqEnc subMode = do _ -> getSMPServer c userId joinConnSrv c userId connId enableNtfs cReq cInfo pqEnc subMode srv -startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> CR.PQEncryption -> m (Compatible VersionSMPA, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) +startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> PQEncryption -> m (Compatible VersionSMPA, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448) startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) pqEncryption = do AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config let e2eVRange = e2eEncryptVRange pqEncryption @@ -706,7 +709,7 @@ startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {cr pure (aVersion, cData, q, rc, e2eSndParams) _ -> throwError $ AGENT A_VERSION -joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> SMPServerWithAuth -> m ConnId +joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQEncryption -> SubscriptionMode -> SMPServerWithAuth -> m ConnId joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqEnc subMode srv = withInvLock c (strEncode inv) "joinConnSrv" $ do (aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqEnc @@ -716,7 +719,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqEnc subMod liftIO $ createRatchet db connId' rc pure r let cData' = (cData :: ConnData) {connId = connId'} - tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) (Just pqEnc) subMode) >>= \case + tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) pqEnc subMode) >>= \case Right _ -> pure connId' Left e -> do -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md @@ -734,7 +737,7 @@ joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRan pure connId' _ -> throwError $ AGENT A_VERSION -joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> SMPServerWithAuth -> m () +joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQEncryption -> SubscriptionMode -> SMPServerWithAuth -> m () joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqEnc subMode srv = do (_aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqEnc q' <- withStore c $ \db -> runExceptT $ do @@ -772,7 +775,7 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne _ -> throwError $ CMD PROHIBITED -- | Accept contact (ACPT command) in Reader monad -acceptContact' :: AgentMonad m => AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId +acceptContact' :: AgentMonad m => AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQEncryption -> SubscriptionMode -> m ConnId acceptContact' c connId enableNtfs invId ownConnInfo pqEnc subMode = withConnLock c connId "acceptContact" $ do Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId) withStore c (`getConn` contactConnId) >>= \case @@ -913,29 +916,36 @@ getNotificationMessage' c nonce encNtfInfo = do Nothing -> SMP.notification msgFlags -- | Send message to the connection (SEND command) in Reader monad -sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> CR.PQEncryption -> MsgFlags -> MsgBody -> m (AgentMsgId, CR.PQEncryption) +sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> PQEncryption -> MsgFlags -> MsgBody -> m (AgentMsgId, PQEncryption) sendMessage' c connId pqEnc msgFlags msg = liftEither . runIdentity =<< sendMessagesB' c (Identity (Right (connId, pqEnc, msgFlags, msg))) -- | Send multiple messages to different connections (SEND command) in Reader monad -sendMessages' :: forall m. AgentMonad' m => AgentClient -> [MsgReq] -> m [Either AgentErrorType (AgentMsgId, CR.PQEncryption)] +sendMessages' :: forall m. AgentMonad' m => AgentClient -> [MsgReq] -> m [Either AgentErrorType (AgentMsgId, PQEncryption)] sendMessages' c = sendMessagesB' c . map Right -sendMessagesB' :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType (AgentMsgId, CR.PQEncryption))) +sendMessagesB' :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType (AgentMsgId, PQEncryption))) sendMessagesB' c reqs = withConnLocks c connIds "sendMessages" $ do reqs' <- withStoreBatch c (\db -> fmap (bindRight $ \req@(connId, _, _, _) -> bimap storeError (req,) <$> getConn db connId) reqs) - let reqs'' = fmap (>>= prepareConn) reqs' + let (toEnable, reqs'') = mapAccumL prepareConn [] reqs' + void $ withStoreBatch' c $ \db -> map (enableConnPQEncryption db) toEnable enqueueMessagesB c reqs'' where - prepareConn :: (MsgReq, SomeConn) -> Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe CR.PQEncryption, MsgFlags, AMessage) - prepareConn ((_, pqEnc, msgFlags, msg), SomeConn _ conn) = case conn of + prepareConn :: [ConnId] -> Either AgentErrorType (MsgReq, SomeConn) -> ([ConnId], Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) + prepareConn acc (Left e) = (acc, Left e) + prepareConn acc (Right ((_, pqEnc, msgFlags, msg), SomeConn _ conn)) = case conn of DuplexConnection cData _ sqs -> prepareMsg cData sqs SndConnection cData sq -> prepareMsg cData [sq] - _ -> Left $ CONN SIMPLEX + _ -> (acc, Left $ CONN SIMPLEX) where - prepareMsg :: ConnData -> NonEmpty SndQueue -> Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe CR.PQEncryption, MsgFlags, AMessage) - prepareMsg cData sqs - | ratchetSyncSendProhibited cData = Left $ CMD PROHIBITED - | otherwise = Right (cData, sqs, Just pqEnc, msgFlags, A_MSG msg) + prepareMsg :: ConnData -> NonEmpty SndQueue -> ([ConnId], Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) + prepareMsg cData@ConnData {connId, pqEncryption} sqs + | ratchetSyncSendProhibited cData = (acc, Left $ CMD 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 && pqEncryption == PQEncOff = + let cData' = cData {pqEncryption = pqEnc} :: ConnData + in (connId : acc, Right (cData', sqs, Just pqEnc, msgFlags, A_MSG msg)) + | otherwise = (acc, Right (cData, sqs, Just pqEnc, msgFlags, A_MSG msg)) connIds = map (\(connId, _, _, _) -> connId) $ rights $ toList reqs -- / async command processing v v v @@ -1007,7 +1017,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do _ -> throwError $ INTERNAL $ "incorrect connection type " <> show (internalCmdTag cmd) ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do secure rq senderKey - void $ enqueueMessage c cData sq Nothing SMP.MsgFlags {notification = True} HELLO + void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO -- ICDeleteConn is no longer used, but it can be present in old client databases ICDeleteConn -> withStore' c (`deleteCommand` cmdId) ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do @@ -1022,7 +1032,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do Just rq1 -> when (status == Confirmed) $ do secureQueue c rq' senderKey withStore' c $ \db -> setRcvQueueStatus db rq' Secured - void . enqueueMessages c cData sqs Nothing SMP.noMsgFlags $ QUSE [((server, sndId), True)] + void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)] rq1' <- withStore' c $ \db -> setRcvSwitchStatus db rq1 $ Just RSSendingQUSE let rqs' = updatedQs rq1' rqs conn' = DuplexConnection cData rqs' sqs @@ -1085,16 +1095,16 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do notify cmd = atomically $ writeTBQueue subQ (corrId, connId, APC (sAEntity @e) cmd) -- ^ ^ ^ async command processing / -enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> Maybe CR.PQEncryption -> MsgFlags -> AMessage -> m (AgentMsgId, CR.PQEncryption) -enqueueMessages c cData sqs pqEnc_ msgFlags aMessage = do +enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m (AgentMsgId, PQEncryption) +enqueueMessages c cData sqs msgFlags aMessage = do when (ratchetSyncSendProhibited cData) $ throwError $ INTERNAL "enqueueMessages: ratchet is not synchronized" - enqueueMessages' c cData sqs pqEnc_ msgFlags aMessage + enqueueMessages' c cData sqs msgFlags aMessage -enqueueMessages' :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> Maybe CR.PQEncryption -> MsgFlags -> AMessage -> m (AgentMsgId, CR.PQEncryption) -enqueueMessages' c cData sqs pqEnc_ msgFlags aMessage = - liftEither . runIdentity =<< enqueueMessagesB c (Identity (Right (cData, sqs, pqEnc_, msgFlags, aMessage))) +enqueueMessages' :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m (AgentMsgId, CR.PQEncryption) +enqueueMessages' c cData sqs msgFlags aMessage = + liftEither . runIdentity =<< enqueueMessagesB c (Identity (Right (cData, sqs, Nothing, msgFlags, aMessage))) -enqueueMessagesB :: (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe CR.PQEncryption, MsgFlags, AMessage)) -> m (t (Either AgentErrorType (AgentMsgId, CR.PQEncryption))) +enqueueMessagesB :: (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> m (t (Either AgentErrorType (AgentMsgId, PQEncryption))) enqueueMessagesB c reqs = do reqs' <- enqueueMessageB c reqs enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs' @@ -1103,12 +1113,12 @@ enqueueMessagesB c reqs = do isActiveSndQ :: SndQueue -> Bool isActiveSndQ SndQueue {status} = status == Secured || status == Active -enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe CR.PQEncryption -> MsgFlags -> AMessage -> m (AgentMsgId, CR.PQEncryption) -enqueueMessage c cData sq pqEnc_ msgFlags aMessage = - liftEither . fmap fst . runIdentity =<< enqueueMessageB c (Identity (Right (cData, [sq], pqEnc_, msgFlags, aMessage))) +enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> m (AgentMsgId, PQEncryption) +enqueueMessage c cData sq msgFlags aMessage = + liftEither . fmap fst . runIdentity =<< enqueueMessageB c (Identity (Right (cData, [sq], Nothing, msgFlags, aMessage))) -- this function is used only for sending messages in batch, it returns the list of successes to enqueue additional deliveries -enqueueMessageB :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe CR.PQEncryption, MsgFlags, AMessage)) -> m (t (Either AgentErrorType ((AgentMsgId, CR.PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) +enqueueMessageB :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage)) -> m (t (Either AgentErrorType ((AgentMsgId, PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId)))) enqueueMessageB c reqs = do getAVRange <- asks $ smpAgentVRange . config reqMids <- withStoreBatch c $ \db -> fmap (bindRight $ storeSentMsg db getAVRange) reqs @@ -1117,22 +1127,23 @@ enqueueMessageB c reqs = do let sqs' = filter isActiveSndQ sqs pure $ Right ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId)) where - storeSentMsg :: DB.Connection -> (CR.PQEncryption -> VersionRangeSMPA) -> (ConnData, NonEmpty SndQueue, Maybe CR.PQEncryption, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe CR.PQEncryption, MsgFlags, AMessage), InternalId, CR.PQEncryption)) - storeSentMsg db getAVRange req@(ConnData {connId, connAgentVersion = v}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do + storeSentMsg :: DB.Connection -> (PQEncryption -> VersionRangeSMPA) -> (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage), InternalId, PQEncryption)) + storeSentMsg db getAVRange req@(cData@ConnData {connId, pqEncryption}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do internalTs <- liftIO getCurrentTime (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash agentMsg = AgentMessage privHeader aMessage agentMsgStr = smpEncode agentMsg internalHash = C.sha256Hash agentMsgStr - (encAgentMessage, pqEncryption) <- agentRatchetEncrypt db connId agentMsgStr (e2eEncUserMsgLength v) pqEnc_ - let agentVersion = maxVersion . getAVRange $ fromMaybe CR.PQEncOff pqEnc_ + (encAgentMessage, pqEnc) <- agentRatchetEncrypt db cData agentMsgStr e2eEncUserMsgLength pqEnc_ + -- agent version range is determined by the connection suppport of PQ encryption, that is may be enabled when message is sent + let agentVersion = maxVersion $ getAVRange pqEncryption msgBody = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage} msgType = agentMessageType agentMsg - msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, pqEncryption, internalHash, prevMsgHash} + msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, pqEncryption = pqEnc, internalHash, prevMsgHash} liftIO $ createSndMsg db connId msgData liftIO $ createSndMsgDelivery db connId sq internalId - pure (req, internalId, pqEncryption) + pure (req, internalId, pqEnc) enqueueSavedMessage :: AgentMonad' m => AgentClient -> ConnData -> AgentMsgId -> SndQueue -> m () enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData, [sq], msgId) @@ -1344,7 +1355,7 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do when (connAgentVersion >= deliveryRcptsSMPAgentVersion) $ do let RcvMsg {msgMeta = MsgMeta {sndMsgId}, internalHash} = msg rcpt = A_RCVD [AMessageReceipt {agentMsgId = sndMsgId, msgHash = internalHash, rcptInfo}] - void $ enqueueMessages c cData sqs Nothing SMP.MsgFlags {notification = False} rcpt + void $ enqueueMessages c cData sqs SMP.MsgFlags {notification = False} rcpt Nothing -> case (msgType, msgReceipt) of -- only remove sent message if receipt hash was Ok, both to debug and for future redundancy (AM_A_RCVD_, Just MsgReceipt {agentMsgId = sndMsgId, msgRcptStatus = MROk}) -> @@ -1374,7 +1385,7 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq' addSubscription c rq'' - void . enqueueMessages c cData sqs Nothing SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))] + void . enqueueMessages c cData sqs SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))] rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSendingQADD let rqs' = updatedQs rq1 rqs <> [rq''] pure . connectionStats $ DuplexConnection cData rqs' sqs @@ -1403,16 +1414,20 @@ abortConnectionSwitch' c connId = _ -> throwError $ CMD PROHIBITED _ -> throwError $ CMD PROHIBITED -synchronizeRatchet' :: AgentMonad m => AgentClient -> ConnId -> CR.PQEncryption -> Bool -> m ConnectionStats +synchronizeRatchet' :: AgentMonad m => AgentClient -> ConnId -> PQEncryption -> Bool -> m ConnectionStats synchronizeRatchet' c connId pqEnc force = withConnLock c connId "synchronizeRatchet" $ do withStore c (`getConn` connId) >>= \case SomeConn _ (DuplexConnection cData@ConnData {pqEncryption} rqs sqs) | ratchetSyncAllowed cData || force -> do -- check queues are not switching? - cData' <- if pqEncryption == pqEnc then pure cData else withStore' c $ \db -> setConnPQEncryption db cData pqEnc + pqEnc' <- + if pqEnc == PQEncOn && pqEncryption == PQEncOff + then PQEncOn <$ withStore' c (`enableConnPQEncryption` connId) + else pure pqEncryption + let cData' = cData {pqEncryption = pqEnc'} :: ConnData AgentConfig {e2eEncryptVRange} <- asks config g <- asks random - (pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion $ e2eEncryptVRange pqEnc) pqEnc + (pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion $ e2eEncryptVRange pqEnc') pqEnc' enqueueRatchetKeyMsgs c cData' sqs e2eParams withStore' c $ \db -> do setConnRatchetSync db connId RSStarted @@ -1948,7 +1963,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, notify (MSGNTF $ SMP.rcvMessageMeta srvMsgId msg') where queueDrained = case conn of - DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs Nothing SMP.noMsgFlags $ QCONT (sndAddress rq) + DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ QCONT (sndAddress rq) _ -> pure () processClientMsg srvTs msgFlags msgBody = do clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <- @@ -2200,7 +2215,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, enqueueDuplexHello :: SndQueue -> m () enqueueDuplexHello sq = do let cData' = toConnData conn' - void $ enqueueMessage c cData' sq Nothing SMP.MsgFlags {notification = True} HELLO + void $ enqueueMessage c cData' sq SMP.MsgFlags {notification = True} HELLO continueSending :: SMP.MsgId -> (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m () continueSending srvMsgId addr (DuplexConnection _ _ sqs) = @@ -2257,7 +2272,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, (Just sndPubKey, Just dhPublicKey) -> do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress) let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} - void . enqueueMessages c cData' sqs Nothing SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)] + void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)] sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY let sqs'' = updatedQs sq1 sqs' <> [sq2] conn' = DuplexConnection cData' rqs sqs'' @@ -2302,7 +2317,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, withStore' c $ \db -> setSndQueueStatus db sq' Secured let sq'' = (sq' :: SndQueue) {status = Secured} -- sending QTEST to the new queue only, the old one will be removed if sent successfully - void $ enqueueMessages c cData' [sq''] Nothing SMP.noMsgFlags $ QTEST [addr] + void $ enqueueMessages c cData' [sq''] SMP.noMsgFlags $ QTEST [addr] sq1' <- withStore' c $ \db -> setSndSwitchStatus db sq1 $ Just SSSendingQTEST let sqs' = updatedQs sq1' sqs conn' = DuplexConnection cData' rqs sqs' @@ -2318,7 +2333,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, let CR.Ratchet {rcSnd} = rcPrev -- if ratchet was initialized as receiving, it means EREADY wasn't sent on key negotiation when (isNothing rcSnd) . void $ - enqueueMessages' c cData' sqs Nothing SMP.MsgFlags {notification = True} (EREADY lastExternalSndId) + enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} (EREADY lastExternalSndId) smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m () smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do @@ -2401,7 +2416,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, (_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 (CR.APRKP CR.SRKSProposed <$> pKem) e2eOtherPartyParams recreateRatchet $ CR.initSndRatchet rcVs k2Rcv rcDHRs rcParams - void . enqueueMessages' c cData' sqs Nothing SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId + void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash @@ -2428,22 +2443,22 @@ switchStatusError q expected actual = <> (", actual=" <> show actual) connectReplyQueues :: AgentMonad m => AgentClient -> ConnData -> ConnInfo -> NonEmpty SMPQueueInfo -> m () -connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = do +connectReplyQueues c cData@ConnData {userId, connId, pqEncryption} ownConnInfo (qInfo :| _) = do clientVRange <- asks $ smpClientVRange . config case qInfo `proveCompatible` clientVRange of Nothing -> throwError $ AGENT A_VERSION Just qInfo' -> do sq <- newSndQueue userId connId qInfo' sq' <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq - enqueueConfirmation c cData sq' ownConnInfo Nothing Nothing + enqueueConfirmation c cData sq' ownConnInfo Nothing pqEncryption -confirmQueueAsync :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> CR.PQEncryption -> SubscriptionMode -> m () +confirmQueueAsync :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> PQEncryption -> SubscriptionMode -> m () confirmQueueAsync c cData sq srv connInfo e2eEncryption_ pqEnc subMode = do - storeConfirmation c cData sq e2eEncryption_ (Just pqEnc) =<< mkAgentConfirmation c cData sq srv connInfo subMode + storeConfirmation c cData sq e2eEncryption_ pqEnc =<< mkAgentConfirmation c cData sq srv connInfo subMode submitPendingMsg c cData sq -confirmQueue :: forall m. AgentMonad m => Compatible VersionSMPA -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> Maybe CR.PQEncryption -> SubscriptionMode -> m () -confirmQueue (Compatible agentVersion) c cData@ConnData {connId, connAgentVersion = v} sq srv connInfo e2eEncryption_ pqEnc_ subMode = do +confirmQueue :: forall m. AgentMonad m => Compatible VersionSMPA -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> PQEncryption -> SubscriptionMode -> m () +confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption_ pqEnc subMode = do msg <- mkConfirmation =<< mkAgentConfirmation c cData sq srv connInfo subMode sendConfirmation c sq msg withStore' c $ \db -> setSndQueueStatus db sq Confirmed @@ -2451,7 +2466,7 @@ confirmQueue (Compatible agentVersion) c cData@ConnData {connId, connAgentVersio mkConfirmation :: AgentMessage -> m MsgBody mkConfirmation aMessage = withStore c $ \db -> runExceptT $ do void . liftIO $ updateSndIds db connId - (encConnInfo, _) <- agentRatchetEncrypt db connId (smpEncode aMessage) (e2eEncConnInfoLength v) pqEnc_ + (encConnInfo, _) <- agentRatchetEncrypt db cData (smpEncode aMessage) e2eEncConnInfoLength (Just pqEnc) pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo} mkAgentConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> m AgentMessage @@ -2459,18 +2474,18 @@ mkAgentConfirmation c cData sq srv connInfo subMode = do qInfo <- createReplyQueue c cData sq subMode srv pure $ AgentConnInfoReply (qInfo :| []) connInfo -enqueueConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> Maybe CR.PQEncryption -> m () -enqueueConfirmation c cData sq connInfo e2eEncryption_ pqEnc_ = do - storeConfirmation c cData sq e2eEncryption_ pqEnc_ $ AgentConnInfo connInfo +enqueueConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> PQEncryption -> m () +enqueueConfirmation c cData sq connInfo e2eEncryption_ pqEnc = do + storeConfirmation c cData sq e2eEncryption_ pqEnc $ AgentConnInfo connInfo submitPendingMsg c cData sq -storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> Maybe CR.PQEncryption -> AgentMessage -> m () -storeConfirmation c ConnData {connId, connAgentVersion = v} sq e2eEncryption_ pqEnc_ agentMsg = withStore c $ \db -> runExceptT $ do +storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> PQEncryption -> AgentMessage -> m () +storeConfirmation c cData@ConnData {connId, connAgentVersion = v} sq e2eEncryption_ pqEnc agentMsg = withStore c $ \db -> runExceptT $ do internalTs <- liftIO getCurrentTime (internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId let agentMsgStr = smpEncode agentMsg internalHash = C.sha256Hash agentMsgStr - (encConnInfo, pqEncryption) <- agentRatchetEncrypt db connId agentMsgStr (e2eEncConnInfoLength v) pqEnc_ + (encConnInfo, pqEncryption) <- agentRatchetEncrypt db cData agentMsgStr e2eEncConnInfoLength (Just pqEnc) let msgBody = smpEncode $ AgentConfirmation {agentVersion = v, e2eEncryption_, encConnInfo} msgType = agentMessageType agentMsg msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash} @@ -2504,20 +2519,21 @@ enqueueRatchetKey c cData@ConnData {connId, pqEncryption} sq e2eEncryption = do pure internalId -- encoded AgentMessage -> encoded EncAgentMessage -agentRatchetEncrypt :: DB.Connection -> ConnId -> ByteString -> Int -> Maybe CR.PQEncryption -> ExceptT StoreError IO (ByteString, CR.PQEncryption) -agentRatchetEncrypt db connId msg paddedLen pqEnc_ = do +agentRatchetEncrypt :: DB.Connection -> ConnData -> ByteString -> (PQEncryption -> Int) -> Maybe PQEncryption -> ExceptT StoreError IO (ByteString, PQEncryption) +agentRatchetEncrypt db ConnData {connId, pqEncryption} msg getPaddedLen pqEnc_ = do rc <- ExceptT $ getRatchet db connId + let paddedLen = getPaddedLen pqEncryption (encMsg, rc') <- liftE (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg pqEnc_ liftIO $ updateRatchet db connId rc' CR.SMDNoChange pure (encMsg, CR.rcSndKEM rc') -- encoded EncAgentMessage -> encoded AgentMessage -agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, CR.PQEncryption) +agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption) agentRatchetDecrypt g db connId encAgentMsg = do rc <- ExceptT $ getRatchet db connId agentRatchetDecrypt' g db connId rc encAgentMsg -agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO (ByteString, CR.PQEncryption) +agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO (ByteString, PQEncryption) agentRatchetDecrypt' g db connId rc encAgentMsg = do skipped <- liftIO $ getSkippedMsgKeys db connId (agentMsgBody_, rc', skippedDiff) <- liftE (SEAgentError . cryptoError) $ CR.rcDecrypt g rc skipped encAgentMsg diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index af271531b..d3008e790 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -282,17 +282,17 @@ supportedSMPAgentVRange pq = -- it is shorter to allow all handshake headers, -- including E2E (double-ratchet) parameters and -- signing key of the sender for the server -e2eEncConnInfoLength :: VersionSMPA -> Int -e2eEncConnInfoLength v +e2eEncConnInfoLength :: PQEncryption -> Int +e2eEncConnInfoLength = \case -- reduced by 3700 (roughly the increase of message ratchet header size + key and ciphertext in reply link) - | v >= pqdrSMPAgentVersion = 11148 - | otherwise = 14848 + PQEncOn -> 11148 + PQEncOff -> 14848 -e2eEncUserMsgLength :: VersionSMPA -> Int -e2eEncUserMsgLength v +e2eEncUserMsgLength :: PQEncryption -> Int +e2eEncUserMsgLength = \case -- reduced by 2200 (roughly the increase of message ratchet header size) - | v >= pqdrSMPAgentVersion = 13656 - | otherwise = 15856 + PQEncOn -> 13656 + PQEncOff -> 15856 -- | Raw (unparsed) SMP agent protocol transmission. type ARawTransmission = (ByteString, ByteString, ByteString) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 78660ce6c..f04bc7904 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -58,7 +58,7 @@ module Simplex.Messaging.Agent.Store.SQLite getConnData, setConnDeleted, setConnAgentVersion, - setConnPQEncryption, + enableConnPQEncryption, getDeletedConnIds, getDeletedWaitingDeliveryConnIds, setConnRatchetSync, @@ -1952,10 +1952,9 @@ setConnAgentVersion :: DB.Connection -> ConnId -> VersionSMPA -> IO () setConnAgentVersion db connId aVersion = DB.execute db "UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?" (aVersion, connId) -setConnPQEncryption :: DB.Connection -> ConnData -> CR.PQEncryption -> IO ConnData -setConnPQEncryption db cData@ConnData {connId} pqEnc = do - DB.execute db "UPDATE connections SET pq_encryption = ? WHERE conn_id = ?" (pqEnc, connId) - pure (cData :: ConnData) {pqEncryption = pqEnc} +enableConnPQEncryption :: DB.Connection -> ConnId -> IO () +enableConnPQEncryption db connId = + DB.execute db "UPDATE connections SET pq_encryption = ? WHERE conn_id = ?" (CR.PQEncOn, connId) getDeletedConnIds :: DB.Connection -> IO [ConnId] getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True) diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 9d4b919ca..b0292f9b5 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -466,6 +466,7 @@ data Ratchet a = Ratchet rcAD :: Str, rcDHRs :: PrivateKey a, rcKEM :: Maybe RatchetKEM, + rcSupportKEM :: PQEncryption, -- defines header size, can only be enabled once rcEnableKEM :: PQEncryption, -- will enable KEM on the next ratchet step rcSndKEM :: PQEncryption, -- used KEM hybrid secret for sending ratchet rcRcvKEM :: PQEncryption, -- used KEM hybrid secret for receiving ratchet @@ -596,12 +597,14 @@ initSndRatchet :: initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) = do -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr) || state.PQRss) let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs (rcPQRss <$> kemAccepted) + pqEnc = PQEncryption $ isJust rcPQRs_ in Ratchet { rcVersion, rcAD = assocData, rcDHRs, rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_, - rcEnableKEM = PQEncryption $ isJust rcPQRs_, + rcSupportKEM = pqEnc, + rcEnableKEM = pqEnc, rcSndKEM = PQEncryption $ isJust kemAccepted, rcRcvKEM = PQEncOff, rcRK, @@ -622,7 +625,7 @@ initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, ratchetKey -- as part of the connection request and random salt was received from the sender. initRcvRatchet :: forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> PQEncryption -> Ratchet a -initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) rcEnableKEM = +initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) pqEnc = Ratchet { rcVersion, rcAD = assocData, @@ -633,7 +636,8 @@ initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK -- state.PQRss = None -- state.PQRct = None rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_, - rcEnableKEM, + rcSupportKEM = pqEnc, + rcEnableKEM = pqEnc, rcSndKEM = PQEncOff, rcRcvKEM = PQEncOff, rcRK = ratchetKey, @@ -662,15 +666,15 @@ data MsgHeader a = MsgHeader -- 69 = 2 (original size) + 2 + 1+56 (Curve448) + 4 + 4 -- TODO PQ this must be version-dependent -- TODO this is the exact size, some reserve should be added -paddedHeaderLen :: VersionE2E -> Int -paddedHeaderLen v - | v >= pqRatchetE2EEncryptVersion = 2284 - | otherwise = 88 +paddedHeaderLen :: PQEncryption -> Int +paddedHeaderLen = \case + PQEncOn -> 2288 + PQEncOff -> 88 -- only used in tests to validate correct padding -- (2 bytes - version size, 1 byte - header size, not to have it fixed or version-dependent) -fullHeaderLen :: VersionE2E -> Int -fullHeaderLen v = 2 + 1 + paddedHeaderLen v + authTagSize + ivSize @AES256 +fullHeaderLen :: PQEncryption -> Int +fullHeaderLen pq = 2 + 1 + paddedHeaderLen pq + authTagSize + ivSize @AES256 -- pass the current version, as MsgHeader only includes the max supported version that can be different from the current encodeMsgHeader :: AlgorithmI a => VersionE2E -> MsgHeader a -> ByteString @@ -698,13 +702,27 @@ data EncMessageHeader = EncMessageHeader -- this encoding depends on version in EncMessageHeader because it is "current" ratchet version instance Encoding EncMessageHeader where smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} - | ehVersion >= pqRatchetE2EEncryptVersion = smpEncode (ehVersion, ehIV, ehAuthTag, Large ehBody) - | otherwise = smpEncode (ehVersion, ehIV, ehAuthTag, ehBody) + = smpEncode (ehVersion, ehIV, ehAuthTag) <> encodeLarge ehVersion ehBody smpP = do (ehVersion, ehIV, ehAuthTag) <- smpP - ehBody <- if ehVersion >= pqRatchetE2EEncryptVersion then unLarge <$> smpP else smpP + ehBody <- largeP pure EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} +-- the encoder always uses 2-byte lengths for the new version, even for short headers without PQ keys. +encodeLarge :: VersionE2E -> ByteString -> ByteString +encodeLarge v s + -- the condition for length is not necessary, it's here as a fallback. + | v >= pqRatchetE2EEncryptVersion || B.length s > 255 = smpEncode $ Large s + | otherwise = smpEncode s + +-- This parser relies on the fact that header cannot be shorter than 32 bytes (it is ~69 bytes without PQ KEM), +-- therefore if the first byte is less or equal to 31 (x1F), then we have 2 byte-length limited to 8191. +-- This allows upgrading the current version in one message. +largeP :: Parser ByteString +largeP = do + len1 <- peekWord8' + if len1 < 32 then unLarge <$> smpP else smpP + -- the header is length-prefixed to parse it as string and use as part of associated data for authenticated encryption data EncRatchetMessage = EncRatchetMessage { emHeader :: ByteString, @@ -712,19 +730,13 @@ data EncRatchetMessage = EncRatchetMessage emBody :: ByteString } --- the encoder always uses 2-byte lengths for the new version, even for short headers without PQ keys. encodeEncRatchetMessage :: VersionE2E -> EncRatchetMessage -> ByteString encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag} - | v >= pqRatchetE2EEncryptVersion = smpEncode (Large emHeader, emAuthTag, Tail emBody) - | otherwise = smpEncode (emHeader, emAuthTag, Tail emBody) + = encodeLarge v emHeader <> smpEncode (emAuthTag, Tail emBody) --- This parser relies on the fact that header cannot be shorter than 32 bytes (it is ~69 bytes without PQ KEM), --- therefore if the first byte is less or equal to 31 (x1F), then we have 2 byte-length limited to 8191. --- This allows upgrading the current version in one message. encRatchetMessageP :: Parser EncRatchetMessage encRatchetMessageP = do - len1 <- peekWord8' - emHeader <- if len1 < 32 then unLarge <$> smpP else smpP + emHeader <- largeP (emAuthTag, Tail emBody) <- smpP pure EncRatchetMessage {emHeader, emBody, emAuthTag} @@ -801,30 +813,42 @@ joinContactInitialKeys = \case rcEncrypt :: AlgorithmI a => Ratchet a -> Int -> ByteString -> Maybe PQEncryption -> ExceptT CryptoError IO (ByteString, Ratchet a) rcEncrypt Ratchet {rcSnd = Nothing} _ _ _ = throwE CERatchetState -rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcVersion} paddedMsgLen msg pqEnc_ = do +rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcKEM, rcNs, rcPN, rcAD = Str rcAD, rcSupportKEM, rcEnableKEM, rcVersion} paddedMsgLen msg pqEnc_ = do -- state.CKs, mk = KDF_CK(state.CKs) let (ck', mk, iv, ehIV) = chainKdf rcCKs + v = current rcVersion + -- PQ encryption can be enabled or disabled + rcEnableKEM' = fromMaybe rcEnableKEM pqEnc_ + -- support for PQ encryption (and therefore large headers/small envelopes) can only be enabled, it cannot be disabled + rcSupportKEM' = PQEncryption $ enablePQ rcSupportKEM || enablePQ rcEnableKEM' -- enc_header = HENCRYPT(state.HKs, header) - let v = current rcVersion - (ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen v) rcAD (msgHeader v) + (ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen rcSupportKEM') rcAD (msgHeader v) -- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header)) let emHeader = smpEncode EncMessageHeader {ehVersion = v, ehBody, ehAuthTag, ehIV} (emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (rcAD <> emHeader) msg let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag} - -- state.Ns += 1 -- TODO v5.8 remove comments below -- Note that maxSupported will not downgrade here below current. -- TODO v5.7 remove comments below - -- It will downgrade when decrypting the message when the current version downgrades to remove support for PQ encryption. - -- TODO v5.8 replace `max v currentE2EEncryptVersion` with `v` (to allow downgrade when app downgraded) - rc' = rc {rcSnd = Just sr {rcCKs = ck'}, rcNs = rcNs + 1, rcVersion = rcVersion {maxSupported = max v currentE2EEncryptVersion}} + -- TODO PQ It will downgrade when decrypting the message when the current version downgrades to remove support for PQ encryption. + -- TODO v5.8 possibly, replace `max v currentE2EEncryptVersion` with `v` (to allow downgrade when app downgraded)? + -- + -- state.Ns += 1 + rc' = + rc + { rcSnd = Just sr {rcCKs = ck'}, + rcNs = rcNs + 1, + rcSupportKEM = rcSupportKEM', + rcEnableKEM = rcEnableKEM', + rcVersion = rcVersion {maxSupported = max v currentE2EEncryptVersion} + } rc'' = case pqEnc_ of Nothing -> rc' -- This sets max version to support PQ encryption. -- Current version upgrade happens when peer decrypts the message. -- TODO v5.7 remove version upgrade here, as it's already upgraded above - Just PQEncOn -> rc' {rcEnableKEM = PQEncOn, rcVersion = rcVersion {maxSupported = pqRatchetE2EEncryptVersion}} - Just PQEncOff -> rc' {rcEnableKEM = PQEncOff, rcKEM = (\rck -> rck {rcKEMs = Nothing}) <$> rcKEM} + Just PQEncOn -> rc' {rcVersion = rcVersion {maxSupported = max v pqRatchetE2EEncryptVersion}} + Just PQEncOff -> rc' {rcKEM = (\rck -> rck {rcKEMs = Nothing}) <$> rcKEM} pure (msg', rc'') where -- header = HEADER_PQ2( @@ -870,7 +894,6 @@ rcDecrypt :: ByteString -> ExceptT CryptoError IO (DecryptResult a) rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do - -- TODO PQ versioning should change encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError encRatchetMessageP msg' encHdr <- parseE CryptoHeaderError smpP emHeader -- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD) @@ -909,12 +932,14 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do where upgradedRatchet :: Ratchet a upgradedRatchet - | msgMaxVersion > current rcVersion = rc {rcVersion = rcVersion {current = min msgMaxVersion $ maxSupported rcVersion}} + | msgMaxVersion > current = rc {rcVersion = rcVersion {current = max current $ min msgMaxVersion maxSupported}} | otherwise = rc + where + RVersions {current, maxSupported} = rcVersion smkDiff :: SkippedMsgKeys -> SkippedMsgDiff smkDiff smks = if M.null smks then SMDNoChange else SMDAdd smks ratchetStep :: Ratchet a -> MsgHeader a -> ExceptT CryptoError IO (Ratchet a) - ratchetStep rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr} MsgHeader {msgDHRs, msgKEM} = do + ratchetStep rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr, rcSupportKEM} MsgHeader {msgDHRs, msgKEM} = do (kemSS, kemSS', rcKEM') <- pqRatchetStep rc' msgKEM -- state.DHRs = GENERATE_DH() (_, rcDHRs') <- atomically $ generateKeyPair @a g @@ -924,11 +949,13 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do (rcRK'', rcCKs', rcNHKs') = rootKdf rcRK' msgDHRs rcDHRs' kemSS' sndKEM = isJust kemSS' rcvKEM = isJust kemSS + enableKEM = sndKEM || rcvKEM || isJust rcKEM' pure rc' { rcDHRs = rcDHRs', rcKEM = rcKEM', - rcEnableKEM = PQEncryption $ sndKEM || rcvKEM, + rcSupportKEM = PQEncryption $ enablePQ rcSupportKEM || enableKEM, + rcEnableKEM = PQEncryption enableKEM, rcSndKEM = PQEncryption sndKEM, rcRcvKEM = PQEncryption rcvKEM, rcRK = rcRK'', @@ -945,7 +972,7 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do -- received message does not have KEM in header, -- but the user enabled KEM when sending previous message Nothing -> case rcKEM of - Nothing | pqEnc -> do + Nothing | pqEnc && current rv >= pqRatchetE2EEncryptVersion -> do rcPQRs <- liftIO $ sntrup761Keypair g pure (Nothing, Nothing, Just RatchetKEM {rcPQRs, rcKEMs = Nothing}) _ -> pure (Nothing, Nothing, Nothing) diff --git a/tests/AgentTests/DoubleRatchetTests.hs b/tests/AgentTests/DoubleRatchetTests.hs index 0e4b9079e..5c5241849 100644 --- a/tests/AgentTests/DoubleRatchetTests.hs +++ b/tests/AgentTests/DoubleRatchetTests.hs @@ -89,10 +89,16 @@ testAlgs test = test C.SX25519 >> test C.SX448 paddedMsgLen :: Int paddedMsgLen = 100 -fullMsgLen :: VersionE2E -> Int -fullMsgLen v = headerLenLength + fullHeaderLen v + C.authTagSize + paddedMsgLen +fullMsgLen :: Ratchet a -> Int +fullMsgLen Ratchet {rcSupportKEM} = headerLenLength + fullHeaderLen rcSupportKEM + C.authTagSize + paddedMsgLen where - headerLenLength = if v < pqRatchetE2EEncryptVersion then 1 else 3 -- two bytes are added because of two Large used in new encoding + -- v = current rcVersion + headerLenLength = case rcSupportKEM of + PQEncOn -> 3 -- two bytes are added because of two Large used in new encoding + PQEncOff -> 1 + -- TODO PQ below should work too + -- | v >= pqRatchetE2EEncryptVersion = 3 + -- | otherwise = 1 testMessageHeader :: forall a. AlgorithmI a => VersionE2E -> C.SAlgorithm a -> Expectation testMessageHeader v _ = do @@ -302,8 +308,10 @@ testEnableKEM alice bob _ _ _ = do (alice, "accepting KEM") \#>! bob (alice, "KEM not enabled yet here too") \#>! bob (bob, "KEM is still not enabled") \#>! alice - (alice, "now KEM is enabled") !#> bob - (bob, "now KEM is enabled for both sides") !#> alice + (alice, "KEM still not enabled 2") \#>! bob + (bob, "now KEM is enabled") !#> alice + (alice, "now KEM is enabled for both sides") !#> bob + (bob, "Still enabled for both sides") !#> alice (alice, "disabling KEM") !#>\ bob (bob, "KEM not disabled yet") !#> alice (alice, "KEM disabled") \#> bob @@ -318,12 +326,20 @@ testEnableKEMStrict alice bob _ _ _ = do (alice, "accepting KEM") \#>! bob (alice, "KEM not enabled yet here too") \#>! bob (bob, "KEM is still not enabled") \#>! alice - (alice, "now KEM is enabled") !#>! bob - (bob, "now KEM is enabled for both sides") !#>! alice + (alice, "KEM still not enabled 2") \#>! bob + (bob, "now KEM is enabled") !#>! alice + (alice, "now KEM is enabled for both sides") !#>! bob + (bob, "Still enabled for both sides") !#>! alice (alice, "disabling KEM") !#>\ bob (bob, "KEM not disabled yet") !#>! alice (alice, "KEM disabled") \#>\ bob (bob, "KEM disabled on both sides") \#>! alice + (alice, "KEM still disabled 1") \#>\ bob + (bob, "KEM still disabled 2") \#>! alice + (alice, "KEM still disabled 3") \#>\ bob + (bob, "KEM still disabled 4") \#>! alice + (alice, "KEM still disabled 5") \#>\ bob + (bob, "KEM still disabled 6") \#>! alice testKeyJSON :: forall a. AlgorithmI a => C.SAlgorithm a -> IO () testKeyJSON _ = do @@ -571,13 +587,13 @@ testRatchetVersions pq = in RVersions v v encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff)) -encrypt_ enableKem (_, rc, _) msg = +encrypt_ pqEnc_ (_, rc, _) msg = -- print msg >> - runExceptT (rcEncrypt rc paddedMsgLen msg enableKem) + runExceptT (rcEncrypt rc paddedMsgLen msg pqEnc_) >>= either (pure . Left) checkLength where checkLength (msg', rc') = do - B.length msg' `shouldBe` fullMsgLen (current $ rcVersion rc) + B.length msg' `shouldBe` fullMsgLen rc' pure $ Right (msg', rc', SMDNoChange) decrypt_ :: (AlgorithmI a, DhAlgorithm a) => (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff))