mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 14:16:00 +00:00
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
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
e04705d9c5
commit
b435a4dacb
@@ -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 <QADD>:" <> 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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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))
|
||||
|
||||
Reference in New Issue
Block a user