dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-09-16 17:03:35 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into ep/log-alpn

Browse Source
This commit is contained in:
Evgeny Poberezkin
2026-08-23 16:08:22 +01:00
parent 2c4ad0634d ac4bf690b6
commit d3ac93d6b1
18 changed files with 871 additions and 479 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/FileTransfer/Util.hs
+9 -2
View File
@@ -1,19 +1,26 @@
module Simplex.FileTransfer.Util
( uniqueCombine,
safeFileNameStr,
removePath,
)
where
import Simplex.Messaging.Util (ifM, whenM)
import System.FilePath (splitExtensions, (</>))
import System.FilePath (makeValid, splitExtensions, takeFileName, (</>))
import UnliftIO
import UnliftIO.Directory
safeFileNameStr :: String -> String
safeFileNameStr = notDots . makeValid . takeFileName
where
notDots n = if n == "." || n == ".." then "_" else n
-- | The file name is sanitized, so the combined path cannot escape the folder.
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
uniqueCombine filePath fileName = tryCombine (0 :: Int)
where
tryCombine n =
let (name, ext) = splitExtensions fileName
let (name, ext) = splitExtensions $ safeFileNameStr fileName
suffix = if n == 0 then "" else "_" <> show n
f = filePath </> (name <> suffix <> ext)
in ifM (doesPathExist f) (tryCombine $ n + 1) (pure f)
src/Simplex/Messaging/Agent.hs
+167 -100
View File
@@ -48,7 +48,7 @@ module Simplex.Messaging.Agent
createUser,
deleteUser,
setUserService,
connRequestPQSupport,
connRequestAgentVersion,
prepareConnectionToCreate,
createConnectionAsync,
setConnShortLinkAsync,
@@ -903,18 +903,16 @@ newConnNoQueues c userId enableNtfs cMode pqSupport = do
-- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection,
-- and join should retry, the same as 1-time invitation joins.
joinConnAsync :: AgentClient -> ACorrId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ()
joinConnAsync c corrId updateConn connId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do
joinConnAsync c corrId updateConn connId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSupport subMode = do
when updateConn $ throwE $ CMD PROHIBITED "joinConnAsync: updateConn not allowed for invitation URI"
withInvLock c (strEncode cReqUri) "joinConnAsync" $
lift (compatibleInvitationUri cReqUri) >>= \case
Just (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v)
Just _ ->
enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN (JRConnReq enableNtfs (ACR sConnectionMode cReqUri) pqSupport) subMode cInfo
Nothing -> throwE $ AGENT A_VERSION
joinConnAsync c corrId updateConn connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode =
joinConnAsync c corrId updateConn connId enableNtfs cReqUri@CRContactUri {} cInfo pqSupport subMode =
lift (compatibleContactUri cReqUri) >>= \case
Just (_, rks_, Compatible connAgentVersion) -> do
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (addrKeysE2EVersion <$> rks_)
Just (_, _, Compatible connAgentVersion) -> do
when updateConn $ withStore' c $ \db -> updateNewConnJoin db connId connAgentVersion pqSupport enableNtfs
enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN (JRConnReq enableNtfs (ACR sConnectionMode cReqUri) pqSupport) subMode cInfo
Nothing -> throwE $ AGENT A_VERSION
@@ -1371,21 +1369,20 @@ newQueueNtfSubscription c RcvQueue {userId, connId, server, clientNtfCreds} ntfS
liftIO $ sendNtfSubCommand ns (NSCCreate, [connId])
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Maybe UTCTime -> ConnectionRequestUri c -> PQSupport -> AM ConnId
newConnToJoin c userId connId enableNtfs serviceRequestExpiresAt cReq pqSup = case cReq of
newConnToJoin c userId connId enableNtfs serviceRequestExpiresAt cReq pqSupport = case cReq of
CRInvitationUri {} ->
lift (compatibleInvitationUri cReq) >>= \case
Just (_, Compatible (CR.E2ERatchetParams v _ _ _), aVersion) -> create aVersion (Just v)
Just (_, _, aVersion) -> create aVersion
Nothing -> throwE $ AGENT A_VERSION
CRContactUri {} ->
lift (compatibleContactUri cReq) >>= \case
Just (_, rks_, aVersion) -> create aVersion (addrKeysE2EVersion <$> rks_)
Just (_, _, aVersion) -> create aVersion
Nothing -> throwE $ AGENT A_VERSION
where
create :: Compatible VersionSMPA -> Maybe CR.VersionE2E -> AM ConnId
create (Compatible connAgentVersion) e2eV_ = do
create :: Compatible VersionSMPA -> AM ConnId
create (Compatible connAgentVersion) = do
g <- asks random
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion e2eV_
cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt}
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt}
withStore c $ \db -> createNewConn db g cData SCMInvitation
newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> PQSupport -> AM ConnId
@@ -1411,12 +1408,11 @@ joinConn c nm userId connId enableNtfs cReq cInfo pqSupport subMode = do
joinConnSrv c nm userId connId enableNtfs cReq cInfo pqSupport subMode srv
startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM ((ConnData, SndQueue), (Maybe (CR.SndE2ERatchetParams 'C.X448), Maybe SMP.LinkId))
startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSupport =
lift (compatibleInvitationUri cReqUri) >>= \case
Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do
-- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out
-- e2ePubKey is always present, it's Maybe historically
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v)
g <- asks random
maxSupported <- asks $ maxVersion . e2eEncryptVRange . config
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt = Nothing}
@@ -1445,7 +1441,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
createRatchet_ :: DB.Connection -> TVar ChaChaDRG -> ConnId -> CR.VersionE2E -> PQSupport -> CR.RcvE2ERatchetParams 'C.X448 -> ExceptT StoreError IO (CR.RatchetX448, CR.SndE2ERatchetParams 'C.X448)
createRatchet_ db g connId maxSupported pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do
(pks, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport)
(pks, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ kem_ pqSupport)
(_, rcDHRs) <- atomically $ C.generateKeyPair g
rcParams <- liftEitherWith (SEAgentError . cryptoError) $ CR.pqX3dhSnd pks e2eRcvParams
let rcVs = CR.RatchetVersions {current = v, maxSupported}
@@ -1463,14 +1459,13 @@ startJoinInvitationDR c userId ConnData {connId} DRInvitation {ratchetState, rep
liftIO $ createRatchet db connId ratchetState
ExceptT $ updateNewConnSnd db connId q
connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport))
connRequestPQSupport c pqSup cReq = withAgentEnv' c $ case cReq of
CRInvitationUri {} -> invPQSupported <$$> compatibleInvitationUri cReq
where
invPQSupported (_, Compatible (CR.E2ERatchetParams e2eV _ _ _), Compatible agentV) = (agentV, pqSup `CR.pqSupportAnd` versionPQSupport_ agentV (Just e2eV))
CRContactUri {} -> ctPQSupported <$$> compatibleContactUri cReq
where
ctPQSupported (_, rks_, Compatible agentV) = (agentV, pqSup `CR.pqSupportAnd` versionPQSupport_ agentV (addrKeysE2EVersion <$> rks_))
connRequestAgentVersion :: AgentClient -> ConnectionRequestUri c -> IO (Maybe VersionSMPA)
connRequestAgentVersion c cReq = withAgentEnv' c $ case cReq of
CRInvitationUri {} -> aVersion <$$> compatibleInvitationUri cReq
CRContactUri {} -> aVersion <$$> compatibleContactUri cReq
where
aVersion :: (Compatible SMPQueueInfo, r, Compatible VersionSMPA) -> VersionSMPA
aVersion (_, _, Compatible agentV) = agentV
compatibleInvitationUri :: ConnectionRequestUri 'CMInvitation -> AM' (Maybe (Compatible SMPQueueInfo, Compatible (CR.RcvE2ERatchetParams 'C.X448), Compatible VersionSMPA))
compatibleInvitationUri (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) = do
@@ -1495,13 +1490,6 @@ compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues =
Just (ratchetKeyId, e2eRcvParams) ->
Just . (ratchetKeyId,) <$> (e2eRcvParams `compatibleVersion` e2eVR)
versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
{-# INLINE versionPQSupport_ #-}
addrKeysE2EVersion :: (RatchetKeyId, Compatible (CR.RcvE2ERatchetParams 'C.X448)) -> CR.VersionE2E
addrKeysE2EVersion (_, Compatible (CR.E2ERatchetParams e2eV _ _ _)) = e2eV
joinConnSrv :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured
joinConnSrv c nm userId connId enableNtfs cReq cInfo pqSup subMode srv =
joinConnSrv' c nm userId connId enableNtfs cReq cInfo pqSup subMode srv $ \replyQInfo _ -> AgentConnInfoReply (replyQInfo :| []) cInfo
@@ -1522,14 +1510,14 @@ joinConnSrv' c nm userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup su
((cData, sq), (e2eSndParams, lnkId_)) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup
secureConfirmQueue c nm cData rq_ sq srv cInfo e2eSndParams subMode
>>= (mapM_ (delInvSL c connId srv) lnkId_ $>)
joinConnSrv' c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv mkInner =
joinConnSrv' c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSupport subMode srv mkInner =
lift (compatibleContactUri cReqUri) >>= \case
Just (qInfo, ratchet_, Compatible v) ->
withInvLock c (strEncode cReqUri) "joinConnSrv" $ do
SomeConn cType conn <- withStore c (`getConn` connId)
envelope <- case ratchet_ of
Nothing -> do
let pqInitKeys = CR.joinContactInitialKeys (v >= pqdrSMPAgentVersion) pqSup
let pqInitKeys = CR.joinContactInitialKeys pqSupport
CCLink cReq _ <- case conn of
NewConnection _ -> newRcvConnSrv c NRMBackground userId connId enableNtfs SCMInvitation Nothing Nothing pqInitKeys False subMode srv
RcvConnection _ rq -> mkJoinInvitation rq pqInitKeys
@@ -1538,8 +1526,7 @@ joinConnSrv' c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup s
Just (ratchetKeyId, Compatible e2eParams@(CR.E2ERatchetParams e2eV _ _ _)) -> do
g <- asks random
e2eVR <- asks $ e2eEncryptVRange . config
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ v (Just e2eV)
maxV = maxVersion e2eVR
let maxV = maxVersion e2eVR
rq <- case conn of
NewConnection _ -> do
e2eKeys <- atomically $ C.generateKeyPair g
@@ -2237,8 +2224,12 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
ICDeleteConn -> withStore' c (`deleteCommand` cmdId)
ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do
rq <- withStore c (\db -> getDeletedRcvQueue db connId srv rId)
deleteQueue c NRMBackground rq
withStore' c (`deleteConnRcvQueue` rq)
maxErrs <- asks $ deleteErrorCount . config
tryAllErrors (deleteQueue c NRMBackground rq) >>= \case
Left e | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> do
withStore' c (`incRcvDeleteErrors` rq)
throwE e
_ -> withStore' c (`deleteConnRcvQueue` rq)
ICQSecure rId senderKey ->
withServer $ \srv -> tryWithLock "ICQSecure" . withDuplexConn $ \(DuplexConnection cData rqs sqs) ->
case find (sameQueue (srv, rId)) rqs of
@@ -2258,6 +2249,31 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
notify $ SWITCH QDRcv SPSecured cStats
_ -> internalErr "ICQSecure: no switching queue found"
_ -> internalErr "ICQSecure: queue address not found in connection"
ICQSndSecure sId ->
withServer $ \srv -> tryWithLock "ICQSndSecure" . withDuplexConn $ \(DuplexConnection cData@ConnData {connAgentVersion} rqs sqs) ->
case findQ (srv, sId) sqs of
Nothing -> internalErr "ICQSndSecure: queue address not found in connection"
Just sq'@SndQueue {dbReplaceQueueId} ->
case dbReplaceQueueId >>= \replaceQId -> find ((replaceQId ==) . dbQId) sqs of
Just oldSq -> do
secureSndQueue c NRMBackground sq'
let confMsg = smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_ = Nothing, encConnInfo = ""}
void $ sendConfirmation c NRMBackground sq' confMsg
oldSq' <- withStore' c $ \db -> do
setSndQueueStatus db sq' Active
setSndQueuePrimary db connId sq'
setSndSwitchStatus db oldSq $ Just SSSendingQEND
let sq'' = (sq' :: SndQueue) {status = Active, primary = True, dbReplaceQueueId = Nothing}
pending <- withStore' c $ \db -> countSndQueueDeliveries db sq''
atomically $ modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + pending}
lift $ resumeMsgDelivery c sq''
void $ enqueueMessages c cData [oldSq, sq''] SMP.noMsgFlags $ QEND [qAddress oldSq]
let conn' = DuplexConnection cData rqs (updatedQs oldSq' $ updatedQs sq'' sqs)
cStats <- connectionStats c conn'
notify $ SWITCH QDSnd SPSecured cStats
Nothing ->
forM_ (find (\q -> sndSwchStatus q == Just SSSendingQEND) sqs) $ \oldSq ->
void $ enqueueMessages c cData [oldSq, sq'] SMP.noMsgFlags $ QEND [qAddress oldSq]
ICQDelete rId -> do
withServer $ \srv -> tryWithLock "ICQDelete" . withDuplexConn $ \(DuplexConnection cData@ConnData {enableNtfs} rqs sqs) -> do
case removeQ (srv, rId) rqs of
@@ -2282,9 +2298,11 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
notify $ SWITCH QDRcv SPCompleted cStats
_ -> internalErr "ICQDelete: cannot delete the only queue in connection"
where
ack srv rId srvMsgId = do
rq <- withStore c $ \db -> getRcvQueue db connId srv rId
ackQueueMessage c rq srvMsgId
ack srv rId srvMsgId =
withStore' c (\db -> getRcvQueue db connId srv rId) >>= \case
Right rq -> ackQueueMessage c rq srvMsgId
Left SEConnNotFound -> pure Nothing
Left e -> throwE $ storeError e
secure :: RcvQueue -> SMP.SndPublicAuthKey -> AM ()
secure rq@RcvQueue {server} senderKey = do
secureQueue c NRMBackground rq senderKey
@@ -2339,8 +2357,10 @@ enqueueMessagesB c reqs = do
enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs'
pure $ fst <$$> reqs'
isActiveSndQ :: SndQueue -> Bool
isActiveSndQ SndQueue {status} = status == Secured || status == Active
isActiveSndQ :: ConnData -> SndQueue -> Bool
isActiveSndQ ConnData {connAgentVersion} sq@SndQueue {status, sndSwchStatus} =
sndSwchStatus /= Just SSSendingQEND
&& (status == Secured || status == Active || (connAgentVersion >= rpcAddressSMPAgentVersion && securingSndQueue sq))
{-# INLINE isActiveSndQ #-}
enqueueMessage :: AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption)
@@ -2354,9 +2374,9 @@ enqueueMessageB c reqs = do
cfg <- asks config
(_, reqMids) <- unsafeWithStore c $ \db -> do
mapAccumLM (\ids r -> storeSentMsg db cfg ids r `E.catchAny` \e -> (ids,) <$> handleInternal e) IM.empty reqs
forME reqMids $ \((csqs_, _, _, _), InternalId msgId, pqSecr) -> forM csqs_ $ \(_, sq :| sqs) -> do
forME reqMids $ \((csqs_, _, _, _), InternalId msgId, pqSecr) -> forM csqs_ $ \(cData, sq :| sqs) -> do
submitPendingMsg c sq
let sqs' = filter isActiveSndQ sqs
let sqs' = filter (isActiveSndQ cData) sqs
pure ((msgId, pqSecr), if null sqs' then Nothing else Just (sqs', msgId))
where
storeSentMsg ::
@@ -2436,9 +2456,13 @@ resumeMsgDelivery :: AgentClient -> SndQueue -> AM' ()
-- hasWork is passed as False to avoid unnecessary write to TMVar:
-- - new worker is always created by "some work to do".
-- - if the worker already exists, there is no need to "push" it again.
resumeMsgDelivery = void .: getDeliveryWorker False
resumeMsgDelivery c sq = unless (securingSndQueue sq) $ void $ getDeliveryWorker False c sq
{-# INLINE resumeMsgDelivery #-}
securingSndQueue :: SndQueue -> Bool
securingSndQueue SndQueue {status, dbReplaceQueueId} = status == New && isJust dbReplaceQueueId
{-# INLINE securingSndQueue #-}
getDeliveryWorker :: Bool -> AgentClient -> SndQueue -> AM' (Worker, TMVar ())
getDeliveryWorker hasWork c sq =
getAgentWorker' fst mkLock "msg_delivery" hasWork c (qAddress sq) (smpDeliveryWorkers c) (runSmpQueueMsgDelivery c sq)
@@ -2448,7 +2472,7 @@ getDeliveryWorker hasWork c sq =
pure (w, retryLock)
submitPendingMsg :: AgentClient -> SndQueue -> AM' ()
submitPendingMsg c sq = do
submitPendingMsg c sq = unless (securingSndQueue sq) $ do
atomically $ modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + 1}
void $ getDeliveryWorker True c sq
@@ -2519,6 +2543,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
AM_QKEY_ -> qError msgId "QKEY: AUTH"
AM_QUSE_ -> qError msgId "QUSE: AUTH"
AM_QTEST_ -> qError msgId "QTEST: AUTH"
AM_QEND_ -> delMsg msgId
AM_EREADY_ -> notifyDel msgId err
AM_SRV_REQ -> logError "AM_SRV_REQ: unexpected stored message" >> delMsg msgId
AM_SRV_RESP -> notifyDel msgId err
@@ -2606,6 +2631,20 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server,
_ -> internalErr msgId "sent QTEST: there is only one queue in connection"
_ -> internalErr msgId "sent QTEST: queue not in connection or not replacing another queue"
_ -> internalErr msgId "QTEST sent not in duplex connection"
AM_QEND_ -> withConnLockNotify c connId "runSmpQueueMsgDelivery AM_QEND_" $ do
SomeConn _ conn <- withStore c (`getConn` connId)
case conn of
DuplexConnection cData' rqs sqs ->
forM (removeQP (\sq' -> sndSwchStatus sq' == Just SSSendingQEND) sqs) $ \case
(oldSq, sq'' : sqs') -> do
atomically $ TM.delete (qAddress oldSq) $ smpDeliveryWorkers c
withStore' c $ \db -> do
deletePendingMsgs db connId oldSq
deleteConnSndQueue db connId oldSq
cStats <- connectionStats c $ DuplexConnection cData' rqs (sq'' :| sqs')
pure ("", connId, AEvt SAEConn $ SWITCH QDSnd SPCompleted cStats)
(_, []) -> pure ("", connId, AEvt SAEConn $ ERR $ INTERNAL "sent QEND: no remaining queue in connection")
_ -> internalErr msgId "QEND sent not in duplex connection"
AM_EREADY_ -> pure ()
AM_SRV_REQ -> logError "AM_SRV_REQ: unexpected stored message"
AM_SRV_RESP -> notify $ SSENT mId proxySrv_
@@ -2681,15 +2720,14 @@ ackMessage' c connId msgId rcptInfo_ = withConnLockNotify c connId "ackMessage"
del :: AM ()
del = withStore' c $ \db -> deleteMsg db connId $ InternalId msgId
sendRcpt :: Connection 'CDuplex -> AM ()
sendRcpt (DuplexConnection cData@ConnData {connAgentVersion} _ sqs) = do
sendRcpt (DuplexConnection cData _ sqs) = do
msg@RcvMsg {msgType, msgReceipt} <- withStore c $ \db -> getRcvMsg db connId $ InternalId msgId
case rcptInfo_ of
Just rcptInfo -> do
unless (msgType == AM_A_MSG_) . throwE $ CMD PROHIBITED "ackMessage: receipt not allowed"
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 SMP.MsgFlags {notification = False} rcpt
let RcvMsg {msgMeta = MsgMeta {sndMsgId}, internalHash} = msg
rcpt = A_RCVD [AMessageReceipt {agentMsgId = sndMsgId, msgHash = internalHash, rcptInfo}]
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}) ->
@@ -2742,7 +2780,7 @@ abortConnectionSwitch' c connId =
withStore c (`getConn` connId) >>= \case
SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
Just rq
| canAbortRcvSwitch rq -> do
| canAbortRcvSwitch cData rq -> do
when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "abortConnectionSwitch: send prohibited"
-- multiple queues to which the connections switches were possible when repeating switch was allowed
let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs
@@ -2771,7 +2809,7 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
AgentConfig {e2eEncryptVRange} <- asks config
g <- asks random
(pks, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqSupport'
enqueueRatchetKeyMsgs c sqs e2eParams
enqueueRatchetKeyMsgs c cData' sqs e2eParams
withStore' c $ \db -> do
setConnRatchetSync db connId RSStarted
setRatchetX3dhKeys db connId pks
@@ -2957,12 +2995,12 @@ getConnectionRatchetAdHash' c connId = do
connectionStats :: AgentClient -> Connection c -> AM ConnectionStats
connectionStats c = \case
RcvConnection cData rq -> do
rcvQueuesInfo <- (: []) <$> rcvQueueInfo rq
rcvQueuesInfo <- (: []) <$> rcvQueueInfo cData rq
pure (stats cData) {rcvQueuesInfo, subStatus = connSubStatus rcvQueuesInfo}
SndConnection cData sq -> do
pure (stats cData) {sndQueuesInfo = [sndQueueInfo sq]}
DuplexConnection cData rqs sqs -> do
rcvQueuesInfo <- mapM rcvQueueInfo (L.toList rqs)
rcvQueuesInfo <- mapM (rcvQueueInfo cData) (L.toList rqs)
pure
(stats cData)
{ rcvQueuesInfo,
@@ -2970,7 +3008,7 @@ connectionStats c = \case
subStatus = connSubStatus rcvQueuesInfo
}
ContactConnection cData rq -> do
rcvQueuesInfo <- (: []) <$> rcvQueueInfo rq
rcvQueuesInfo <- (: []) <$> rcvQueueInfo cData rq
pure (stats cData) {rcvQueuesInfo, subStatus = connSubStatus rcvQueuesInfo}
NewConnection cData ->
pure $ stats cData
@@ -2982,13 +3020,13 @@ connectionStats c = \case
rcvQueuesInfo = [],
sndQueuesInfo = [],
ratchetSyncState,
ratchetSyncSupported = connAgentVersion >= ratchetSyncSMPAgentVersion,
ratchetSyncSupported = True,
subStatus = Nothing
}
rcvQueueInfo :: RcvQueue -> AM RcvQueueInfo
rcvQueueInfo rq@RcvQueue {server, status, rcvSwchStatus} = do
rcvQueueInfo :: ConnData -> RcvQueue -> AM RcvQueueInfo
rcvQueueInfo cData rq@RcvQueue {server, status, rcvSwchStatus} = do
subStatus <- atomically checkQueueSubStatus
pure $ RcvQueueInfo {rcvServer = server, status, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq, subStatus}
pure $ RcvQueueInfo {rcvServer = server, status, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch cData rq, subStatus}
where
checkQueueSubStatus :: STM SubscriptionStatus
checkQueueSubStatus =
@@ -3479,7 +3517,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
_ -> pure ()
processClientMsg srvTs msgFlags msgBody = do
clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-
parseMessage msgBody
parseMessage "4" msgBody
clientVRange <- asks $ smpClientVRange . config
unless (phVer `isCompatible` clientVRange || phVer <= agreedClientVerion) . throwE $ AGENT A_VERSION
case (e2eDhSecret, e2ePubKey_) of
@@ -3536,6 +3574,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
-- no action needed for QTEST
-- any message in the new queue will mark it active and trigger deletion of the old queue
QTEST _ -> logServer "<--" c srv rId ("MSG <QTEST>:" <> logSecret' srvMsgId) >> ackDel msgId
QEND addrs -> qDuplexAckDel conn'' "QEND" $ qEndMsg srvMsgId addrs
EREADY _ -> qDuplexAckDel conn'' "EREADY" $ ereadyMsg rcPrev
where
qDuplexAckDel :: Connection c -> String -> (Connection 'CDuplex -> AM ()) -> AM ACKd
@@ -3567,7 +3606,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
notify $ ERR (AGENT $ A_DUPLICATE $ Just DroppedMsg {brokerTs, attempts})
ackDel internalId
else
liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
liftEither (parse smpP (AGENT $ A_MESSAGE "parse msg body 1") agentMsgBody) >>= \case
AgentMessage _ (A_MSG body) -> do
logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret' srvMsgId
notify $ MSG msgMeta msgFlags body
@@ -3602,7 +3641,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
liftIO $ lockConnForUpdate db connId
rc <- ExceptT $ getRatchetForUpdate db connId -- ratchet state pre-decryption - required for processing EREADY
(agentMsgBody, pqEncryption) <- agentRatchetDecrypt' g db connId rc encAgentMessage
liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
liftEither (parse smpP (SEAgentError $ AGENT $ A_MESSAGE "parse msg body 2") agentMsgBody) >>= \case
agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
let msgType = agentMessageType agentMsg
internalHash = C.sha256Hash agentMsgBody
@@ -3688,8 +3727,8 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
decryptClientMessage :: C.DhSecretX25519 -> SMP.ClientMsgEnvelope -> AM (SMP.PrivHeader, AgentMsgEnvelope)
decryptClientMessage e2eDh SMP.ClientMsgEnvelope {cmNonce, cmEncBody} = do
clientMsg <- liftEither $ agentCbDecrypt e2eDh cmNonce cmEncBody
SMP.ClientMessage privHeader clientBody <- parseMessage clientMsg
agentEnvelope <- parseMessage clientBody
SMP.ClientMessage privHeader clientBody <- parseMessage "5" clientMsg
agentEnvelope <- parseMessage "6" clientBody
-- Version check is removed here, because when connecting via v1 contact address the agent still sends v2 message,
-- to allow duplexHandshake mode, in case the receiving agent was updated to v2 after the address was created.
-- aVRange <- asks $ smpAgentVRange . config
@@ -3698,8 +3737,8 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
-- else throwE $ AGENT A_VERSION
pure (privHeader, agentEnvelope)
parseMessage :: Encoding a => ByteString -> AM a
parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
parseMessage :: Encoding a => String -> ByteString -> AM a
parseMessage cxt = liftEither . parse smpP (AGENT $ A_MESSAGE $ "parse message " <> cxt)
-- checking agreed versions to continue connection in case of client/agent version downgrades
checkConfVersions :: VersionSMPA -> VersionSMPC -> AM ()
@@ -3716,6 +3755,18 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
checkConfVersions agentVersion phVer
let ConnData {pqSupport, serviceRequestExpiresAt} = toConnData conn'
case status of
New | isJust (dbReplaceQId rq) -> case conn' of
DuplexConnection cData' rqs sqs -> do
let dhSecret = C.dh' e2ePubKey e2ePrivKey
clientVersion = min agreedClientVerion phVer
withStore' c $ \db -> do
setRcvQueueConfirmedE2E db rq dhSecret clientVersion
setRcvQueuePrimary db connId rq
let rq' = (rq :: RcvQueue) {status = Confirmed, e2eDhSecret = Just dhSecret, smpClientVersion = clientVersion, primary = True, dbReplaceQueueId = Nothing}
conn'' = DuplexConnection cData' (updatedQs rq' rqs) sqs
cStats <- connectionStats c conn''
notify $ SWITCH QDRcv SPConfirmed cStats
_ -> prohibited "conf: rotation not in duplex connection"
New -> case conn' of
-- party initiating connection
RcvConnection {} -> do
@@ -3723,7 +3774,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
-- create ratchet from sent invitation and received confirmation keys
Just e2eSndParams -> do
keys <- withStore c (`getRatchetX3dhKeys` connId)
processConnInfo =<< initRcvRatchet_ agentVersion pqSupport keys e2eSndParams
processConnInfo =<< initRcvRatchet_ pqSupport keys e2eSndParams
-- use ratchet initialized from contact address ratchet keys during invitation
Nothing -> withStore' c (`getRatchet` connId) >>= \case
Left _ -> prohibited "conf: incorrect state"
@@ -3732,7 +3783,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
processConnInfo (rc, pqSupport') = do
(agentMsgBody_, rc') <- decryptConnInfo rc encConnInfo
case agentMsgBody_ of
Right agentMsgBody -> parseMessage agentMsgBody >>= \case
Right agentMsgBody -> parseMessage "1" agentMsgBody >>= \case
AgentConnInfoReply smpQueues connInfo | isNothing serviceRequestExpiresAt -> do
processConf rc' connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer}
withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody)
@@ -3773,7 +3824,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
DuplexConnection _ (rq'@RcvQueue {smpClientVersion = v'} :| _) _ | isNothing e2eEncryption -> do
g <- asks random
(agentMsgBody, pqEncryption) <- withStore c $ \db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo
parseMessage agentMsgBody >>= \case
parseMessage "2" agentMsgBody >>= \case
AgentConnInfo connInfo -> do
notify $ INFO pqSupport connInfo
let dhSecret = C.dh' e2ePubKey e2ePrivKey
@@ -3789,15 +3840,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
_ -> prohibited "conf: incorrect state"
_ -> prohibited "conf: status /= new"
initRcvRatchet_ :: VersionSMPA -> PQSupport -> CR.RcvE2EPrivRatchetParams 'C.X448 -> CR.SndE2ERatchetParams 'C.X448 -> AM (CR.RatchetX448, PQSupport)
initRcvRatchet_ agentVersion pqSupport pks@(_, pk2, _) (CR.AE2ERatchetParams _ e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _ _)) = do
initRcvRatchet_ :: PQSupport -> CR.RcvE2EPrivRatchetParams 'C.X448 -> CR.SndE2ERatchetParams 'C.X448 -> AM (CR.RatchetX448, PQSupport)
initRcvRatchet_ pqSupport pks@(_, pk2, _) (CR.AE2ERatchetParams _ e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _ _)) = do
e2eEncryptVRange <- asks $ e2eEncryptVRange . config
unless (e2eVersion `isCompatible` e2eEncryptVRange) $ throwE $ AGENT A_VERSION
rcParams <- liftError cryptoError $ CR.pqX3dhRcv pks e2eSndParams
let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange}
connPQSupport = pqSupport `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just e2eVersion)
rc = CR.initRcvRatchet rcVs pk2 rcParams connPQSupport
pure (rc, connPQSupport)
rc = CR.initRcvRatchet rcVs pk2 rcParams pqSupport
pure (rc, pqSupport)
decryptConnInfo :: CR.RatchetX448 -> ByteString -> AM (Either C.CryptoError ByteString, CR.RatchetX448)
decryptConnInfo rc encConnInfo = do
@@ -3868,7 +3918,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
-- processed by queue sender
qAddMsg :: SMP.MsgId -> NonEmpty (SMPQueueUri, Maybe SndQAddr) -> Connection 'CDuplex -> AM ()
qAddMsg _ ((_, Nothing) :| _) _ = qError "adding queue without switching is not supported"
qAddMsg srvMsgId ((qUri, Just addr) :| _) (DuplexConnection cData' rqs sqs) = do
qAddMsg srvMsgId ((qUri, Just addr) :| _) (DuplexConnection cData'@ConnData {connAgentVersion} rqs sqs) = do
when (ratchetSyncSendProhibited cData') $ throwE $ AGENT (A_QUEUE "ratchet is not synchronized")
clientVRange <- asks $ smpClientVRange . config
case qUri `compatibleVersion` clientVRange of
@@ -3885,9 +3935,17 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs
addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret' srvMsgId <> " " <> logSecret (senderId queueAddress)
let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', C.toPublic sndPrivateKey)]
sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just SSSendingQKEY
swchStatus <-
if connAgentVersion >= rpcAddressSMPAgentVersion
then do
withStore' c $ \db -> copyPendingSndDeliveries db sq sq2
enqueueCommand c "" connId (Just $ qServer sq2) $ AInternalCommand $ ICQSndSecure (snd $ qAddress sq2)
pure SSSecuringQueue
else do
let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}}
void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', C.toPublic sndPrivateKey)]
pure SSSendingQKEY
sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just swchStatus
let sqs'' = updatedQs sq1 sqs' <> [sq2]
conn' = DuplexConnection cData' rqs sqs''
cStats <- connectionStats c conn'
@@ -3941,6 +3999,23 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
_ -> qError "QUSE: switching SndQueue not found in connection"
_ -> qError "QUSE: switched queue address not found in connection"
-- processed by queue recipient
qEndMsg :: SMP.MsgId -> NonEmpty SndQAddr -> Connection 'CDuplex -> AM ()
qEndMsg srvMsgId addrs (DuplexConnection cData'@ConnData {enableNtfs} rqs sqs) =
case L.partition (\rq' -> any (`sameQAddress` sndAddress rq') addrs) rqs of
(removed@(_ : _), keptRq : keptRqs) -> do
logServer "<--" c srv rId $ "MSG <QEND>:" <> logSecret' srvMsgId
forM_ removed $ \rq'@RcvQueue {server = rmServer, rcvId} -> do
withStore' c $ \db -> setRcvQueueDeleted db rq'
enqueueCommand c "" connId (Just rmServer) $ AInternalCommand $ ICDeleteRcvQueue rcvId
when enableNtfs $ do
ns <- asks ntfSupervisor
liftIO $ sendNtfSubCommand ns (NSCCreate, [connId])
let conn' = DuplexConnection cData' (keptRq :| keptRqs) sqs
cStats <- connectionStats c conn'
notify $ SWITCH QDRcv SPCompleted cStats
_ -> pure ()
qError :: String -> AM a
qError = throwE . AGENT . A_QUEUE
@@ -3957,15 +4032,10 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
case conn' of
ContactConnection {} -> do
-- show connection request even if invitaion via contact address is not compatible.
-- in case invitation not compatible, assume there is no PQ encryption support.
pqSupport <- lift $ maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq
invId <- storeInvitation (CRInvitation connReq) cInfo False
let srvs = L.map qServer $ crSmpQueues crData
notify $ REQ invId pqSupport srvs cInfo False
notify $ REQ invId PQSupportOn srvs cInfo False
_ -> prohibited "inv: sent to message conn"
where
pqSupported (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible agentVersion) =
PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just v)
storeInvitation :: ContactRequest -> ConnInfo -> Bool -> AM InvitationId
storeInvitation connReq recipientConnInfo serviceRequest = do
@@ -3983,15 +4053,15 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
unlessM duplicateRequest $
withStore' c (\db -> getAddressRatchetKeys db connId ratchetKeyId) >>= \case
Right (pk1, pk2, pKem) -> do
(rc, connPQSupport) <- initRcvRatchet_ agentVersion pqSupport (pk1, pk2, pKem) e2eSndParams
(rc, connPQSupport) <- initRcvRatchet_ pqSupport (pk1, pk2, pKem) e2eSndParams
(agentMsgBody_, ratchetState) <- decryptConnInfo rc encConnInfo
case agentMsgBody_ of
Right agentMsgBody -> do
let mkDR replyQueue = DRInvitation {ratchetState, replyQueue, agentVersion, pqSupport = connPQSupport}
parseMessage agentMsgBody >>= \case
parseMessage "3" agentMsgBody >>= \case
AgentConnInfoReply (replyQueue :| _) cInfo -> do
invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) cInfo False
notify $ REQ invId pqSupported (qServer replyQueue :| []) cInfo True
notify $ REQ invId PQSupportOn (qServer replyQueue :| []) cInfo True
AgentServiceRequest (replyQueue :| _) sig_ payload ->
case verifyServiceReq rc payload sig_ of
Left err -> logError ("service request: " <> T.pack err) >> notify (ERR $ AGENT $ A_SERVICE ASEBadSignature)
@@ -4003,9 +4073,6 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
Left _ -> prohibited "addr inv: unknown ratchetKeyId"
_ -> prohibited "inv: sent to message conn"
where
pqSupported = case e2eSndParams of
CR.AE2ERatchetParams _ (CR.E2ERatchetParams e2eVersion _ _ _) ->
PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just e2eVersion)
duplicateRequest = case e2eSndParams of
CR.AE2ERatchetParams _ (CR.E2ERatchetParams _ k1 k2 _) -> do
let rkHash = C.sha256Hash $ C.pubKeyBytes k1 <> C.pubKeyBytes k2
@@ -4053,7 +4120,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
sendReplyKey = do
g <- asks random
(pks, e2eParams) <- liftIO $ CR.generateRcvE2EParams g e2eVersion pqSupport
enqueueRatchetKeyMsgs c sqs e2eParams
enqueueRatchetKeyMsgs c cData' sqs e2eParams
pure pks
notifyRatchetSyncError = do
let cData'' = cData' {ratchetSyncState = RSRequired} :: ConnData
@@ -4195,10 +4262,10 @@ storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq
liftIO $ createSndMsg db connId msgData
liftIO $ createSndMsgDelivery db sq internalId
enqueueRatchetKeyMsgs :: AgentClient -> NonEmpty SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> AM ()
enqueueRatchetKeyMsgs c (sq :| sqs) e2eEncryption = do
enqueueRatchetKeyMsgs :: AgentClient -> ConnData -> NonEmpty SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> AM ()
enqueueRatchetKeyMsgs c cData (sq :| sqs) e2eEncryption = do
msgId <- enqueueRatchetKey c sq e2eEncryption
mapM_ (lift . enqueueSavedMessage c msgId) $ filter isActiveSndQ sqs
mapM_ (lift . enqueueSavedMessage c msgId) $ filter (isActiveSndQ cData) sqs
enqueueRatchetKey :: AgentClient -> SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> AM AgentMsgId
enqueueRatchetKey c sq@SndQueue {connId} e2eEncryption = do
@@ -4223,16 +4290,16 @@ enqueueRatchetKey c sq@SndQueue {connId} e2eEncryption = do
pure internalId
-- encoded AgentMessage -> encoded EncAgentMessage
agentRatchetEncrypt :: DB.Connection -> ConnData -> ByteString -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (ByteString, PQEncryption)
agentRatchetEncrypt :: DB.Connection -> ConnData -> ByteString -> (PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (ByteString, PQEncryption)
agentRatchetEncrypt db cData msg getPaddedLen pqEnc_ currentE2EVersion = do
(mek, paddedLen, pqEnc) <- agentRatchetEncryptHeader db cData getPaddedLen pqEnc_ currentE2EVersion
encMsg <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncryptMsg mek paddedLen msg
pure (encMsg, pqEnc)
agentRatchetEncryptHeader :: DB.Connection -> ConnData -> (VersionSMPA -> PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (CR.MsgEncryptKeyX448, Int, PQEncryption)
agentRatchetEncryptHeader db ConnData {connId, connAgentVersion = v, pqSupport} getPaddedLen pqEnc_ currentE2EVersion = do
agentRatchetEncryptHeader :: DB.Connection -> ConnData -> (PQSupport -> Int) -> Maybe PQEncryption -> CR.VersionE2E -> ExceptT StoreError IO (CR.MsgEncryptKeyX448, Int, PQEncryption)
agentRatchetEncryptHeader db ConnData {connId, pqSupport} getPaddedLen pqEnc_ currentE2EVersion = do
rc <- ExceptT $ getRatchetForUpdate db connId
let paddedLen = getPaddedLen v pqSupport
let paddedLen = getPaddedLen pqSupport
(mek, rc') <- withExceptT (SEAgentError . cryptoError) $ CR.rcEncryptHeader rc pqEnc_ currentE2EVersion
liftIO $ updateRatchet db connId rc' CR.SMDNoChange
pure (mek, paddedLen, CR.rcSndKEM rc')
src/Simplex/Messaging/Agent/Client.hs
+2 -2
View File
@@ -1950,7 +1950,7 @@ getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
decryptSMPMessage :: RcvQueue -> SMP.RcvMessage -> AM SMP.ClientRcvMsgBody
decryptSMPMessage rq SMP.RcvMessage {msgId, msgBody = SMP.EncRcvMsgBody body} =
liftEither $ parse SMP.clientRcvMsgBodyP (AGENT A_MESSAGE) =<< decrypt body
liftEither $ parse SMP.clientRcvMsgBodyP (AGENT $ A_MESSAGE "decrypt message") =<< decrypt body
where
decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId)
@@ -2254,7 +2254,7 @@ agentCbDecrypt dhSecret nonce msg =
cryptoError :: C.CryptoError -> AgentErrorType
cryptoError = \case
C.CryptoLargeMsgError -> CMD LARGE "CryptoLargeMsgError"
C.CryptoHeaderError _ -> AGENT A_MESSAGE -- parsing error
C.CryptoHeaderError e -> AGENT $ A_MESSAGE $ "parse msg header " <> e
C.CERatchetDuplicateMessage -> AGENT $ A_DUPLICATE Nothing
C.AESDecryptError -> c DECRYPT_AES
C.CBDecryptError -> c DECRYPT_CB
src/Simplex/Messaging/Agent/Protocol.hs
+35 -30
View File
@@ -41,12 +41,8 @@ module Simplex.Messaging.Agent.Protocol
VersionSMPA,
VersionRangeSMPA,
pattern VersionSMPA,
duplexHandshakeSMPAgentVersion,
ratchetSyncSMPAgentVersion,
deliveryRcptsSMPAgentVersion,
pqdrSMPAgentVersion,
sndAuthKeySMPAgentVersion,
ratchetOnConfSMPAgentVersion,
rpcAddressSMPAgentVersion,
currentSMPAgentVersion,
supportedSMPAgentVRange,
e2eEncConnInfoLength,
@@ -304,6 +300,7 @@ import UnliftIO.Exception (Exception)
-- 5 - post-quantum double ratchet (3/14/2024)
-- 6 - secure reply queues with provided keys (6/14/2024)
-- 7 - initialize ratchet on processing confirmation (7/18/2024)
-- 8 - agent RPC and double ratchet PQ encryption from first message to contact address (8/01/2026)
data SMPAgentVersion
@@ -316,29 +313,20 @@ type VersionRangeSMPA = VersionRange SMPAgentVersion
pattern VersionSMPA :: Word16 -> VersionSMPA
pattern VersionSMPA v = Version v
duplexHandshakeSMPAgentVersion :: VersionSMPA
duplexHandshakeSMPAgentVersion = VersionSMPA 2
ratchetSyncSMPAgentVersion :: VersionSMPA
ratchetSyncSMPAgentVersion = VersionSMPA 3
deliveryRcptsSMPAgentVersion :: VersionSMPA
deliveryRcptsSMPAgentVersion = VersionSMPA 4
pqdrSMPAgentVersion :: VersionSMPA
pqdrSMPAgentVersion = VersionSMPA 5
sndAuthKeySMPAgentVersion :: VersionSMPA
sndAuthKeySMPAgentVersion = VersionSMPA 6
_sndAuthKeySMPAgentVersion :: VersionSMPA
_sndAuthKeySMPAgentVersion = VersionSMPA 6
ratchetOnConfSMPAgentVersion :: VersionSMPA
ratchetOnConfSMPAgentVersion = VersionSMPA 7
rpcAddressSMPAgentVersion :: VersionSMPA
rpcAddressSMPAgentVersion = VersionSMPA 8
minSupportedSMPAgentVersion :: VersionSMPA
minSupportedSMPAgentVersion = duplexHandshakeSMPAgentVersion
minSupportedSMPAgentVersion = _sndAuthKeySMPAgentVersion
currentSMPAgentVersion :: VersionSMPA
currentSMPAgentVersion = VersionSMPA 7
currentSMPAgentVersion = VersionSMPA 8
supportedSMPAgentVRange :: VersionRangeSMPA
supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPAgentVersion
@@ -346,17 +334,17 @@ supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPA
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
-- signing key of the sender for the server
e2eEncConnInfoLength :: VersionSMPA -> PQSupport -> Int
e2eEncConnInfoLength v = \case
e2eEncConnInfoLength :: PQSupport -> Int
e2eEncConnInfoLength = \case
-- reduced by 3726 (roughly the increase of message ratchet header size + key and ciphertext in reply link)
PQSupportOn | v >= pqdrSMPAgentVersion -> 11106
_ -> 14832
PQSupportOn -> 11106
PQSupportOff -> 14832
e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int
e2eEncAgentMsgLength v = \case
e2eEncAgentMsgLength :: PQSupport -> Int
e2eEncAgentMsgLength = \case
-- reduced by 2222 (the increase of message ratchet header size)
PQSupportOn | v >= pqdrSMPAgentVersion -> 13618
_ -> 15840
PQSupportOn -> 13618
PQSupportOff -> 15840
-- | SMP agent event
type ATransmission = (ACorrId, AEntityId, AEvt)
@@ -651,16 +639,22 @@ instance FromJSON RcvSwitchStatus where
data SndSwitchStatus
= SSSendingQKEY
| SSSendingQTEST
| SSSecuringQueue
| SSSendingQEND
deriving (Eq, Show)
instance StrEncoding SndSwitchStatus where
strEncode = \case
SSSendingQKEY -> "sending_qkey"
SSSendingQTEST -> "sending_qtest"
SSSecuringQueue -> "securing_queue"
SSSendingQEND -> "sending_qend"
strP =
A.takeTill (== ' ') >>= \case
"sending_qkey" -> pure SSSendingQKEY
"sending_qtest" -> pure SSSendingQTEST
"securing_queue" -> pure SSSecuringQueue
"sending_qend" -> pure SSSendingQEND
_ -> fail "bad SndSwitchStatus"
instance ToField SndSwitchStatus where toField = toField . decodeLatin1 . strEncode
@@ -972,6 +966,7 @@ data AgentMessageType
| AM_QKEY_
| AM_QUSE_
| AM_QTEST_
| AM_QEND_
| AM_EREADY_
| AM_SRV_REQ
| AM_SRV_RESP
@@ -991,6 +986,7 @@ instance Encoding AgentMessageType where
AM_QKEY_ -> "QK"
AM_QUSE_ -> "QU"
AM_QTEST_ -> "QT"
AM_QEND_ -> "QE"
AM_EREADY_ -> "E"
AM_SRV_REQ -> "A"
AM_SRV_RESP -> "P"
@@ -1010,6 +1006,7 @@ instance Encoding AgentMessageType where
'K' -> pure AM_QKEY_
'U' -> pure AM_QUSE_
'T' -> pure AM_QTEST_
'E' -> pure AM_QEND_
_ -> fail "bad AgentMessageType"
'E' -> pure AM_EREADY_
'A' -> pure AM_SRV_REQ
@@ -1049,6 +1046,7 @@ data AMsgType
| QKEY_
| QUSE_
| QTEST_
| QEND_
| EREADY_
deriving (Eq)
@@ -1062,6 +1060,7 @@ instance Encoding AMsgType where
QKEY_ -> "QK"
QUSE_ -> "QU"
QTEST_ -> "QT"
QEND_ -> "QE"
EREADY_ -> "E"
smpP =
A.anyChar >>= \case
@@ -1075,6 +1074,7 @@ instance Encoding AMsgType where
'K' -> pure QKEY_
'U' -> pure QUSE_
'T' -> pure QTEST_
'E' -> pure QEND_
_ -> fail "bad AMsgType"
'E' -> pure EREADY_
_ -> fail "bad AMsgType"
@@ -1099,6 +1099,8 @@ data AMessage
QUSE (NonEmpty (SndQAddr, Bool))
| -- sent by the sender to test new queues and to complete switching
QTEST (NonEmpty SndQAddr)
| -- sent by the sender to remove queues from the connection (fast rotation, v8)
QEND (NonEmpty SndQAddr)
| -- ratchet re-synchronization is complete, with last decrypted sender message id (recipient's `last_external_snd_msg_id`)
EREADY AgentMsgId
deriving (Show)
@@ -1117,6 +1119,7 @@ aMessageType = \case
QKEY _ -> AM_QKEY_
QUSE _ -> AM_QUSE_
QTEST _ -> AM_QTEST_
QEND _ -> AM_QEND_
EREADY _ -> AM_EREADY_
-- | this type is used to send as part of the protocol between different clients
@@ -1169,6 +1172,7 @@ instance Encoding AMessage where
QKEY qs -> smpEncode (QKEY_, qs)
QUSE qs -> smpEncode (QUSE_, qs)
QTEST qs -> smpEncode (QTEST_, qs)
QEND qs -> smpEncode (QEND_, qs)
EREADY lastDecryptedMsgId -> smpEncode (EREADY_, lastDecryptedMsgId)
smpP =
smpP
@@ -1181,6 +1185,7 @@ instance Encoding AMessage where
QKEY_ -> QKEY <$> smpP
QUSE_ -> QUSE <$> smpP
QTEST_ -> QTEST <$> smpP
QEND_ -> QEND <$> smpP
EREADY_ -> EREADY <$> smpP
instance ToField AMessage where toField = toField . Binary . smpEncode
@@ -2195,7 +2200,7 @@ data ConnectionErrorType
-- | Errors of another SMP agent.
data SMPAgentError
= -- | client or agent message that failed to parse
A_MESSAGE
A_MESSAGE {messageErr :: String}
| -- | prohibited SMP/agent message
A_PROHIBITED {prohibitedErr :: String}
| -- | incompatible version of SMP client, agent or encryption protocols
src/Simplex/Messaging/Agent/Store.hs
+13 -5
View File
@@ -207,12 +207,13 @@ rcvSMPQueueAddress :: RcvQueue -> SMPQueueAddress
rcvSMPQueueAddress RcvQueue {server, sndId, e2ePrivKey, queueMode} =
SMPQueueAddress server sndId (C.publicKey e2ePrivKey) queueMode
canAbortRcvSwitch :: RcvQueue -> Bool
canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus
canAbortRcvSwitch :: ConnData -> RcvQueue -> Bool
canAbortRcvSwitch ConnData {connAgentVersion} = maybe False canAbort . rcvSwchStatus
where
canAbort = \case
RSSwitchStarted -> True
RSSendingQADD -> True
-- at agent version 8 and above the peer always chooses fast rotation, so a sent QADD is committed
RSSendingQADD -> connAgentVersion < rpcAddressSMPAgentVersion
-- if switch is in RSSendingQUSE, a race condition with sender deleting the original queue is possible
RSSendingQUSE -> False
-- if switch is in RSReceivedMessage status, aborting switch (deleting new queue)
@@ -475,8 +476,8 @@ type NoticeId = Int64
-- this function should be mirrored in the clients
ratchetSyncAllowed :: ConnData -> Bool
ratchetSyncAllowed ConnData {ratchetSyncState, connAgentVersion} =
connAgentVersion >= ratchetSyncSMPAgentVersion && (ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState]))
ratchetSyncAllowed ConnData {ratchetSyncState} =
ratchetSyncState `elem` ([RSAllowed, RSRequired] :: [RatchetSyncState])
-- this function should be mirrored in the clients
ratchetSyncSendProhibited :: ConnData -> Bool
@@ -538,6 +539,7 @@ data InternalCommand
| ICDeleteConn
| ICDeleteRcvQueue SMP.RecipientId
| ICQSecure SMP.RecipientId SMP.SndPublicAuthKey
| ICQSndSecure SMP.SenderId
| ICQDelete SMP.RecipientId
| ICReplyDel
@@ -549,6 +551,7 @@ data InternalCommandTag
| ICDeleteConn_
| ICDeleteRcvQueue_
| ICQSecure_
| ICQSndSecure_
| ICQDelete_
| ICReplyDel_
deriving (Show)
@@ -562,6 +565,7 @@ instance StrEncoding InternalCommand where
ICDeleteConn -> strEncode ICDeleteConn_
ICDeleteRcvQueue rId -> strEncode (ICDeleteRcvQueue_, rId)
ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey)
ICQSndSecure sId -> strEncode (ICQSndSecure_, sId)
ICQDelete rId -> strEncode (ICQDelete_, rId)
ICReplyDel -> strEncode ICReplyDel_
strP =
@@ -573,6 +577,7 @@ instance StrEncoding InternalCommand where
ICDeleteConn_ -> pure ICDeleteConn
ICDeleteRcvQueue_ -> ICDeleteRcvQueue <$> _strP
ICQSecure_ -> ICQSecure <$> _strP <*> _strP
ICQSndSecure_ -> ICQSndSecure <$> _strP
ICQDelete_ -> ICQDelete <$> _strP
ICReplyDel_ -> pure ICReplyDel
@@ -585,6 +590,7 @@ instance StrEncoding InternalCommandTag where
ICDeleteConn_ -> "DELETE_CONN"
ICDeleteRcvQueue_ -> "DELETE_RCV_QUEUE"
ICQSecure_ -> "QSECURE"
ICQSndSecure_ -> "QSND_SECURE"
ICQDelete_ -> "QDELETE"
ICReplyDel_ -> "REPLY_DEL"
strP =
@@ -596,6 +602,7 @@ instance StrEncoding InternalCommandTag where
"DELETE_CONN" -> pure ICDeleteConn_
"DELETE_RCV_QUEUE" -> pure ICDeleteRcvQueue_
"QSECURE" -> pure ICQSecure_
"QSND_SECURE" -> pure ICQSndSecure_
"QDELETE" -> pure ICQDelete_
"REPLY_DEL" -> pure ICReplyDel_
_ -> fail "bad InternalCommandTag"
@@ -614,6 +621,7 @@ internalCmdTag = \case
ICDeleteConn -> ICDeleteConn_
ICDeleteRcvQueue {} -> ICDeleteRcvQueue_
ICQSecure {} -> ICQSecure_
ICQSndSecure {} -> ICQSndSecure_
ICQDelete _ -> ICQDelete_
ICReplyDel -> ICReplyDel_
src/Simplex/Messaging/Agent/Store/AgentStore.hs
+20
View File
@@ -131,6 +131,8 @@ module Simplex.Messaging.Agent.Store.AgentStore
createSndMsg,
updateSndMsgHash,
createSndMsgDelivery,
copyPendingSndDeliveries,
countSndQueueDeliveries,
getSndMsgViaRcpt,
updateSndMsgRcpt,
getPendingQueueMsg,
@@ -1041,6 +1043,24 @@ createSndMsgDelivery :: DB.Connection -> SndQueue -> InternalId -> IO ()
createSndMsgDelivery db SndQueue {connId, dbQueueId} msgId =
DB.execute db "INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id) VALUES (?, ?, ?)" (connId, dbQueueId, msgId)
-- copies every undelivered (failed = 0) delivery from one snd queue to another, for redundant delivery during fast rotation
copyPendingSndDeliveries :: DB.Connection -> SndQueue -> SndQueue -> IO ()
copyPendingSndDeliveries db SndQueue {connId, dbQueueId = fromQueueId} SndQueue {dbQueueId = toQueueId} =
DB.execute
db
[sql|
INSERT INTO snd_message_deliveries (conn_id, snd_queue_id, internal_id)
SELECT conn_id, ?, internal_id
FROM snd_message_deliveries
WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0
|]
(toQueueId, connId, fromQueueId)
countSndQueueDeliveries :: DB.Connection -> SndQueue -> IO Int
countSndQueueDeliveries db SndQueue {connId, dbQueueId} =
maybeFirstRow' 0 fromOnly $
DB.query db "SELECT count(1) FROM snd_message_deliveries WHERE conn_id = ? AND snd_queue_id = ? AND failed = 0" (connId, dbQueueId)
getSndMsgViaRcpt :: DB.Connection -> ConnId -> InternalSndId -> IO (Either StoreError SndMsg)
getSndMsgViaRcpt db connId sndMsgId =
firstRow toSndMsg (SEMsgNotFound "getSndMsgViaRcpt") $
src/Simplex/Messaging/Crypto/Ratchet.hs
+77 -119
View File
@@ -51,8 +51,6 @@ module Simplex.Messaging.Crypto.Ratchet
VersionRangeE2E,
pattern VersionE2E,
RatchetVersions (..),
kdfX3DHE2EEncryptVersion,
pqRatchetE2EEncryptVersion,
currentE2EEncryptVersion,
supportedE2EEncryptVRange,
generateRcvE2EParams,
@@ -87,8 +85,6 @@ module Simplex.Messaging.Crypto.Ratchet
RatchetKey (..),
fullHeaderLen,
applySMDiff,
encodeMsgHeader,
msgHeaderP,
)
where
@@ -102,7 +98,6 @@ import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Attoparsec.ByteString (Parser, peekWord8')
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
@@ -132,6 +127,7 @@ import UnliftIO.STM
-- e2e encryption headers version history:
-- 1 - binary protocol encoding (1/1/2022)
-- 2 - use KDF in x3dh (10/20/2022)
-- 3 - PQDR (3/14/2024)
data E2EVersion
@@ -144,17 +140,17 @@ type VersionRangeE2E = VersionRange E2EVersion
pattern VersionE2E :: Word16 -> VersionE2E
pattern VersionE2E v = Version v
kdfX3DHE2EEncryptVersion :: VersionE2E
kdfX3DHE2EEncryptVersion = VersionE2E 2
_pqRatchetE2EEncryptVersion :: VersionE2E
_pqRatchetE2EEncryptVersion = VersionE2E 3
pqRatchetE2EEncryptVersion :: VersionE2E
pqRatchetE2EEncryptVersion = VersionE2E 3
minSupportedE2EEncryptVersion :: VersionE2E
minSupportedE2EEncryptVersion = _pqRatchetE2EEncryptVersion
currentE2EEncryptVersion :: VersionE2E
currentE2EEncryptVersion = VersionE2E 3
supportedE2EEncryptVRange :: VersionRangeE2E
supportedE2EEncryptVRange = mkVersionRange kdfX3DHE2EEncryptVersion currentE2EEncryptVersion
supportedE2EEncryptVRange = mkVersionRange minSupportedE2EEncryptVersion currentE2EEncryptVersion
data RatchetKEMState
= RKSProposed -- only KEM encapsulation key
@@ -238,9 +234,7 @@ data AnyE2ERatchetParams
deriving instance Show AnyE2ERatchetParams
instance (RatchetKEMStateI s, AlgorithmI a) => Encoding (E2ERatchetParams s a) where
smpEncode (E2ERatchetParams v k1 k2 kem_)
| v >= pqRatchetE2EEncryptVersion = smpEncode (v, k1, k2, kem_)
| otherwise = smpEncode (v, k1, k2)
smpEncode (E2ERatchetParams v k1 k2 kem_) = smpEncode (v, k1, k2, kem_)
smpP = toParams <$?> smpP
where
toParams :: AE2ERatchetParams a -> Either String (E2ERatchetParams s a)
@@ -261,14 +255,9 @@ instance Encoding AnyE2ERatchetParams where
case testEquality a a' of
Nothing -> fail "bad e2e params: different key algorithms"
Just Refl ->
kemP v >>= \case
smpP >>= \case
Just (ARKP s kem) -> pure $ AnyE2ERatchetParams s a $ E2ERatchetParams v k1 k2 (Just kem)
Nothing -> pure $ AnyE2ERatchetParams SRKSProposed a $ E2ERatchetParams v k1 k2 Nothing
where
kemP :: VersionE2E -> Parser (Maybe ARKEMParams)
kemP v
| v >= pqRatchetE2EEncryptVersion = smpP
| otherwise = pure Nothing
instance VersionI E2EVersion (E2ERatchetParams s a) where
type VersionRangeT E2EVersion (E2ERatchetParams s a) = E2ERatchetParamsUri s a
@@ -307,11 +296,10 @@ instance (RatchetKEMStateI s, AlgorithmI a) => StrEncoding (E2ERatchetParamsUri
[("v", strEncode vs), ("x3dh", strEncodeList [key1, key2])]
<> maybe [] encodeKem kem_
where
encodeKem kem
| maxVersion vs < pqRatchetE2EEncryptVersion = []
| otherwise = case kem of
RKParamsProposed k -> [("kem_key", strEncode k)]
RKParamsAccepted ct k -> [("kem_ct", strEncode ct), ("kem_key", strEncode k)]
encodeKem :: RKEMParams s -> [(ByteString, ByteString)]
encodeKem kem = case kem of
RKParamsProposed k -> [("kem_key", strEncode k)]
RKParamsAccepted ct k -> [("kem_ct", strEncode ct), ("kem_key", strEncode k)]
strP = toE2ERatchetParamsUri <$?> strP
{-# INLINE strP #-}
@@ -328,25 +316,26 @@ instance StrEncoding AnyE2ERatchetParamsUri where
strEncode (AnyE2ERatchetParamsUri _ _ ps) = strEncode ps
strP = do
query <- strP
vr :: VersionRangeE2E <- queryParam "v" query
vr :: VersionRangeE2E <- adjustE2EVRange <$> queryParam "v" query
keys <- L.toList <$> queryParam "x3dh" query
case keys of
[APublicDhKey a k1, APublicDhKey a' k2] -> case testEquality a a' of
Nothing -> fail "bad e2e params: different key algorithms"
Just Refl ->
kemP vr query >>= \case
kemP query >>= \case
Just (ARKP s kem) -> pure $ AnyE2ERatchetParamsUri s a $ E2ERatchetParamsUri vr k1 k2 (Just kem)
Nothing -> pure $ AnyE2ERatchetParamsUri SRKSProposed a $ E2ERatchetParamsUri vr k1 k2 Nothing
_ -> fail "bad e2e params"
where
kemP vr query
| maxVersion vr >= pqRatchetE2EEncryptVersion =
queryParam_ "kem_key" query
$>>= \k -> Just . kemParams k <$> queryParam_ "kem_ct" query
| otherwise = pure Nothing
kemP query =
queryParam_ "kem_key" query
$>>= \k -> Just . kemParams k <$> queryParam_ "kem_ct" query
kemParams k = \case
Nothing -> ARKP SRKSProposed $ RKParamsProposed k
Just ct -> ARKP SRKSAccepted $ RKParamsAccepted ct k
adjustE2EVRange vr =
let v = max minSupportedE2EEncryptVersion $ minVersion vr
in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr)
instance (RatchetKEMStateI s, AlgorithmI a) => Encoding (E2ERatchetParamsUri s a) where
smpEncode (E2ERatchetParamsUri vr k1 k2 kem_) = smpEncode (vr, k1, k2, kem_)
@@ -432,16 +421,14 @@ generateE2EParams g v useKEM_ = do
where
kemParams :: IO (Maybe (RKEMParams s, PrivRKEMParams s))
kemParams = case useKEM_ of
Just useKem
| v >= pqRatchetE2EEncryptVersion ->
Just <$> do
ks@(k, _) <- sntrup761Keypair g
case useKem of
ProposeKEM -> pure (RKParamsProposed k, PrivateRKParamsProposed ks)
AcceptKEM k' -> do
(ct, shared) <- sntrup761Enc g k'
pure (RKParamsAccepted ct k, PrivateRKParamsAccepted ct shared ks)
_ -> pure Nothing
Just useKem -> Just <$> do
ks@(k, _) <- sntrup761Keypair g
case useKem of
ProposeKEM -> pure (RKParamsProposed k, PrivateRKParamsProposed ks)
AcceptKEM k' -> do
(ct, shared) <- sntrup761Enc g k'
pure (RKParamsAccepted ct k, PrivateRKParamsAccepted ct shared ks)
Nothing -> pure Nothing
-- used by party initiating connection, Bob in double-ratchet spec
generateRcvE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> PQSupport -> IO (RcvE2EPrivRatchetParams a, RcvE2ERatchetParams a)
@@ -474,30 +461,30 @@ data RatchetInitParams = RatchetInitParams
-- this is used by the peer joining the connection
pqX3dhSnd :: DhAlgorithm a => AE2EPrivRatchetParams a -> E2ERatchetParams 'RKSProposed a -> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
-- 3. replied 2. received
pqX3dhSnd (spk1, spk2, spKem_) (E2ERatchetParams v rk1 rk2 rKem_) = do
pqX3dhSnd (spk1, spk2, spKem_) (E2ERatchetParams _ rk1 rk2 rKem_) = do
(ks_, kem_) <- sndPq
let initParams = pqX3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2) kem_
pure (initParams, ks_)
where
sndPq :: Either CryptoError (Maybe KEMKeyPair, Maybe RatchetKEMAccepted)
sndPq = case spKem_ of
Just (APRKP _ ps) | v >= pqRatchetE2EEncryptVersion -> case (ps, rKem_) of
Just (APRKP _ ps) -> case (ps, rKem_) of
(PrivateRKParamsAccepted ct shared ks, Just (RKParamsProposed k)) -> Right (Just ks, Just $ RatchetKEMAccepted k shared ct)
(PrivateRKParamsProposed ks, _) -> Right (Just ks, Nothing) -- both parties can send "proposal" in case of ratchet renegotiation
_ -> Left CERatchetKEMState
_ -> Right (Nothing, Nothing)
Nothing -> Right (Nothing, Nothing)
-- this is used by the peer that created new connection, after receiving the reply
pqX3dhRcv :: forall s a. (RatchetKEMStateI s, DhAlgorithm a) => RcvE2EPrivRatchetParams a -> E2ERatchetParams s a -> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
-- 1. sent 4. received in reply
pqX3dhRcv (rpk1, rpk2, rpKem_) (E2ERatchetParams v sk1 sk2 sKem_) = do
pqX3dhRcv (rpk1, rpk2, rpKem_) (E2ERatchetParams _ sk1 sk2 sKem_) = do
kem_ <- rcvPq
let initParams = pqX3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2) (snd <$> kem_)
pure (initParams, fst <$> kem_)
where
rcvPq :: ExceptT CryptoError IO (Maybe (KEMKeyPair, RatchetKEMAccepted))
rcvPq = case sKem_ of
Just (RKParamsAccepted ct k') | v >= pqRatchetE2EEncryptVersion -> case rpKem_ of
Just (RKParamsAccepted ct k') -> case rpKem_ of
Just (PrivateRKParamsProposed ks@(_, pk)) -> do
shared <- liftIO $ sntrup761Dec ct pk
pure $ Just (ks, RatchetKEMAccepted k' shared ct)
@@ -721,31 +708,22 @@ data MsgHeader a = MsgHeader
-- to allow extension without increasing the size, the actual header length is:
-- 69 = 2 (original size) + 2 + 1+56 (Curve448) + 4 + 4
-- The exact size is 2288, added reserve
paddedHeaderLen :: VersionE2E -> PQSupport -> Int
paddedHeaderLen v = \case
PQSupportOn | v >= pqRatchetE2EEncryptVersion -> 2310
_ -> 88
paddedHeaderLen :: PQSupport -> Int
paddedHeaderLen = \case
PQSupportOn -> 2310
PQSupportOff -> 88
-- only used in tests to validate correct padding
-- (2 bytes - version size, 1 byte - header size)
fullHeaderLen :: VersionE2E -> PQSupport -> Int
fullHeaderLen v pq = 2 + 1 + paddedHeaderLen v pq + authTagSize + ivSize @AES256
fullHeaderLen :: PQSupport -> 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
encodeMsgHeader v MsgHeader {msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs}
| v >= pqRatchetE2EEncryptVersion = smpEncode (msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs)
| otherwise = smpEncode (msgMaxVersion, msgDHRs, msgPN, msgNs)
-- pass the current version, as MsgHeader only includes the max supported version that can be different from the current
msgHeaderP :: AlgorithmI a => VersionE2E -> Parser (MsgHeader a)
msgHeaderP v = do
msgMaxVersion <- smpP
msgDHRs <- smpP
msgKEM <- if v >= pqRatchetE2EEncryptVersion then smpP else pure Nothing
msgPN <- smpP
msgNs <- smpP
pure MsgHeader {msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs}
instance AlgorithmI a => Encoding (MsgHeader a) where
smpEncode MsgHeader {msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs} =
smpEncode (msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs)
smpP = do
(msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs) <- smpP
pure MsgHeader {msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs}
data EncMessageHeader = EncMessageHeader
{ ehVersion :: VersionE2E, -- this is current ratchet version
@@ -757,26 +735,11 @@ 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} =
smpEncode (ehVersion, ehIV, ehAuthTag) <> encodeLarge ehVersion ehBody
smpEncode (ehVersion, ehIV, ehAuthTag, Large ehBody)
smpP = do
(ehVersion, ehIV, ehAuthTag) <- smpP
ehBody <- largeP
(ehVersion, ehIV, ehAuthTag, Large ehBody) <- smpP
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
| v >= pqRatchetE2EEncryptVersion = 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,
@@ -784,15 +747,12 @@ data EncRatchetMessage = EncRatchetMessage
emBody :: ByteString
}
encodeEncRatchetMessage :: VersionE2E -> EncRatchetMessage -> ByteString
encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag} =
encodeLarge v emHeader <> smpEncode (emAuthTag, Tail emBody)
encRatchetMessageP :: Parser EncRatchetMessage
encRatchetMessageP = do
emHeader <- largeP
(emAuthTag, Tail emBody) <- smpP
pure EncRatchetMessage {emHeader, emBody, emAuthTag}
instance Encoding EncRatchetMessage where
smpEncode EncRatchetMessage {emHeader, emBody, emAuthTag} =
smpEncode (Large emHeader, emAuthTag, Tail emBody)
smpP = do
(Large emHeader, emAuthTag, Tail emBody) <- smpP
pure EncRatchetMessage {emHeader, emBody, emAuthTag}
newtype PQEncryption = PQEncryption {enablePQ :: Bool}
deriving (Eq, Show)
@@ -841,15 +801,15 @@ pqEncToSupport (PQEncryption pq) = PQSupport pq
pqSupportAnd :: PQSupport -> PQSupport -> PQSupport
pqSupportAnd (PQSupport s1) (PQSupport s2) = PQSupport $ s1 && s2
pqEnableSupport :: VersionE2E -> PQSupport -> PQEncryption -> PQSupport
pqEnableSupport v (PQSupport sup) (PQEncryption enc) = PQSupport $ sup || (v >= pqRatchetE2EEncryptVersion && enc)
pqEnableSupport :: PQSupport -> PQEncryption -> PQSupport
pqEnableSupport (PQSupport sup) (PQEncryption enc) = PQSupport $ sup || enc
replyKEM_ :: VersionE2E -> Maybe (RKEMParams 'RKSProposed) -> PQSupport -> Maybe AUseKEM
replyKEM_ v kem_ = \case
PQSupportOn | v >= pqRatchetE2EEncryptVersion -> Just $ case kem_ of
replyKEM_ :: Maybe (RKEMParams 'RKSProposed) -> PQSupport -> Maybe AUseKEM
replyKEM_ kem_ = \case
PQSupportOn -> Just $ case kem_ of
Just (RKParamsProposed k) -> AUseKEM SRKSAccepted $ AcceptKEM k
Nothing -> AUseKEM SRKSProposed ProposeKEM
_ -> Nothing
PQSupportOff -> Nothing
instance StrEncoding PQEncryption where
strEncode pqMode
@@ -898,9 +858,9 @@ connPQEncryption = \case
IKUsePQ -> PQSupportOn
IKLinkPQ pq -> pq -- default for creating connection is IKLinkPQ PQEncOn
joinContactInitialKeys :: Bool -> PQSupport -> InitialKeys
joinContactInitialKeys pqCompatible = \case
PQSupportOn | pqCompatible -> IKUsePQ
joinContactInitialKeys :: PQSupport -> InitialKeys
joinContactInitialKeys = \case
PQSupportOn -> IKUsePQ
pqEnc -> IKLinkPQ pqEnc
rcCheckCanPad :: Int -> ByteString -> ExceptT CryptoError IO ()
@@ -916,14 +876,14 @@ rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, r
-- 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' = pqEnableSupport v rcSupportKEM rcEnableKEM'
rcSupportKEM' = pqEnableSupport rcSupportKEM rcEnableKEM'
-- This sets max version to support PQ encryption.
-- Current version upgrade happens when peer decrypts the message.
-- TODO note that maxSupported will not downgrade here below current (v).
maxSupported' = max supportedE2EVersion $ if pqEnc_ == Just PQEncOn then pqRatchetE2EEncryptVersion else v
maxSupported' = max supportedE2EVersion $ if pqEnc_ == Just PQEncOn then minSupportedE2EEncryptVersion else v
rcVersion' = rcVersion {maxSupported = maxSupported'}
-- enc_header = HENCRYPT(state.HKs, header)
(ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen v rcSupportKEM') rcAD (msgHeader v maxSupported')
(ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV (paddedHeaderLen rcSupportKEM') rcAD (msgHeader maxSupported')
-- return enc_header
let emHeader = smpEncode EncMessageHeader {ehVersion = v, ehBody, ehAuthTag, ehIV}
msgEncryptKey =
@@ -951,9 +911,8 @@ rcEncryptHeader rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, r
-- pn = state.PN,
-- n = state.Ns
-- )
msgHeader v maxSupported' =
encodeMsgHeader
v
msgHeader maxSupported' =
smpEncode
MsgHeader
{ msgMaxVersion = maxSupported',
msgDHRs = publicKey rcDHRs,
@@ -976,11 +935,10 @@ data MsgEncryptKey a = MsgEncryptKey
deriving (Show)
rcEncryptMsg :: AlgorithmI a => MsgEncryptKey a -> Int -> ByteString -> ExceptT CryptoError IO ByteString
rcEncryptMsg MsgEncryptKey {msgKey = MessageKey mk iv, msgRcAD, msgEncHeader, msgRcVersion = v} paddedMsgLen msg = do
rcEncryptMsg MsgEncryptKey {msgKey = MessageKey mk iv, msgRcAD, msgEncHeader} paddedMsgLen msg = do
-- return ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
(emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (msgRcAD <> msgEncHeader) msg
let msg' = encodeEncRatchetMessage v EncRatchetMessage {emHeader = msgEncHeader, emBody, emAuthTag}
pure msg'
pure $ smpEncode EncRatchetMessage {emHeader = msgEncHeader, emBody, emAuthTag}
data SkippedMessage a
= SMMessage (DecryptResult a)
@@ -1004,7 +962,7 @@ rcDecrypt ::
ByteString ->
ExceptT CryptoError IO (DecryptResult a)
rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError encRatchetMessageP msg'
encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError smpP msg'
encHdr <- parseE CryptoHeaderError smpP emHeader
-- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD)
decryptSkipped encHdr encMsg >>= \case
@@ -1049,7 +1007,7 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
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, rcSupportKEM, rcVersion = rv} 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
@@ -1064,7 +1022,7 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
rc'
{ rcDHRs = rcDHRs',
rcKEM = rcKEM',
rcSupportKEM = pqEnableSupport (current rv) rcSupportKEM rcEnableKEM',
rcSupportKEM = pqEnableSupport rcSupportKEM rcEnableKEM',
rcEnableKEM = rcEnableKEM',
rcSndKEM = PQEncryption sndKEM,
rcRcvKEM = PQEncryption rcvKEM,
@@ -1078,17 +1036,17 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
rcNHKr = rcNHKr'
}
pqRatchetStep :: Ratchet a -> Maybe ARKEMParams -> ExceptT CryptoError IO (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
pqRatchetStep Ratchet {rcKEM, rcEnableKEM = PQEncryption pqEnc, rcVersion = rv} = \case
pqRatchetStep Ratchet {rcKEM, rcEnableKEM = PQEncryption pqEnc} = \case
-- received message does not have KEM in header,
-- but the user enabled KEM when sending previous message
Nothing -> case rcKEM of
Nothing | pqEnc && current rv >= pqRatchetE2EEncryptVersion -> do
Nothing | pqEnc -> do
rcPQRs <- liftIO $ sntrup761Keypair g
pure (Nothing, Nothing, Just RatchetKEM {rcPQRs, rcKEMs = Nothing})
_ -> pure (Nothing, Nothing, Nothing)
-- received message has KEM in header.
Just (ARKP _ ps)
| pqEnc && current rv >= pqRatchetE2EEncryptVersion -> do
| pqEnc -> do
-- state.PQRr = header.kem
(ss, rcPQRr) <- sharedSecret
-- state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret KEM #1
@@ -1156,9 +1114,9 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
e -> throwE e
-- header = HDECRYPT(state.NHKr, enc_header)
decryptNextHeader hdr = (AdvanceRatchet,) <$> decryptHeader (rcNHKr rc) hdr
decryptHeader k EncMessageHeader {ehVersion, ehBody, ehAuthTag, ehIV} = do
decryptHeader k EncMessageHeader {ehBody, ehAuthTag, ehIV} = do
header <- decryptAEAD k ehIV rcAD ehBody ehAuthTag `catchE` \_ -> throwE CERatchetHeader
parseE' CryptoHeaderError (msgHeaderP ehVersion) header
parseE' CryptoHeaderError smpP header
decryptMessage :: MessageKey -> EncRatchetMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)
decryptMessage (MessageKey mk iv) EncRatchetMessage {emHeader, emBody, emAuthTag} =
-- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))
src/Simplex/Messaging/Crypto/ShortLink.hs
+1 -1
View File
@@ -120,6 +120,6 @@ decryptLinkData linkKey k (encFD, encMD) = do
pure (sig, s)
decode :: Encoding a => ByteString -> Either AgentErrorType a
decode = msgErr . smpDecode
msgErr = first (const $ AGENT A_MESSAGE)
msgErr = first (const $ AGENT $ A_MESSAGE "parse link data")
linkErr :: String -> Either AgentErrorType ()
linkErr = Left . AGENT . A_LINK