dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-24 19:05:24 +00:00
Code Issues Packages Projects Releases Wiki Activity

agent: quantum-resistant double ratchet encryption (#939)

Browse Source 
* doc

* diff

* ratchet header

* types

* ratchet step with PQ KEM, message header with KEM

* comment

* update types, remove Eq instances, store KEM keys to database

* pqx3dh

* PQ double ratchet test

* pqdr tests pass

* fix most tests

* refactor

* allow KEM proposals from both sides

* test names

* agent API parameters to use PQ KEM

* initialize ratchet state for enabling KEM

* fix/test KEM state machine to support disabling/enabling via messages

* more tests

* diff

* diff2

* refactor

* refactor

* refactor

* refactor

* remove Maybe

* rename

* add PQ encryption status to CON, MID and MSG events and sendMessage API results

* different PQ parameter when creating connection

* rename/reorganize types for PQ encryption modes

* rename

* fix testWaitDeliveryTimeout

* rename

* rename2

* ghc8107

* rename

* increase timeouts for concurrent send/receive test

* enable all tests

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
2024-03-03 19:40:49 +00:00
committed by GitHub
parent 30fd4065d9
commit e06e22328f
31 changed files with 1776 additions and 689 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Messaging/Agent.hs
+177 -164
View File
@@ -218,20 +218,20 @@ deleteUser :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> m ()
deleteUser c = withAgentEnv c .: deleteUser' c
-- | Create SMP agent connection (NEW command) asynchronously, synchronous response is new connection id
createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> SubscriptionMode -> m ConnId
createConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .: newConnAsync c userId aCorrId enableNtfs
createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> m ConnId
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 -> SubscriptionMode -> m ConnId
joinConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:. joinConnAsync c userId aCorrId enableNtfs
joinConnectionAsync :: AgentErrorMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.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
allowConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> m ()
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 -> SubscriptionMode -> m ConnId
acceptContactAsync c aCorrId enableNtfs = withAgentEnv c .:. acceptContactAsync' c aCorrId enableNtfs
acceptContactAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId
acceptContactAsync c aCorrId enableNtfs = withAgentEnv c .:: acceptContactAsync' c aCorrId enableNtfs
-- | Acknowledge message (ACK command) asynchronously, no synchronous response
ackMessageAsync :: forall m. AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
@@ -250,20 +250,20 @@ deleteConnectionsAsync :: AgentErrorMonad m => AgentClient -> Bool -> [ConnId] -
deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync' c waitDelivery
-- | Create SMP agent connection (NEW command)
createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c)
createConnection c userId enableNtfs = withAgentEnv c .:. newConn c userId "" enableNtfs
createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c)
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 -> SubscriptionMode -> m ConnId
joinConnection c userId enableNtfs = withAgentEnv c .:. joinConn c userId "" enableNtfs
joinConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId
joinConnection c userId enableNtfs = withAgentEnv c .:: joinConn c userId "" enableNtfs
-- | Allow connection to continue after CONF notification (LET command)
allowConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
allowConnection c = withAgentEnv c .:. allowConnection' c
-- | Accept contact after REQ notification (ACPT command)
acceptContact :: AgentErrorMonad m => AgentClient -> Bool -> ConfirmationId -> ConnInfo -> SubscriptionMode -> m ConnId
acceptContact c enableNtfs = withAgentEnv c .:. acceptContact' c "" enableNtfs
acceptContact :: AgentErrorMonad m => AgentClient -> Bool -> ConfirmationId -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId
acceptContact c enableNtfs = withAgentEnv c .:: acceptContact' c "" enableNtfs
-- | Reject contact (RJCT command)
rejectContact :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> m ()
@@ -292,17 +292,17 @@ 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 -> MsgFlags -> MsgBody -> m AgentMsgId
sendMessage c = withAgentEnv c .:. sendMessage' c
sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> CR.PQEncryption -> MsgFlags -> MsgBody -> m (AgentMsgId, CR.PQEncryption)
sendMessage c = withAgentEnv c .:: sendMessage' c
type MsgReq = (ConnId, MsgFlags, MsgBody)
-- | Send multiple messages to different connections (SEND command)
sendMessages :: MonadUnliftIO m => AgentClient -> [MsgReq] -> m [Either AgentErrorType AgentMsgId]
sendMessages c = withAgentEnv c . sendMessages' c
sendMessages :: MonadUnliftIO m => AgentClient -> CR.PQEncryption -> [MsgReq] -> m [Either AgentErrorType (AgentMsgId, CR.PQEncryption)]
sendMessages c = withAgentEnv c .: sendMessages' c
sendMessagesB :: (MonadUnliftIO m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType AgentMsgId))
sendMessagesB c = withAgentEnv c . sendMessagesB' c
sendMessagesB :: (MonadUnliftIO m, Traversable t) => AgentClient -> CR.PQEncryption -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType (AgentMsgId, CR.PQEncryption)))
sendMessagesB c = withAgentEnv c .: sendMessagesB' c
ackMessage :: AgentErrorMonad m => AgentClient -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m ()
ackMessage c = withAgentEnv c .:. ackMessage' c
@@ -316,8 +316,8 @@ abortConnectionSwitch :: AgentErrorMonad m => AgentClient -> ConnId -> m Connect
abortConnectionSwitch c = withAgentEnv c . abortConnectionSwitch' c
-- | Re-synchronize connection ratchet keys
synchronizeRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m ConnectionStats
synchronizeRatchet c = withAgentEnv c .: synchronizeRatchet' c
synchronizeRatchet :: AgentErrorMonad m => AgentClient -> ConnId -> CR.PQEncryption -> Bool -> m ConnectionStats
synchronizeRatchet c = withAgentEnv c .:. synchronizeRatchet' c
-- | Suspend SMP agent connection (OFF command)
suspendConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
@@ -514,13 +514,13 @@ client c@AgentClient {rcvQ, subQ} = forever $ do
processCommand :: forall m. AgentMonad m => AgentClient -> (EntityId, APartyCmd 'Client) -> m (EntityId, APartyCmd 'Agent)
processCommand c (connId, APC e cmd) =
second (APC e) <$> case cmd of
NEW enableNtfs (ACM cMode) subMode -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing subMode
JOIN enableNtfs (ACR _ cReq) subMode connInfo -> (,OK) <$> joinConn c userId connId enableNtfs cReq connInfo subMode
NEW enableNtfs (ACM cMode) pqIK subMode -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing pqIK subMode
JOIN enableNtfs (ACR _ cReq) pqEnc subMode connInfo -> (,OK) <$> joinConn c userId connId enableNtfs cReq connInfo pqEnc subMode
LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK)
ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo SMSubscribe
ACPT invId pqEnc ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo pqEnc SMSubscribe
RJCT invId -> rejectContact' c connId invId $> (connId, OK)
SUB -> subscribeConnection' c connId $> (connId, OK)
SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody
SEND pqEnc msgFlags msgBody -> (connId,) . uncurry MID <$> sendMessage' c connId pqEnc msgFlags msgBody
ACK msgId rcptInfo_ -> ackMessage' c connId msgId rcptInfo_ $> (connId, OK)
SWCH -> switchConnection' c connId $> (connId, OK)
OFF -> suspendConnection' c connId $> (connId, OK)
@@ -549,32 +549,32 @@ deleteUser' c userId delSMPQueues = do
whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $
writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> SubscriptionMode -> m ConnId
newConnAsync c userId corrId enableNtfs cMode subMode = do
connId <- newConnNoQueues c userId "" enableNtfs cMode
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode) subMode
newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> m ConnId
newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
connId <- newConnNoQueues c userId "" enableNtfs cMode (CR.connPQEncryption pqInitKeys)
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 -> m ConnId
newConnNoQueues c userId connId enableNtfs cMode = do
newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> CR.PQEncryption -> m ConnId
newConnNoQueues c userId connId enableNtfs cMode pqEncryption = do
g <- asks random
connAgentVersion <- asks $ maxVersion . smpAgentVRange . config
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
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 -> SubscriptionMode -> m ConnId
joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo subMode = do
joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.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 $ smpAgentVRange . config
case crAgentVRange `compatibleVersion` aVRange of
Just (Compatible connAgentVersion) -> do
g <- asks random
let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqEncryption}
connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) subMode cInfo
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqEncryption subMode cInfo
pure connId
_ -> throwError $ AGENT A_VERSION
joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _subMode _cInfo =
joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _subMode _cInfo _pqEncryption =
throwError $ CMD PROHIBITED
allowConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> m ()
@@ -584,13 +584,13 @@ 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 -> SubscriptionMode -> m ConnId
acceptContactAsync' c corrId enableNtfs invId ownConnInfo subMode = do
acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> CR.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
SomeConn _ (ContactConnection ConnData {userId} _) -> do
withStore' c $ \db -> acceptInvitation db invId ownConnInfo
joinConnAsync c userId corrId enableNtfs connReq ownConnInfo subMode `catchAgentError` \err -> do
joinConnAsync c userId corrId enableNtfs connReq ownConnInfo pqEnc subMode `catchAgentError` \err -> do
withStore' c (`unacceptInvitation` invId)
throwError err
_ -> throwError $ CMD PROHIBITED
@@ -644,17 +644,20 @@ switchConnectionAsync' c corrId connId =
pure . connectionStats $ DuplexConnection cData rqs' sqs
_ -> throwError $ CMD PROHIBITED
newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c)
newConn c userId connId enableNtfs cMode clientData subMode =
getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData subMode
newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c)
newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode =
getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode
newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c)
newConnSrv c userId connId enableNtfs cMode clientData subMode srv = do
connId' <- newConnNoQueues c userId connId enableNtfs cMode
newRcvConnSrv c userId connId' enableNtfs cMode clientData subMode srv
newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c)
newConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv = do
connId' <- newConnNoQueues c userId connId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
newRcvConnSrv c userId connId' enableNtfs cMode clientData pqInitKeys subMode srv
newRcvConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c)
newRcvConnSrv c userId connId enableNtfs cMode clientData subMode srv = do
newRcvConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c)
newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv = do
case (cMode, pqInitKeys) of
(SCMContact, CR.IKUsePQ) -> throwError $ CMD PROHIBITED
_ -> pure ()
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
(rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange subMode `catchAgentError` \e -> liftIO (print e) >> throwError e
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
@@ -669,71 +672,73 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData subMode srv = do
SCMContact -> pure (connId, CRContactUri crData)
SCMInvitation -> do
g <- asks random
(pk1, pk2, e2eRcvParams) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange)
joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> m ConnId
joinConn c userId connId enableNtfs cReq cInfo subMode = do
joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.PQEncryption -> SubscriptionMode -> m ConnId
joinConn c userId connId enableNtfs cReq cInfo pqEnc subMode = do
srv <- case cReq of
CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ ->
getNextServer c userId [qServer q]
_ -> getSMPServer c userId
joinConnSrv c userId connId enableNtfs cReq cInfo subMode srv
joinConnSrv c userId connId enableNtfs cReq cInfo pqEnc subMode srv
startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> m (Compatible Version, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.E2ERatchetParams 'C.X448)
startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) = do
startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> CR.PQEncryption -> m (Compatible Version, 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
case ( qUri `compatibleVersion` smpClientVRange,
e2eRcvParamsUri `compatibleVersion` e2eEncryptVRange,
crAgentVRange `compatibleVersion` smpAgentVRange
) of
(Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams _ _ rcDHRr)), Just aVersion@(Compatible connAgentVersion)) -> do
(Just qInfo, Just (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), Just aVersion@(Compatible connAgentVersion)) -> do
g <- asks random
(pk1, pk2, e2eSndParams) <- atomically . CR.generateE2EParams g $ version e2eRcvParams
(pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ pqEncryption kem_)
(_, rcDHRs) <- atomically $ C.generateKeyPair g
let rc = CR.initSndRatchet e2eEncryptVRange rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
-- TODO PQ generate KEM keypair if needed - is it done?
rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams
let rc = CR.initSndRatchet e2eEncryptVRange rcDHRr rcDHRs rcParams
q <- newSndQueue userId "" qInfo
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk}
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqEncryption}
pure (aVersion, cData, q, rc, e2eSndParams)
_ -> throwError $ AGENT A_VERSION
joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> SMPServerWithAuth -> m ConnId
joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo subMode srv =
joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.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
(aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv pqEnc
g <- asks random
(connId', sq) <- withStore c $ \db -> runExceptT $ do
r@(connId', _) <- ExceptT $ createSndConn db g cData q
liftIO $ createRatchet db connId' rc
pure r
let cData' = (cData :: ConnData) {connId = connId'}
tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case
tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) (Just 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
void $ withStore' c $ \db -> deleteConn db Nothing connId'
throwError e
joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo subMode srv = do
joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo pqEnc subMode srv = do
aVRange <- asks $ smpAgentVRange . config
clientVRange <- asks $ smpClientVRange . config
case ( qUri `compatibleVersion` clientVRange,
crAgentVRange `compatibleVersion` aVRange
) of
(Just qInfo, Just vrsn) -> do
(connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing subMode srv
(connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.joinContactInitialKeys pqEnc) subMode srv
sendInvitation c userId qInfo vrsn cReq cInfo
pure connId'
_ -> throwError $ AGENT A_VERSION
joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> SMPServerWithAuth -> m ()
joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo subMode srv = do
(_aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv
joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> CR.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
liftIO $ createRatchet db connId rc
ExceptT $ updateNewConnSnd db connId q
confirmQueueAsync c cData q' srv cInfo (Just e2eSndParams) subMode
joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _srv = do
confirmQueueAsync c cData q' srv cInfo (Just e2eSndParams) pqEnc subMode
joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqEnc _srv = do
throwError $ CMD PROHIBITED
createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> m SMPQueueInfo
@@ -764,13 +769,13 @@ 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 -> SubscriptionMode -> m ConnId
acceptContact' c connId enableNtfs invId ownConnInfo subMode = withConnLock c connId "acceptContact" $ do
acceptContact' :: AgentMonad m => AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> CR.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
SomeConn _ (ContactConnection ConnData {userId} _) -> do
withStore' c $ \db -> acceptInvitation db invId ownConnInfo
joinConn c userId connId enableNtfs connReq ownConnInfo subMode `catchAgentError` \err -> do
joinConn c userId connId enableNtfs connReq ownConnInfo pqEnc subMode `catchAgentError` \err -> do
withStore' c (`unacceptInvitation` invId)
throwError err
_ -> throwError $ CMD PROHIBITED
@@ -905,18 +910,18 @@ 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 -> MsgFlags -> MsgBody -> m AgentMsgId
sendMessage' c connId msgFlags msg = liftEither . runIdentity =<< sendMessagesB' c (Identity (Right (connId, msgFlags, msg)))
sendMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> CR.PQEncryption -> MsgFlags -> MsgBody -> m (AgentMsgId, CR.PQEncryption)
sendMessage' c connId pqEnc msgFlags msg = liftEither . runIdentity =<< sendMessagesB' c pqEnc (Identity (Right (connId, msgFlags, msg)))
-- | Send multiple messages to different connections (SEND command) in Reader monad
sendMessages' :: forall m. AgentMonad' m => AgentClient -> [MsgReq] -> m [Either AgentErrorType AgentMsgId]
sendMessages' c = sendMessagesB' c . map Right
sendMessages' :: forall m. AgentMonad' m => AgentClient -> CR.PQEncryption -> [MsgReq] -> m [Either AgentErrorType (AgentMsgId, CR.PQEncryption)]
sendMessages' c pqEnc = sendMessagesB' c pqEnc . map Right
sendMessagesB' :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType AgentMsgId))
sendMessagesB' c reqs = withConnLocks c connIds "sendMessages" $ do
sendMessagesB' :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> CR.PQEncryption -> t (Either AgentErrorType MsgReq) -> m (t (Either AgentErrorType (AgentMsgId, CR.PQEncryption)))
sendMessagesB' c pqEnc 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'
enqueueMessagesB c reqs''
enqueueMessagesB c (Just pqEnc) reqs''
where
prepareConn :: (MsgReq, SomeConn) -> Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)
prepareConn ((_, msgFlags, msg), SomeConn _ conn) = case conn of
@@ -965,16 +970,16 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
processCmd :: RetryInterval -> PendingCommand -> m ()
processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} = case command of
AClientCommand (APC _ cmd) -> case cmd of
NEW enableNtfs (ACM cMode) subMode -> noServer $ do
NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
usedSrvs <- newTVarIO ([] :: [SMPServer])
tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do
(_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing subMode srv
(_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing pqEnc subMode srv
notify $ INV (ACR cMode cReq)
JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) subMode connInfo -> noServer $ do
JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do
let initUsed = [qServer q]
usedSrvs <- newTVarIO initUsed
tryCommand . withNextSrv c userId usedSrvs initUsed $ \srv -> do
joinConnSrvAsync c userId connId enableNtfs cReq connInfo subMode srv
joinConnSrvAsync c userId connId enableNtfs cReq connInfo pqEnc subMode srv
notify OK
LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK
ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK
@@ -999,7 +1004,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 SMP.MsgFlags {notification = True} HELLO
void $ enqueueMessage c cData sq Nothing 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
@@ -1014,7 +1019,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 SMP.noMsgFlags $ QUSE [((server, sndId), True)]
void . enqueueMessages c cData sqs Nothing 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
@@ -1077,39 +1082,39 @@ 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 -> MsgFlags -> AMessage -> m AgentMsgId
enqueueMessages c cData sqs msgFlags aMessage = do
enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> Maybe CR.PQEncryption -> MsgFlags -> AMessage -> m (AgentMsgId, CR.PQEncryption)
enqueueMessages c cData sqs pqEnc_ msgFlags aMessage = do
when (ratchetSyncSendProhibited cData) $ throwError $ INTERNAL "enqueueMessages: ratchet is not synchronized"
enqueueMessages' c cData sqs msgFlags aMessage
enqueueMessages' c cData sqs pqEnc_ msgFlags aMessage
enqueueMessages' :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
enqueueMessages' c cData sqs msgFlags aMessage =
liftEither . runIdentity =<< enqueueMessagesB c (Identity (Right (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 pqEnc_ (Identity (Right (cData, sqs, msgFlags, aMessage)))
enqueueMessagesB :: (AgentMonad' m, Traversable t) => AgentClient -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)) -> m (t (Either AgentErrorType AgentMsgId))
enqueueMessagesB c reqs = do
reqs' <- enqueueMessageB c reqs
enqueueMessagesB :: (AgentMonad' m, Traversable t) => AgentClient -> Maybe CR.PQEncryption -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)) -> m (t (Either AgentErrorType (AgentMsgId, CR.PQEncryption)))
enqueueMessagesB c pqEnc_ reqs = do
reqs' <- enqueueMessageB c pqEnc_ reqs
enqueueSavedMessageB c $ mapMaybe snd $ rights $ toList reqs'
pure $ fst <$$> reqs'
isActiveSndQ :: SndQueue -> Bool
isActiveSndQ SndQueue {status} = status == Secured || status == Active
enqueueMessage :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
enqueueMessage c cData sq msgFlags aMessage =
liftEither . fmap fst . runIdentity =<< enqueueMessageB c (Identity (Right (cData, [sq], msgFlags, aMessage)))
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 pqEnc_ (Identity (Right (cData, [sq], 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, MsgFlags, AMessage)) -> m (t (Either AgentErrorType (AgentMsgId, Maybe (ConnData, [SndQueue], AgentMsgId))))
enqueueMessageB c reqs = do
enqueueMessageB :: forall m t. (AgentMonad' m, Traversable t) => AgentClient -> Maybe CR.PQEncryption -> t (Either AgentErrorType (ConnData, NonEmpty SndQueue, MsgFlags, AMessage)) -> m (t (Either AgentErrorType ((AgentMsgId, CR.PQEncryption), Maybe (ConnData, [SndQueue], AgentMsgId))))
enqueueMessageB c pqEnc_ reqs = do
aVRange <- asks $ maxVersion . smpAgentVRange . config
reqMids <- withStoreBatch c $ \db -> fmap (bindRight $ storeSentMsg db aVRange) reqs
forME reqMids $ \((cData, sq :| sqs, _, _), InternalId msgId) -> do
forME reqMids $ \((cData, sq :| sqs, _, _), InternalId msgId, pqSecr) -> do
submitPendingMsg c cData sq
let sqs' = filter isActiveSndQ sqs
pure $ Right (msgId, if null sqs' then Nothing else Just (cData, sqs', msgId))
pure $ Right ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId))
where
storeSentMsg :: DB.Connection -> Version -> (ConnData, NonEmpty SndQueue, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, MsgFlags, AMessage), InternalId))
storeSentMsg :: DB.Connection -> Version -> (ConnData, NonEmpty SndQueue, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, MsgFlags, AMessage), InternalId, CR.PQEncryption))
storeSentMsg db agentVersion req@(ConnData {connId}, sq :| _, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
internalTs <- liftIO getCurrentTime
(internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
@@ -1117,13 +1122,13 @@ enqueueMessageB c reqs = do
agentMsg = AgentMessage privHeader aMessage
agentMsgStr = smpEncode agentMsg
internalHash = C.sha256Hash agentMsgStr
encAgentMessage <- agentRatchetEncrypt db connId agentMsgStr e2eEncUserMsgLength
(encAgentMessage, pqEncryption) <- agentRatchetEncrypt db connId agentMsgStr e2eEncUserMsgLength pqEnc_
let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage}
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, internalHash, prevMsgHash}
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, pqEncryption, internalHash, prevMsgHash}
liftIO $ createSndMsg db connId msgData
liftIO $ createSndMsgDelivery db connId sq internalId
pure (req, internalId)
pure (req, internalId, pqEncryption)
enqueueSavedMessage :: AgentMonad' m => AgentClient -> ConnData -> AgentMsgId -> SndQueue -> m ()
enqueueSavedMessage c cData msgId sq = enqueueSavedMessageB c $ Identity (cData, [sq], msgId)
@@ -1166,7 +1171,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork
atomically $ throwWhenNoDelivery c sq
atomically $ beginAgentOperation c AOSndNetwork
withWork c doWork (\db -> getPendingQueueMsg db connId sq) $
\(rq_, PendingMsgData {msgId, msgType, msgBody, msgFlags, msgRetryState, internalTs}) -> do
\(rq_, PendingMsgData {msgId, msgType, msgBody, pqEncryption, msgFlags, msgRetryState, internalTs}) -> do
atomically $ endAgentOperation c AOMsgDelivery -- this operation begins in submitPendingMsg
let mId = unId msgId
ri' = maybe id updateRetryInterval2 msgRetryState ri
@@ -1236,7 +1241,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork
-- it would lead to the non-deterministic internal ID of the first sent message, at to some other race conditions,
-- because it can be sent before HELLO is received
-- With `status == Active` condition, CON is sent here only by the accepting party, that previously received HELLO
when (status == Active) $ notify CON
when (status == Active) $ notify $ CON pqEncryption
-- this branch should never be reached as receive queue is created before the confirmation,
_ -> logError "HELLO sent without receive queue"
AM_A_MSG_ -> notify $ SENT mId
@@ -1335,7 +1340,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 SMP.MsgFlags {notification = False} rcpt
void $ enqueueMessages c cData sqs Nothing 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}) ->
@@ -1365,7 +1370,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 SMP.noMsgFlags $ QADD [(qUri, Just (server, sndId))]
void . enqueueMessages c cData sqs Nothing 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
@@ -1394,19 +1399,19 @@ abortConnectionSwitch' c connId =
_ -> throwError $ CMD PROHIBITED
_ -> throwError $ CMD PROHIBITED
synchronizeRatchet' :: AgentMonad m => AgentClient -> ConnId -> Bool -> m ConnectionStats
synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet" $ do
synchronizeRatchet' :: AgentMonad m => AgentClient -> ConnId -> CR.PQEncryption -> Bool -> m ConnectionStats
synchronizeRatchet' c connId pqEnc force = withConnLock c connId "synchronizeRatchet" $ do
withStore c (`getConn` connId) >>= \case
SomeConn _ (DuplexConnection cData rqs sqs)
| ratchetSyncAllowed cData || force -> do
-- check queues are not switching?
AgentConfig {e2eEncryptVRange} <- asks config
g <- asks random
(pk1, pk2, e2eParams) <- atomically . CR.generateE2EParams g $ maxVersion e2eEncryptVRange
(pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
enqueueRatchetKeyMsgs c cData sqs e2eParams
withStore' c $ \db -> do
setConnRatchetSync db connId RSStarted
setRatchetX3dhKeys db connId pk1 pk2
setRatchetX3dhKeys db connId pk1 pk2 pKem
let cData' = cData {ratchetSyncState = RSStarted} :: ConnData
conn' = DuplexConnection cData' rqs sqs
pure $ connectionStats conn'
@@ -1938,7 +1943,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 SMP.noMsgFlags $ QCONT (sndAddress rq)
DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs Nothing SMP.noMsgFlags $ QCONT (sndAddress rq)
_ -> pure ()
processClientMsg srvTs msgFlags msgBody = do
clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-
@@ -1981,7 +1986,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do
conn'' <- resetRatchetSync
case aMessage of
HELLO -> helloMsg srvMsgId conn'' >> ackDel msgId
HELLO -> helloMsg srvMsgId msgMeta conn'' >> ackDel msgId
-- note that there is no ACK sent for A_MSG, it is sent with agent's user ACK command
A_MSG body -> do
logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
@@ -2041,7 +2046,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
agentClientMsg :: TVar ChaChaDRG -> ByteString -> m (Maybe (InternalId, MsgMeta, AMessage, CR.RatchetX448))
agentClientMsg g encryptedMsgHash = withStore c $ \db -> runExceptT $ do
rc <- ExceptT $ getRatchet db connId -- ratchet state pre-decryption - required for processing EREADY
agentMsgBody <- agentRatchetDecrypt' g db connId rc encAgentMessage
(agentMsgBody, pqEncryption) <- agentRatchetDecrypt' g db connId rc encAgentMessage
liftEither (parse smpP (SEAgentError $ AGENT A_MESSAGE) agentMsgBody) >>= \case
agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
let msgType = agentMessageType agentMsg
@@ -2051,7 +2056,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash prevMsgHash
recipient = (unId internalId, internalTs)
broker = (srvMsgId, systemToUTCTime srvTs)
msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId, pqEncryption}
rcvMsg = RcvMsgData {msgMeta, msgType, msgFlags, msgBody = agentMsgBody, internalRcvId, internalHash, externalPrevSndHash = prevMsgHash, encryptedMsgHash}
liftIO $ createRcvMsg db connId rq rcvMsg
pure $ Just (internalId, msgMeta, aMessage, rc)
@@ -2121,7 +2126,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
parseMessage :: Encoding a => ByteString -> m a
parseMessage = liftEither . parse smpP (AGENT A_MESSAGE)
smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m ()
smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do
logServer "<--" c srv rId $ "MSG <CONF>:" <> logSecret srvMsgId
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
@@ -2131,10 +2136,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
case status of
New -> case (conn', e2eEncryption) of
-- party initiating connection
(RcvConnection {}, Just e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _)) -> do
(RcvConnection ConnData {pqEncryption} _, Just (CR.AE2ERatchetParams _ e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _ _))) -> do
unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
(pk1, rcDHRs) <- withStore c (`getRatchetX3dhKeys` connId)
let rc = CR.initRcvRatchet e2eEncryptVRange rcDHRs $ CR.x3dhRcv pk1 rcDHRs e2eSndParams
(pk1, rcDHRs, pKem) <- withStore c (`getRatchetX3dhKeys` connId)
rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 rcDHRs pKem e2eSndParams
let rc = CR.initRcvRatchet e2eEncryptVRange rcDHRs rcParams pqEncryption
g <- asks random
(agentMsgBody_, rc', skipped) <- liftError cryptoError $ CR.rcDecrypt g rc M.empty encConnInfo
case (agentMsgBody_, skipped) of
@@ -2155,7 +2161,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
-- party accepting connection
(DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do
g <- asks random
withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage >>= \case
withStore c (\db -> runExceptT $ agentRatchetDecrypt g db connId encConnInfo) >>= parseMessage . fst >>= \case
AgentConnInfo connInfo -> do
notify $ INFO connInfo
let dhSecret = C.dh' e2ePubKey e2ePrivKey
@@ -2165,8 +2171,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
_ -> prohibited
_ -> prohibited
helloMsg :: SMP.MsgId -> Connection c -> m ()
helloMsg srvMsgId conn' = do
helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> m ()
helloMsg srvMsgId MsgMeta {pqEncryption} conn' = do
logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret srvMsgId
case status of
Active -> prohibited
@@ -2176,14 +2182,16 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
-- `sndStatus == Active` when HELLO was previously sent, and this is the reply HELLO
-- this branch is executed by the accepting party in duplexHandshake mode (v2)
-- (was executed by initiating party in v1 that is no longer supported)
| sndStatus == Active -> notify CON
--
-- TODO PQ encryption mode
| sndStatus == Active -> notify $ CON pqEncryption
| otherwise -> enqueueDuplexHello sq
_ -> pure ()
where
enqueueDuplexHello :: SndQueue -> m ()
enqueueDuplexHello sq = do
let cData' = toConnData conn'
void $ enqueueMessage c cData' sq SMP.MsgFlags {notification = True} HELLO
void $ enqueueMessage c cData' sq Nothing SMP.MsgFlags {notification = True} HELLO
continueSending :: SMP.MsgId -> (SMPServer, SMP.SenderId) -> Connection 'CDuplex -> m ()
continueSending srvMsgId addr (DuplexConnection _ _ sqs) =
@@ -2240,7 +2248,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 SMP.noMsgFlags $ QKEY [(sqInfo', sndPubKey)]
void . enqueueMessages c cData' sqs Nothing 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''
@@ -2285,7 +2293,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''] SMP.noMsgFlags $ QTEST [addr]
void $ enqueueMessages c cData' [sq''] Nothing SMP.noMsgFlags $ QTEST [addr]
sq1' <- withStore' c $ \db -> setSndSwitchStatus db sq1 $ Just SSSendingQTEST
let sqs' = updatedQs sq1' sqs
conn' = DuplexConnection cData' rqs sqs'
@@ -2301,7 +2309,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 SMP.MsgFlags {notification = True} (EREADY lastExternalSndId)
enqueueMessages' c cData' sqs Nothing SMP.MsgFlags {notification = True} (EREADY lastExternalSndId)
smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do
@@ -2320,8 +2328,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
DuplexConnection {} -> action conn'
_ -> qError $ name <> ": message must be sent to duplex connection"
newRatchetKey :: CR.E2ERatchetParams 'C.X448 -> Connection 'CDuplex -> m ()
newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv) conn'@(DuplexConnection cData'@ConnData {lastExternalSndId} _ sqs) =
newRatchetKey :: CR.RcvE2ERatchetParams 'C.X448 -> Connection 'CDuplex -> m ()
newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv kem_) conn'@(DuplexConnection cData'@ConnData {lastExternalSndId} _ sqs) =
unlessM ratchetExists $ do
AgentConfig {e2eEncryptVRange} <- asks config
unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
@@ -2336,7 +2344,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
exists <- checkRatchetKeyHashExists db connId rkHashRcv
unless exists $ addProcessedRatchetKeyHash db connId rkHashRcv
pure exists
getSendRatchetKeys :: m (C.PrivateKeyX448, C.PrivateKeyX448)
getSendRatchetKeys :: m (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams)
getSendRatchetKeys = case rss of
RSOk -> sendReplyKey -- receiving client
RSAllowed -> sendReplyKey
@@ -2352,9 +2360,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
where
sendReplyKey = do
g <- asks random
(pk1, pk2, e2eParams) <- atomically . CR.generateE2EParams g $ version e2eOtherPartyParams
-- TODO PQ the decision to use KEM should depend on connection
(pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g e2eVersion CR.PQEncOn
enqueueRatchetKeyMsgs c cData' sqs e2eParams
pure (pk1, pk2)
pure (pk1, pk2, pKem)
notifyRatchetSyncError = do
let cData'' = cData' {ratchetSyncState = RSRequired} :: ConnData
conn'' = updateConnection cData'' conn'
@@ -2371,14 +2380,17 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
createRatchet db connId rc
-- compare public keys `k1` in AgentRatchetKey messages sent by self and other party
-- to determine ratchet initilization ordering
initRatchet :: VersionRange -> (C.PrivateKeyX448, C.PrivateKeyX448) -> m ()
initRatchet e2eEncryptVRange (pk1, pk2)
initRatchet :: VersionRange -> (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams) -> m ()
initRatchet e2eEncryptVRange (pk1, pk2, pKem)
| rkHash (C.publicKey pk1) (C.publicKey pk2) <= rkHashRcv = do
recreateRatchet $ CR.initRcvRatchet e2eEncryptVRange pk2 $ CR.x3dhRcv pk1 pk2 e2eOtherPartyParams
rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 pk2 pKem e2eOtherPartyParams
-- TODO PQ the decision to use KEM should either depend on the global setting or on whether it was enabled in connection before
recreateRatchet $ CR.initRcvRatchet e2eEncryptVRange pk2 rcParams $ CR.PQEncryption (isJust kem_)
| otherwise = do
(_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random
recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs $ CR.x3dhSnd pk1 pk2 e2eOtherPartyParams
void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 (CR.APRKP CR.SRKSProposed <$> pKem) e2eOtherPartyParams
recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs rcParams
void . enqueueMessages' c cData' sqs Nothing SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash
@@ -2412,15 +2424,15 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) =
Just qInfo' -> do
sq <- newSndQueue userId connId qInfo'
sq' <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
enqueueConfirmation c cData sq' ownConnInfo Nothing
enqueueConfirmation c cData sq' ownConnInfo Nothing Nothing
confirmQueueAsync :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> SubscriptionMode -> m ()
confirmQueueAsync c cData sq srv connInfo e2eEncryption_ subMode = do
storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation c cData sq srv connInfo subMode
confirmQueueAsync :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> CR.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
submitPendingMsg c cData sq
confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> SubscriptionMode -> m ()
confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption_ subMode = do
confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> Maybe CR.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
@@ -2428,7 +2440,7 @@ confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo
mkConfirmation :: AgentMessage -> m MsgBody
mkConfirmation aMessage = withStore c $ \db -> runExceptT $ do
void . liftIO $ updateSndIds db connId
encConnInfo <- agentRatchetEncrypt db connId (smpEncode aMessage) e2eEncConnInfoLength
(encConnInfo, _) <- agentRatchetEncrypt db connId (smpEncode aMessage) e2eEncConnInfoLength pqEnc_
pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo}
mkAgentConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> m AgentMessage
@@ -2436,30 +2448,30 @@ 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.E2ERatchetParams 'C.X448) -> m ()
enqueueConfirmation c cData sq connInfo e2eEncryption_ = do
storeConfirmation c cData sq e2eEncryption_ $ AgentConnInfo 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
submitPendingMsg c cData sq
storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.E2ERatchetParams 'C.X448) -> AgentMessage -> m ()
storeConfirmation c ConnData {connId, connAgentVersion} sq e2eEncryption_ agentMsg = withStore c $ \db -> runExceptT $ do
storeConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> Maybe CR.PQEncryption -> AgentMessage -> m ()
storeConfirmation c ConnData {connId, connAgentVersion} 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 <- agentRatchetEncrypt db connId agentMsgStr e2eEncConnInfoLength
(encConnInfo, pqEncryption) <- agentRatchetEncrypt db connId agentMsgStr e2eEncConnInfoLength pqEnc_
let msgBody = smpEncode $ AgentConfirmation {agentVersion = connAgentVersion, e2eEncryption_, encConnInfo}
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
liftIO $ createSndMsg db connId msgData
liftIO $ createSndMsgDelivery db connId sq internalId
enqueueRatchetKeyMsgs :: forall m. AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> CR.E2ERatchetParams 'C.X448 -> m ()
enqueueRatchetKeyMsgs :: forall m. AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> m ()
enqueueRatchetKeyMsgs c cData (sq :| sqs) e2eEncryption = do
msgId <- enqueueRatchetKey c cData sq e2eEncryption
mapM_ (enqueueSavedMessage c cData msgId) $ filter isActiveSndQ sqs
enqueueRatchetKey :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> CR.E2ERatchetParams 'C.X448 -> m AgentMsgId
enqueueRatchetKey :: forall m. AgentMonad m => AgentClient -> ConnData -> SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> m AgentMsgId
enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
aVRange <- asks $ smpAgentVRange . config
msgId <- storeRatchetKey $ maxVersion aVRange
@@ -2475,31 +2487,32 @@ enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
internalHash = C.sha256Hash agentMsgStr
let msgBody = smpEncode $ AgentRatchetKey {agentVersion, e2eEncryption, info = agentMsgStr}
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
-- TODO PQ set pqEncryption based on connection mode
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, pqEncryption = CR.PQEncOff, msgFlags = SMP.MsgFlags {notification = True}, internalHash, prevMsgHash}
liftIO $ createSndMsg db connId msgData
liftIO $ createSndMsgDelivery db connId sq internalId
pure internalId
-- encoded AgentMessage -> encoded EncAgentMessage
agentRatchetEncrypt :: DB.Connection -> ConnId -> ByteString -> Int -> ExceptT StoreError IO ByteString
agentRatchetEncrypt db connId msg paddedLen = do
agentRatchetEncrypt :: DB.Connection -> ConnId -> ByteString -> Int -> Maybe CR.PQEncryption -> ExceptT StoreError IO (ByteString, CR.PQEncryption)
agentRatchetEncrypt db connId msg paddedLen pqEnc_ = do
rc <- ExceptT $ getRatchet db connId
(encMsg, rc') <- liftE (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg
(encMsg, rc') <- liftE (SEAgentError . cryptoError) $ CR.rcEncrypt rc paddedLen msg pqEnc_
liftIO $ updateRatchet db connId rc' CR.SMDNoChange
pure encMsg
pure (encMsg, CR.rcSndKEM rc')
-- encoded EncAgentMessage -> encoded AgentMessage
agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO ByteString
agentRatchetDecrypt :: TVar ChaChaDRG -> DB.Connection -> ConnId -> ByteString -> ExceptT StoreError IO (ByteString, CR.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
agentRatchetDecrypt' :: TVar ChaChaDRG -> DB.Connection -> ConnId -> CR.RatchetX448 -> ByteString -> ExceptT StoreError IO (ByteString, CR.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
liftIO $ updateRatchet db connId rc' skippedDiff
liftEither $ first (SEAgentError . cryptoError) agentMsgBody_
liftEither $ bimap (SEAgentError . cryptoError) (,CR.rcRcvKEM rc') agentMsgBody_
newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m NewSndQueue
newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do
src/Simplex/Messaging/Agent/Protocol.hs
+48 -67
View File
@@ -166,7 +166,7 @@ import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -182,7 +182,7 @@ import Simplex.FileTransfer.Description
import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType)
import Simplex.Messaging.Agent.QueryString
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri)
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), pattern PQEncOff, RcvE2ERatchetParams, RcvE2ERatchetParamsUri, SndE2ERatchetParams)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
@@ -243,11 +243,15 @@ supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentS
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
-- signing key of the sender for the server
-- TODO PQ this should be version-dependent
-- previously it was 14848, reduced by 3700 (roughly the increase of message ratchet header size + key and ciphertext in reply link)
e2eEncConnInfoLength :: Int
e2eEncConnInfoLength = 14848
e2eEncConnInfoLength = 11148
-- TODO PQ this should be version-dependent
-- previously it was 15856, reduced by 2200 (roughly the increase of message ratchet header size)
e2eEncUserMsgLength :: Int
e2eEncUserMsgLength = 15856
e2eEncUserMsgLength = 13656
-- | Raw (unparsed) SMP agent protocol transmission.
type ARawTransmission = (ByteString, ByteString, ByteString)
@@ -273,8 +277,6 @@ data SAParty :: AParty -> Type where
deriving instance Show (SAParty p)
deriving instance Eq (SAParty p)
instance TestEquality SAParty where
testEquality SAgent SAgent = Just Refl
testEquality SClient SClient = Just Refl
@@ -297,8 +299,6 @@ data SAEntity :: AEntity -> Type where
deriving instance Show (SAEntity e)
deriving instance Eq (SAEntity e)
instance TestEquality SAEntity where
testEquality SAEConn SAEConn = Just Refl
testEquality SAERcvFile SAERcvFile = Just Refl
@@ -322,27 +322,22 @@ deriving instance Show ACmd
data APartyCmd p = forall e. AEntityI e => APC (SAEntity e) (ACommand p e)
instance Eq (APartyCmd p) where
APC e cmd == APC e' cmd' = case testEquality e e' of
Just Refl -> cmd == cmd'
Nothing -> False
deriving instance Show (APartyCmd p)
type ConnInfo = ByteString
-- | Parameterized type for SMP agent protocol commands and responses from all participants.
data ACommand (p :: AParty) (e :: AEntity) where
NEW :: Bool -> AConnectionMode -> SubscriptionMode -> ACommand Client AEConn -- response INV
NEW :: Bool -> AConnectionMode -> InitialKeys -> SubscriptionMode -> ACommand Client AEConn -- response INV
INV :: AConnectionRequestUri -> ACommand Agent AEConn
JOIN :: Bool -> AConnectionRequestUri -> SubscriptionMode -> ConnInfo -> ACommand Client AEConn -- response OK
JOIN :: Bool -> AConnectionRequestUri -> PQEncryption -> SubscriptionMode -> ConnInfo -> ACommand Client AEConn -- response OK
CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender
ACPT :: InvitationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
ACPT :: InvitationId -> PQEncryption -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client
RJCT :: InvitationId -> ACommand Client AEConn
INFO :: ConnInfo -> ACommand Agent AEConn
CON :: ACommand Agent AEConn -- notification that connection is established
CON :: PQEncryption -> ACommand Agent AEConn -- notification that connection is established
SUB :: ACommand Client AEConn
END :: ACommand Agent AEConn
CONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
@@ -351,8 +346,8 @@ data ACommand (p :: AParty) (e :: AEntity) where
UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> ACommand Agent AEConn
SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn
MID :: AgentMsgId -> ACommand Agent AEConn
SEND :: PQEncryption -> MsgFlags -> MsgBody -> ACommand Client AEConn
MID :: AgentMsgId -> PQEncryption -> ACommand Agent AEConn
SENT :: AgentMsgId -> ACommand Agent AEConn
MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> ACommand Agent AEConn
@@ -379,19 +374,12 @@ data ACommand (p :: AParty) (e :: AEntity) where
SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile
SFERR :: AgentErrorType -> ACommand Agent AESndFile
deriving instance Eq (ACommand p e)
deriving instance Show (ACommand p e)
data ACmdTag = forall p e. (APartyI p, AEntityI e) => ACmdTag (SAParty p) (SAEntity e) (ACommandTag p e)
data APartyCmdTag p = forall e. AEntityI e => APCT (SAEntity e) (ACommandTag p e)
instance Eq (APartyCmdTag p) where
APCT e cmd == APCT e' cmd' = case testEquality e e' of
Just Refl -> cmd == cmd'
Nothing -> False
deriving instance Show (APartyCmdTag p)
data ACommandTag (p :: AParty) (e :: AEntity) where
@@ -441,8 +429,6 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
SFDONE_ :: ACommandTag Agent AESndFile
SFERR_ :: ACommandTag Agent AESndFile
deriving instance Eq (ACommandTag p e)
deriving instance Show (ACommandTag p e)
aPartyCmdTag :: APartyCmd p -> APartyCmdTag p
@@ -458,8 +444,8 @@ aCommandTag = \case
REQ {} -> REQ_
ACPT {} -> ACPT_
RJCT _ -> RJCT_
INFO _ -> INFO_
CON -> CON_
INFO {} -> INFO_
CON _ -> CON_
SUB -> SUB_
END -> END_
CONNECT {} -> CONNECT_
@@ -469,7 +455,7 @@ aCommandTag = \case
SWITCH {} -> SWITCH_
RSYNC {} -> RSYNC_
SEND {} -> SEND_
MID _ -> MID_
MID {} -> MID_
SENT _ -> SENT_
MERR {} -> MERR_
MERRS {} -> MERRS_
@@ -726,8 +712,6 @@ data SConnectionMode (m :: ConnectionMode) where
SCMInvitation :: SConnectionMode CMInvitation
SCMContact :: SConnectionMode CMContact
deriving instance Eq (SConnectionMode m)
deriving instance Show (SConnectionMode m)
instance TestEquality SConnectionMode where
@@ -737,9 +721,6 @@ instance TestEquality SConnectionMode where
data AConnectionMode = forall m. ConnectionModeI m => ACM (SConnectionMode m)
instance Eq AConnectionMode where
ACM m == ACM m' = isJust $ testEquality m m'
cmInvitation :: AConnectionMode
cmInvitation = ACM SCMInvitation
@@ -769,17 +750,19 @@ data MsgMeta = MsgMeta
{ integrity :: MsgIntegrity,
recipient :: (AgentMsgId, UTCTime),
broker :: (MsgId, UTCTime),
sndMsgId :: AgentMsgId
sndMsgId :: AgentMsgId,
pqEncryption :: PQEncryption
}
deriving (Eq, Show)
instance StrEncoding MsgMeta where
strEncode MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
strEncode MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId, pqEncryption} =
B.unwords
[ strEncode integrity,
"R=" <> bshow rmId <> "," <> showTs rTs,
"B=" <> encode bmId <> "," <> showTs bTs,
"S=" <> bshow sndMsgId
"S=" <> bshow sndMsgId,
"PQ=" <> strEncode pqEncryption
]
where
showTs = B.pack . formatISO8601Millis
@@ -788,7 +771,8 @@ instance StrEncoding MsgMeta where
recipient <- " R=" *> partyMeta A.decimal
broker <- " B=" *> partyMeta base64P
sndMsgId <- " S=" *> A.decimal
pure MsgMeta {integrity, recipient, broker, sndMsgId}
pqEncryption <- " PQ=" *> strP
pure MsgMeta {integrity, recipient, broker, sndMsgId, pqEncryption}
where
partyMeta idParser = (,) <$> idParser <* A.char ',' <*> tsISO8601P
@@ -809,7 +793,7 @@ data SMPConfirmation = SMPConfirmation
data AgentMsgEnvelope
= AgentConfirmation
{ agentVersion :: Version,
e2eEncryption_ :: Maybe (E2ERatchetParams 'C.X448),
e2eEncryption_ :: Maybe (SndE2ERatchetParams 'C.X448),
encConnInfo :: ByteString
}
| AgentMsgEnvelope
@@ -823,7 +807,7 @@ data AgentMsgEnvelope
}
| AgentRatchetKey
{ agentVersion :: Version,
e2eEncryption :: E2ERatchetParams 'C.X448,
e2eEncryption :: RcvE2ERatchetParams 'C.X448,
info :: ByteString
}
deriving (Show)
@@ -1115,7 +1099,7 @@ instance forall m. ConnectionModeI m => StrEncoding (ConnectionRequestUri m) whe
CRInvitationUri crData e2eParams -> crEncode "invitation" crData (Just e2eParams)
CRContactUri crData -> crEncode "contact" crData Nothing
where
crEncode :: ByteString -> ConnReqUriData -> Maybe (E2ERatchetParamsUri 'C.X448) -> ByteString
crEncode :: ByteString -> ConnReqUriData -> Maybe (RcvE2ERatchetParamsUri 'C.X448) -> ByteString
crEncode crMode ConnReqUriData {crScheme, crAgentVRange, crSmpQueues, crClientData} e2eParams =
strEncode crScheme <> "/" <> crMode <> "#/?" <> queryStr
where
@@ -1324,22 +1308,15 @@ instance Encoding SMPQueueUri where
pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey}
data ConnectionRequestUri (m :: ConnectionMode) where
CRInvitationUri :: ConnReqUriData -> E2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
-- contact connection request does NOT contain E2E encryption parameters -
CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
-- contact connection request does NOT contain E2E encryption parameters for double ratchet -
-- they are passed in AgentInvitation message
CRContactUri :: ConnReqUriData -> ConnectionRequestUri CMContact
deriving instance Eq (ConnectionRequestUri m)
deriving instance Show (ConnectionRequestUri m)
data AConnectionRequestUri = forall m. ConnectionModeI m => ACR (SConnectionMode m) (ConnectionRequestUri m)
instance Eq AConnectionRequestUri where
ACR m cr == ACR m' cr' = case testEquality m m' of
Just Refl -> cr == cr'
_ -> False
deriving instance Show AConnectionRequestUri
data ConnReqUriData = ConnReqUriData
@@ -1713,13 +1690,13 @@ commandP binaryP =
>>= \case
ACmdTag SClient e cmd ->
ACmd SClient e <$> case cmd of
NEW_ -> s (NEW <$> strP_ <*> strP_ <*> (strP <|> pure SMP.SMSubscribe))
JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP)
NEW_ -> s (NEW <$> strP_ <*> strP_ <*> pqIKP <*> (strP <|> pure SMP.SMSubscribe))
JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> pqEncP <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP)
LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> binaryP)
ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> pqEncP <*> binaryP)
RJCT_ -> s (RJCT <$> A.takeByteString)
SUB_ -> pure SUB
SEND_ -> s (SEND <$> smpP <* A.space <*> binaryP)
SEND_ -> s (SEND <$> pqEncP <*> smpP <* A.space <*> binaryP)
ACK_ -> s (ACK <$> A.decimal <*> optional (A.space *> binaryP))
SWCH_ -> pure SWCH
OFF_ -> pure OFF
@@ -1731,7 +1708,7 @@ commandP binaryP =
CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> binaryP)
REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> binaryP)
INFO_ -> s (INFO <$> binaryP)
CON_ -> pure CON
CON_ -> s (CON <$> strP)
END_ -> pure END
CONNECT_ -> s (CONNECT <$> strP_ <*> strP)
DISCONNECT_ -> s (DISCONNECT <$> strP_ <*> strP)
@@ -1739,7 +1716,7 @@ commandP binaryP =
UP_ -> s (UP <$> strP_ <*> connections)
SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
RSYNC_ -> s (RSYNC <$> strP_ <*> strP <*> strP)
MID_ -> s (MID <$> A.decimal)
MID_ -> s (MID <$> A.decimal <*> _strP)
SENT_ -> s (SENT <$> A.decimal)
MERR_ -> s (MERR <$> A.decimal <* A.space <*> strP)
MERRS_ -> s (MERRS <$> strP_ <*> strP)
@@ -1762,6 +1739,10 @@ commandP binaryP =
where
s :: Parser a -> Parser a
s p = A.space *> p
pqIKP :: Parser InitialKeys
pqIKP = strP_ <|> pure (IKNoPQ PQEncOff)
pqEncP :: Parser PQEncryption
pqEncP = strP_ <|> pure PQEncOff
connections :: Parser [ConnId]
connections = strP `A.sepBy'` A.char ','
sfDone :: Text -> Either String (ACommand 'Agent 'AESndFile)
@@ -1777,13 +1758,13 @@ parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
-- | Serialize SMP agent command.
serializeCommand :: ACommand p e -> ByteString
serializeCommand = \case
NEW ntfs cMode subMode -> s (NEW_, ntfs, cMode, subMode)
NEW ntfs cMode pqIK subMode -> s (NEW_, ntfs, cMode, pqIK, subMode)
INV cReq -> s (INV_, cReq)
JOIN ntfs cReq subMode cInfo -> s (JOIN_, ntfs, cReq, subMode, Str $ serializeBinary cInfo)
JOIN ntfs cReq pqEnc subMode cInfo -> s (JOIN_, ntfs, cReq, pqEnc, subMode, Str $ serializeBinary cInfo)
CONF confId srvs cInfo -> B.unwords [s CONF_, confId, strEncodeList srvs, serializeBinary cInfo]
LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo]
REQ invId srvs cInfo -> B.unwords [s REQ_, invId, s srvs, serializeBinary cInfo]
ACPT invId cInfo -> B.unwords [s ACPT_, invId, serializeBinary cInfo]
ACPT invId pqEnc cInfo -> B.unwords [s ACPT_, invId, s pqEnc, serializeBinary cInfo]
RJCT invId -> B.unwords [s RJCT_, invId]
INFO cInfo -> B.unwords [s INFO_, serializeBinary cInfo]
SUB -> s SUB_
@@ -1794,8 +1775,8 @@ serializeCommand = \case
UP srv conns -> B.unwords [s UP_, s srv, connections conns]
SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats)
SEND msgFlags msgBody -> B.unwords [s SEND_, smpEncode msgFlags, serializeBinary msgBody]
MID mId -> s (MID_, mId)
SEND pqEnc msgFlags msgBody -> B.unwords [s SEND_, s pqEnc, smpEncode msgFlags, serializeBinary msgBody]
MID mId pqEnc -> s (MID_, mId, pqEnc)
SENT mId -> s (SENT_, mId)
MERR mId e -> s (MERR_, mId, e)
MERRS mIds e -> s (MERRS_, mIds, e)
@@ -1811,7 +1792,7 @@ serializeCommand = \case
DEL_USER userId -> s (DEL_USER_, userId)
CHK -> s CHK_
STAT srvs -> s (STAT_, srvs)
CON -> s CON_
CON pqEnc -> s (CON_, pqEnc)
ERR e -> s (ERR_, e)
OK -> s OK_
SUSPENDED -> s SUSPENDED_
@@ -1884,13 +1865,13 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
cmdWithMsgBody :: APartyCmd p -> m (Either AgentErrorType (APartyCmd p))
cmdWithMsgBody (APC e cmd) =
APC e <$$> case cmd of
SEND msgFlags body -> SEND msgFlags <$$> getBody body
SEND kem msgFlags body -> SEND kem msgFlags <$$> getBody body
MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body
JOIN ntfs qUri subMode cInfo -> JOIN ntfs qUri subMode <$$> getBody cInfo
JOIN ntfs qUri kem subMode cInfo -> JOIN ntfs qUri kem subMode <$$> getBody cInfo
CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo
LET confId cInfo -> LET confId <$$> getBody cInfo
REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo
ACPT invId cInfo -> ACPT invId <$$> getBody cInfo
ACPT invId kem cInfo -> ACPT invId kem <$$> getBody cInfo
INFO cInfo -> INFO <$$> getBody cInfo
_ -> pure $ Right cmd
src/Simplex/Messaging/Agent/Store.hs
+8 -16
View File
@@ -30,7 +30,7 @@ import Data.Type.Equality
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval (RI2State)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (RatchetX448)
import Simplex.Messaging.Crypto.Ratchet (RatchetX448, PQEncryption)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
( MsgBody,
@@ -61,8 +61,6 @@ data DBQueueId (q :: QueueStored) where
DBQueueId :: Int64 -> DBQueueId 'QSStored
DBNewQueue :: DBQueueId 'QSNew
deriving instance Eq (DBQueueId q)
deriving instance Show (DBQueueId q)
type RcvQueue = StoredRcvQueue 'QSStored
@@ -101,7 +99,7 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
clientNtfCreds :: Maybe ClientNtfCreds,
deleteErrors :: Int
}
deriving (Eq, Show)
deriving (Show)
rcvQueueInfo :: RcvQueue -> RcvQueueInfo
rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
@@ -128,7 +126,7 @@ data ClientNtfCreds = ClientNtfCreds
-- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient
rcvNtfDhSecret :: RcvNtfDhSecret
}
deriving (Eq, Show)
deriving (Show)
type SndQueue = StoredSndQueue 'QSStored
@@ -161,7 +159,7 @@ data StoredSndQueue (q :: QueueStored) = SndQueue
-- | SMP client version
smpClientVersion :: Version
}
deriving (Eq, Show)
deriving (Show)
sndQueueInfo :: SndQueue -> SndQueueInfo
sndQueueInfo SndQueue {server, sndSwchStatus} =
@@ -256,8 +254,6 @@ data Connection (d :: ConnType) where
DuplexConnection :: ConnData -> NonEmpty RcvQueue -> NonEmpty SndQueue -> Connection CDuplex
ContactConnection :: ConnData -> RcvQueue -> Connection CContact
deriving instance Eq (Connection d)
deriving instance Show (Connection d)
toConnData :: Connection d -> ConnData
@@ -290,8 +286,6 @@ connType SCSnd = CSnd
connType SCDuplex = CDuplex
connType SCContact = CContact
deriving instance Eq (SConnType d)
deriving instance Show (SConnType d)
instance TestEquality SConnType where
@@ -305,11 +299,6 @@ instance TestEquality SConnType where
-- Used to refer to an arbitrary connection when retrieving from store.
data SomeConn = forall d. SomeConn (SConnType d) (Connection d)
instance Eq SomeConn where
SomeConn d c == SomeConn d' c' = case testEquality d d' of
Just Refl -> c == c'
_ -> False
deriving instance Show SomeConn
data ConnData = ConnData
@@ -319,7 +308,8 @@ data ConnData = ConnData
enableNtfs :: Bool,
lastExternalSndId :: PrevExternalSndId,
deleted :: Bool,
ratchetSyncState :: RatchetSyncState
ratchetSyncState :: RatchetSyncState,
pqEncryption :: PQEncryption
}
deriving (Eq, Show)
@@ -534,6 +524,7 @@ data SndMsgData = SndMsgData
msgType :: AgentMessageType,
msgFlags :: MsgFlags,
msgBody :: MsgBody,
pqEncryption :: PQEncryption,
internalHash :: MsgHash,
prevMsgHash :: MsgHash
}
@@ -551,6 +542,7 @@ data PendingMsgData = PendingMsgData
msgType :: AgentMessageType,
msgFlags :: MsgFlags,
msgBody :: MsgBody,
pqEncryption :: PQEncryption,
msgRetryState :: Maybe RI2State,
internalTs :: InternalTs
}
src/Simplex/Messaging/Agent/Store/SQLite.hs
+48 -55
View File
@@ -269,6 +269,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
@@ -575,14 +576,14 @@ createSndConn db gVar cData q@SndQueue {server} =
insertSndQueue_ db connId q serverKeyHash_
createConnRecord :: DB.Connection -> ConnId -> ConnData -> SConnectionMode c -> IO ()
createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs} cMode =
createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqEncryption} cMode =
DB.execute
db
[sql|
INSERT INTO connections
(user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake) VALUES (?,?,?,?,?,?)
(user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_encryption, duplex_handshake) VALUES (?,?,?,?,?,?,?)
|]
(userId, connId, cMode, connAgentVersion, enableNtfs, True)
(userId, connId, cMode, connAgentVersion, enableNtfs, pqEncryption, True)
checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
@@ -1028,18 +1029,18 @@ getPendingQueueMsg db connId SndQueue {dbQueueId} =
DB.query
db
[sql|
SELECT m.msg_type, m.msg_flags, m.msg_body, m.internal_ts, s.retry_int_slow, s.retry_int_fast
SELECT m.msg_type, m.msg_flags, m.msg_body, m.pq_encryption, m.internal_ts, s.retry_int_slow, s.retry_int_fast
FROM messages m
JOIN snd_messages s ON s.conn_id = m.conn_id AND s.internal_id = m.internal_id
WHERE m.conn_id = ? AND m.internal_id = ?
|]
(connId, msgId)
err = SEInternal $ "msg delivery " <> bshow msgId <> " returned []"
pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData
pendingMsgData (msgType, msgFlags_, msgBody, internalTs, riSlow_, riFast_) =
pendingMsgData :: (AgentMessageType, Maybe MsgFlags, MsgBody, CR.PQEncryption, InternalTs, Maybe Int64, Maybe Int64) -> PendingMsgData
pendingMsgData (msgType, msgFlags_, msgBody, pqEncryption, internalTs, riSlow_, riFast_) =
let msgFlags = fromMaybe SMP.noMsgFlags msgFlags_
msgRetryState = RI2State <$> riSlow_ <*> riFast_
in PendingMsgData {msgId, msgType, msgFlags, msgBody, msgRetryState, internalTs}
in PendingMsgData {msgId, msgType, msgFlags, msgBody, pqEncryption, msgRetryState, internalTs}
markMsgFailed msgId = DB.execute db "UPDATE snd_message_deliveries SET failed = 1 WHERE conn_id = ? AND internal_id = ?" (connId, msgId)
getWorkItem :: Show i => ByteString -> IO (Maybe i) -> (i -> IO (Either StoreError a)) -> (i -> IO ()) -> IO (Either StoreError (Maybe a))
@@ -1108,7 +1109,7 @@ getRcvMsg db connId agentMsgId =
[sql|
SELECT
r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack
FROM rcv_messages r
JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id
LEFT JOIN snd_messages s ON s.conn_id = r.conn_id AND s.rcpt_internal_id = r.internal_id
@@ -1124,7 +1125,7 @@ getLastMsg db connId msgId =
[sql|
SELECT
r.internal_id, m.internal_ts, r.broker_id, r.broker_ts, r.external_snd_id, r.integrity, r.internal_hash,
m.msg_type, m.msg_body, s.internal_id, s.rcpt_status, r.user_ack
m.msg_type, m.msg_body, m.pq_encryption, s.internal_id, s.rcpt_status, r.user_ack
FROM rcv_messages r
JOIN messages m ON r.conn_id = m.conn_id AND r.internal_id = m.internal_id
JOIN connections c ON r.conn_id = c.conn_id AND c.last_internal_msg_id = r.internal_id
@@ -1133,9 +1134,9 @@ getLastMsg db connId msgId =
|]
(connId, msgId)
toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs, AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg
toRcvMsg (agentMsgId, internalTs, brokerId, brokerTs, sndMsgId, integrity, internalHash, msgType, msgBody, rcptInternalId_, rcptStatus_, userAck) =
let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity}
toRcvMsg :: (Int64, InternalTs, BrokerId, BrokerTs) :. (AgentMsgId, MsgIntegrity, MsgHash, AgentMessageType, MsgBody, CR.PQEncryption, Maybe AgentMsgId, Maybe MsgReceiptStatus, Bool) -> RcvMsg
toRcvMsg ((agentMsgId, internalTs, brokerId, brokerTs) :. (sndMsgId, integrity, internalHash, msgType, msgBody, pqEncryption, rcptInternalId_, rcptStatus_, userAck)) =
let msgMeta = MsgMeta {recipient = (agentMsgId, internalTs), broker = (brokerId, brokerTs), sndMsgId, integrity, pqEncryption}
msgReceipt = MsgReceipt <$> rcptInternalId_ <*> rcptStatus_
in RcvMsg {internalId = InternalId agentMsgId, msgMeta, msgType, msgBody, internalHash, msgReceipt, userAck}
@@ -1195,34 +1196,34 @@ deleteSndMsgsExpired db ttl = do
"DELETE FROM messages WHERE internal_ts < ? AND internal_snd_id IS NOT NULL"
(Only cutoffTs)
createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> IO ()
createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 =
DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2) VALUES (?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2)
createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO ()
createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
DB.execute db "INSERT INTO ratchets (conn_id, x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem) VALUES (?, ?, ?, ?)" (connId, x3dhPrivKey1, x3dhPrivKey2, pqPrivKem)
getRatchetX3dhKeys :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448))
getRatchetX3dhKeys :: DB.Connection -> ConnId -> IO (Either StoreError (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams))
getRatchetX3dhKeys db connId =
fmap hasKeys $
firstRow id SEX3dhKeysNotFound $
DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2 FROM ratchets WHERE conn_id = ?" (Only connId)
firstRow' keys SEX3dhKeysNotFound $
DB.query db "SELECT x3dh_priv_key_1, x3dh_priv_key_2, pq_priv_kem FROM ratchets WHERE conn_id = ?" (Only connId)
where
hasKeys = \case
Right (Just k1, Just k2) -> Right (k1, k2)
keys = \case
(Just k1, Just k2, pKem) -> Right (k1, k2, pKem)
_ -> Left SEX3dhKeysNotFound
-- used to remember new keys when starting ratchet re-synchronization
-- TODO remove the columns for public keys in v5.7.
-- Currently, the keys are not used but still stored to support app downgrade to the previous version.
setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> IO ()
setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 =
setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO ()
setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
DB.execute
db
[sql|
UPDATE ratchets
SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?
SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ?
WHERE conn_id = ?
|]
(x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, connId)
(x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId)
-- TODO remove the columns for public keys in v5.7.
createRatchet :: DB.Connection -> ConnId -> RatchetX448 -> IO ()
createRatchet db connId rc =
DB.executeNamed
@@ -1233,7 +1234,10 @@ createRatchet db connId rc =
ON CONFLICT (conn_id) DO UPDATE SET
ratchet_state = :ratchet_state,
x3dh_priv_key_1 = NULL,
x3dh_priv_key_2 = NULL
x3dh_priv_key_2 = NULL,
x3dh_pub_key_1 = NULL,
x3dh_pub_key_2 = NULL,
pq_priv_kem = NULL
|]
[":conn_id" := connId, ":ratchet_state" := rc]
@@ -1772,6 +1776,10 @@ instance ToField MsgReceiptStatus where toField = toField . decodeLatin1 . strEn
instance FromField MsgReceiptStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToField CR.PQEncryption where toField (CR.PQEncryption pqEnc) = toField pqEnc
instance FromField CR.PQEncryption where fromField f = CR.PQEncryption <$> fromField f
listToEither :: e -> [a] -> Either e a
listToEither _ (x : _) = Right x
listToEither e _ = Left e
@@ -1923,14 +1931,14 @@ getConnData db connId' =
[sql|
SELECT
user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs,
last_external_snd_msg_id, deleted, ratchet_sync_state
last_external_snd_msg_id, deleted, ratchet_sync_state, pq_encryption
FROM connections
WHERE conn_id = ?
|]
(Only connId')
where
cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, deleted, ratchetSyncState) =
(ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, lastExternalSndId, deleted, ratchetSyncState}, cMode)
cData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqEncryption) =
(ConnData {userId, connId, connAgentVersion, enableNtfs = fromMaybe True enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqEncryption}, cMode)
setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO ()
setConnDeleted db waitDelivery connId
@@ -2089,23 +2097,15 @@ updateLastIdsRcv_ dbConn connId newInternalId newInternalRcvId =
insertRcvMsgBase_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgType, msgFlags, msgBody, internalRcvId} = do
let MsgMeta {recipient = (internalId, internalTs)} = msgMeta
DB.executeNamed
let MsgMeta {recipient = (internalId, internalTs), pqEncryption} = msgMeta
DB.execute
dbConn
[sql|
INSERT INTO messages
( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body)
VALUES
(:conn_id,:internal_id,:internal_ts,:internal_rcv_id, NULL,:msg_type,:msg_flags,:msg_body);
(conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption)
VALUES (?,?,?,?,?,?,?,?,?);
|]
[ ":conn_id" := connId,
":internal_id" := internalId,
":internal_ts" := internalTs,
":internal_rcv_id" := internalRcvId,
":msg_type" := msgType,
":msg_flags" := msgFlags,
":msg_body" := msgBody
]
(connId, internalId, internalTs, internalRcvId, Nothing :: Maybe Int64, msgType, msgFlags, msgBody, pqEncryption)
insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvQueue -> RcvMsgData -> IO ()
insertRcvMsgDetails_ db connId RcvQueue {dbQueueId} RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash, encryptedMsgHash} = do
@@ -2186,23 +2186,16 @@ updateLastIdsSnd_ dbConn connId newInternalId newInternalSndId =
-- * createSndMsg helpers
insertSndMsgBase_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
insertSndMsgBase_ dbConn connId SndMsgData {..} = do
DB.executeNamed
dbConn
insertSndMsgBase_ db connId SndMsgData {internalId, internalTs, internalSndId, msgType, msgFlags, msgBody, pqEncryption} = do
DB.execute
db
[sql|
INSERT INTO messages
( conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body)
(conn_id, internal_id, internal_ts, internal_rcv_id, internal_snd_id, msg_type, msg_flags, msg_body, pq_encryption)
VALUES
(:conn_id,:internal_id,:internal_ts, NULL,:internal_snd_id,:msg_type,:msg_flags,:msg_body);
(?,?,?,?,?,?,?,?,?);
|]
[ ":conn_id" := connId,
":internal_id" := internalId,
":internal_ts" := internalTs,
":internal_snd_id" := internalSndId,
":msg_type" := msgType,
":msg_flags" := msgFlags,
":msg_body" := msgBody
]
(connId, internalId, internalTs, Nothing :: Maybe Int64, internalSndId, msgType, msgFlags, msgBody, pqEncryption)
insertSndMsgDetails_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
insertSndMsgDetails_ dbConn connId SndMsgData {..} =
src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+3 -1
View File
@@ -70,6 +70,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20231225_failed_work_ite
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_delivery_indexes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -108,7 +109,8 @@ schemaMigrations =
("m20231225_failed_work_items", m20231225_failed_work_items, Just down_m20231225_failed_work_items),
("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes),
("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect),
("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery)
("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery),
("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem)
]
-- | The list of migrations in ascending order by date
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240225_ratchet_kem.hs
+22
View File
@@ -0,0 +1,22 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20240225_ratchet_kem :: Query
m20240225_ratchet_kem =
[sql|
ALTER TABLE ratchets ADD COLUMN pq_priv_kem BLOB;
ALTER TABLE connections ADD COLUMN pq_encryption INTEGER NOT NULL DEFAULT 0;
ALTER TABLE messages ADD COLUMN pq_encryption INTEGER NOT NULL DEFAULT 0;
|]
down_m20240225_ratchet_kem :: Query
down_m20240225_ratchet_kem =
[sql|
ALTER TABLE ratchets DROP COLUMN pq_priv_kem;
ALTER TABLE connections DROP COLUMN pq_encryption;
ALTER TABLE messages DROP COLUMN pq_encryption;
|]
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+5 -2
View File
@@ -27,7 +27,8 @@ CREATE TABLE connections(
user_id INTEGER CHECK(user_id NOT NULL)
REFERENCES users ON DELETE CASCADE,
ratchet_sync_state TEXT NOT NULL DEFAULT 'ok',
deleted_at_wait_delivery TEXT
deleted_at_wait_delivery TEXT,
pq_encryption INTEGER NOT NULL DEFAULT 0
) WITHOUT ROWID;
CREATE TABLE rcv_queues(
host TEXT NOT NULL,
@@ -90,6 +91,7 @@ CREATE TABLE messages(
msg_type BLOB NOT NULL, --(H)ELLO,(R)EPLY,(D)ELETE. Should SMP confirmation be saved too?
msg_body BLOB NOT NULL DEFAULT x'',
msg_flags TEXT NULL,
pq_encryption INTEGER NOT NULL DEFAULT 0,
PRIMARY KEY(conn_id, internal_id),
FOREIGN KEY(conn_id, internal_rcv_id) REFERENCES rcv_messages
ON DELETE CASCADE DEFERRABLE INITIALLY DEFERRED,
@@ -160,7 +162,8 @@ CREATE TABLE ratchets(
e2e_version INTEGER NOT NULL DEFAULT 1
,
x3dh_pub_key_1 BLOB,
x3dh_pub_key_2 BLOB
x3dh_pub_key_2 BLOB,
pq_priv_kem BLOB
) WITHOUT ROWID;
CREATE TABLE skipped_messages(
skipped_message_id INTEGER PRIMARY KEY,
src/Simplex/Messaging/Crypto.hs
+3 -39
View File
@@ -101,6 +101,7 @@ module Simplex.Messaging.Crypto
verify,
verify',
validSignatureSize,
checkAlgorithm,
-- * crypto_box authenticator, as discussed in https://groups.google.com/g/sci.crypt/c/73yb5a9pz2Y/m/LNgRO7IYXOwJ
CbAuthenticator (..),
@@ -243,8 +244,6 @@ data SAlgorithm :: Algorithm -> Type where
SX25519 :: SAlgorithm X25519
SX448 :: SAlgorithm X448
deriving instance Eq (SAlgorithm a)
deriving instance Show (SAlgorithm a)
data Alg = forall a. AlgorithmI a => Alg (SAlgorithm a)
@@ -297,11 +296,6 @@ data APublicKey
AlgorithmI a =>
APublicKey (SAlgorithm a) (PublicKey a)
instance Eq APublicKey where
APublicKey a k == APublicKey a' k' = case testEquality a a' of
Just Refl -> k == k'
Nothing -> False
instance Encoding APublicKey where
smpEncode = smpEncode . encodePubKey
{-# INLINE smpEncode #-}
@@ -342,11 +336,6 @@ data APrivateKey
AlgorithmI a =>
APrivateKey (SAlgorithm a) (PrivateKey a)
instance Eq APrivateKey where
APrivateKey a k == APrivateKey a' k' = case testEquality a a' of
Just Refl -> k == k'
Nothing -> False
deriving instance Show APrivateKey
type PrivateKeyEd25519 = PrivateKey Ed25519
@@ -372,11 +361,6 @@ data APrivateSignKey
(AlgorithmI a, SignatureAlgorithm a) =>
APrivateSignKey (SAlgorithm a) (PrivateKey a)
instance Eq APrivateSignKey where
APrivateSignKey a k == APrivateSignKey a' k' = case testEquality a a' of
Just Refl -> k == k'
Nothing -> False
deriving instance Show APrivateSignKey
instance Encoding APrivateSignKey where
@@ -396,11 +380,6 @@ data APublicVerifyKey
(AlgorithmI a, SignatureAlgorithm a) =>
APublicVerifyKey (SAlgorithm a) (PublicKey a)
instance Eq APublicVerifyKey where
APublicVerifyKey a k == APublicVerifyKey a' k' = case testEquality a a' of
Just Refl -> k == k'
Nothing -> False
deriving instance Show APublicVerifyKey
data APrivateDhKey
@@ -408,11 +387,6 @@ data APrivateDhKey
(AlgorithmI a, DhAlgorithm a) =>
APrivateDhKey (SAlgorithm a) (PrivateKey a)
instance Eq APrivateDhKey where
APrivateDhKey a k == APrivateDhKey a' k' = case testEquality a a' of
Just Refl -> k == k'
Nothing -> False
deriving instance Show APrivateDhKey
data APublicDhKey
@@ -420,11 +394,6 @@ data APublicDhKey
(AlgorithmI a, DhAlgorithm a) =>
APublicDhKey (SAlgorithm a) (PublicKey a)
instance Eq APublicDhKey where
APublicDhKey a k == APublicDhKey a' k' = case testEquality a a' of
Just Refl -> k == k'
Nothing -> False
deriving instance Show APublicDhKey
data DhSecret (a :: Algorithm) where
@@ -787,8 +756,6 @@ data Signature (a :: Algorithm) where
SignatureEd25519 :: Ed25519.Signature -> Signature Ed25519
SignatureEd448 :: Ed448.Signature -> Signature Ed448
deriving instance Eq (Signature a)
deriving instance Show (Signature a)
data ASignature
@@ -796,11 +763,6 @@ data ASignature
(AlgorithmI a, SignatureAlgorithm a) =>
ASignature (SAlgorithm a) (Signature a)
instance Eq ASignature where
ASignature a s == ASignature a' s' = case testEquality a a' of
Just Refl -> s == s'
_ -> False
deriving instance Show ASignature
class CryptoSignature s where
@@ -885,6 +847,8 @@ data CryptoError
CryptoHeaderError String
| -- | no sending chain key in ratchet state
CERatchetState
| -- | no decapsulation key in ratchet state
CERatchetKEMState
| -- | header decryption error (could indicate that another key should be tried)
CERatchetHeader
| -- | too many skipped messages
src/Simplex/Messaging/Crypto/Ratchet.hs
+534 -88
View File
@@ -5,16 +5,23 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-- {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Simplex.Messaging.Crypto.Ratchet where
import Control.Applicative ((<|>))
import Control.Monad.Except
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Crypto.Cipher.AES (AES256)
import Crypto.Hash (SHA512)
@@ -23,22 +30,30 @@ 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)
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Composition ((.:), (.:.))
import Data.Functor (($>))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, isJust)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import Simplex.Messaging.Agent.QueryString
import Simplex.Messaging.Crypto
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON, parseE, parseE')
import Simplex.Messaging.Util ((<$?>), ($>>=))
import Simplex.Messaging.Version
import UnliftIO.STM
@@ -49,74 +64,319 @@ import UnliftIO.STM
kdfX3DHE2EEncryptVersion :: Version
kdfX3DHE2EEncryptVersion = 2
pqRatchetVersion :: Version
pqRatchetVersion = 3
currentE2EEncryptVersion :: Version
currentE2EEncryptVersion = 2
currentE2EEncryptVersion = 3
supportedE2EEncryptVRange :: VersionRange
supportedE2EEncryptVRange = mkVersionRange kdfX3DHE2EEncryptVersion currentE2EEncryptVersion
data E2ERatchetParams (a :: Algorithm)
= E2ERatchetParams Version (PublicKey a) (PublicKey a)
deriving (Eq, Show)
data RatchetKEMState
= RKSProposed -- only KEM encapsulation key
| RKSAccepted -- KEM ciphertext and the next encapsulation key
instance AlgorithmI a => Encoding (E2ERatchetParams a) where
smpEncode (E2ERatchetParams v k1 k2) = smpEncode (v, k1, k2)
smpP = E2ERatchetParams <$> smpP <*> smpP <*> smpP
data SRatchetKEMState (s :: RatchetKEMState) where
SRKSProposed :: SRatchetKEMState 'RKSProposed
SRKSAccepted :: SRatchetKEMState 'RKSAccepted
instance VersionI (E2ERatchetParams a) where
type VersionRangeT (E2ERatchetParams a) = E2ERatchetParamsUri a
version (E2ERatchetParams v _ _) = v
toVersionRangeT (E2ERatchetParams _ k1 k2) vr = E2ERatchetParamsUri vr k1 k2
deriving instance Show (SRatchetKEMState s)
instance VersionRangeI (E2ERatchetParamsUri a) where
type VersionT (E2ERatchetParamsUri a) = (E2ERatchetParams a)
versionRange (E2ERatchetParamsUri vr _ _) = vr
toVersionT (E2ERatchetParamsUri _ k1 k2) v = E2ERatchetParams v k1 k2
instance TestEquality SRatchetKEMState where
testEquality SRKSProposed SRKSProposed = Just Refl
testEquality SRKSAccepted SRKSAccepted = Just Refl
testEquality _ _ = Nothing
data E2ERatchetParamsUri (a :: Algorithm)
= E2ERatchetParamsUri VersionRange (PublicKey a) (PublicKey a)
deriving (Eq, Show)
class RatchetKEMStateI (s :: RatchetKEMState) where sRatchetKEMState :: SRatchetKEMState s
instance AlgorithmI a => StrEncoding (E2ERatchetParamsUri a) where
strEncode (E2ERatchetParamsUri vs key1 key2) =
strEncode $
QSP QNoEscaping [("v", strEncode vs), ("x3dh", strEncodeList [key1, key2])]
instance RatchetKEMStateI RKSProposed where sRatchetKEMState = SRKSProposed
instance RatchetKEMStateI RKSAccepted where sRatchetKEMState = SRKSAccepted
checkRatchetKEMState :: forall t s s' a. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' a -> Either String (t s a)
checkRatchetKEMState x = case testEquality (sRatchetKEMState @s) (sRatchetKEMState @s') of
Just Refl -> Right x
Nothing -> Left "bad ratchet KEM state"
checkRatchetKEMState' :: forall t s s'. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' -> Either String (t s)
checkRatchetKEMState' x = case testEquality (sRatchetKEMState @s) (sRatchetKEMState @s') of
Just Refl -> Right x
Nothing -> Left "bad ratchet KEM state"
data RKEMParams (s :: RatchetKEMState) where
RKParamsProposed :: KEMPublicKey -> RKEMParams 'RKSProposed
RKParamsAccepted :: KEMCiphertext -> KEMPublicKey -> RKEMParams 'RKSAccepted
deriving instance Show (RKEMParams s)
data ARKEMParams = forall s. RatchetKEMStateI s => ARKP (SRatchetKEMState s) (RKEMParams s)
deriving instance Show ARKEMParams
instance RatchetKEMStateI s => Encoding (RKEMParams s) where
smpEncode = \case
RKParamsProposed k -> smpEncode ('P', k)
RKParamsAccepted ct k -> smpEncode ('A', ct, k)
smpP = (\(ARKP _ ps) -> checkRatchetKEMState' ps) <$?> smpP
instance Encoding (ARKEMParams) where
smpEncode (ARKP _ ps) = smpEncode ps
smpP =
smpP >>= \case
'P' -> ARKP SRKSProposed . RKParamsProposed <$> smpP
'A' -> ARKP SRKSAccepted .: RKParamsAccepted <$> smpP <*> smpP
_ -> fail "bad ratchet KEM params"
data E2ERatchetParams (s :: RatchetKEMState) (a :: Algorithm)
= E2ERatchetParams Version (PublicKey a) (PublicKey a) (Maybe (RKEMParams s))
deriving (Show)
data AE2ERatchetParams (a :: Algorithm)
= forall s.
RatchetKEMStateI s =>
AE2ERatchetParams (SRatchetKEMState s) (E2ERatchetParams s a)
deriving instance Show (AE2ERatchetParams a)
data AnyE2ERatchetParams
= forall s a.
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
AnyE2ERatchetParams (SRatchetKEMState s) (SAlgorithm a) (E2ERatchetParams s a)
deriving instance Show AnyE2ERatchetParams
instance (RatchetKEMStateI s, AlgorithmI a) => Encoding (E2ERatchetParams s a) where
smpEncode (E2ERatchetParams v k1 k2 kem_)
| v >= pqRatchetVersion = smpEncode (v, k1, k2, kem_)
| otherwise = smpEncode (v, k1, k2)
smpP = toParams <$?> smpP
where
toParams :: AE2ERatchetParams a -> Either String (E2ERatchetParams s a)
toParams = \case
AE2ERatchetParams _ (E2ERatchetParams v k1 k2 Nothing) -> Right $ E2ERatchetParams v k1 k2 Nothing
AE2ERatchetParams _ ps -> checkRatchetKEMState ps
instance AlgorithmI a => Encoding (AE2ERatchetParams a) where
smpEncode (AE2ERatchetParams _ ps) = smpEncode ps
smpP = (\(AnyE2ERatchetParams s _ ps) -> (AE2ERatchetParams s) <$> checkAlgorithm ps) <$?> smpP
instance Encoding AnyE2ERatchetParams where
smpEncode (AnyE2ERatchetParams _ _ ps) = smpEncode ps
smpP = do
v :: Version <- smpP
APublicDhKey a k1 <- smpP
APublicDhKey a' k2 <- smpP
case testEquality a a' of
Nothing -> fail "bad e2e params: different key algorithms"
Just Refl ->
kemP v >>= \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 :: Version -> Parser (Maybe (ARKEMParams))
kemP v
| v >= pqRatchetVersion = smpP
| otherwise = pure Nothing
instance VersionI (E2ERatchetParams s a) where
type VersionRangeT (E2ERatchetParams s a) = E2ERatchetParamsUri s a
version (E2ERatchetParams v _ _ _) = v
toVersionRangeT (E2ERatchetParams _ k1 k2 kem_) vr = E2ERatchetParamsUri vr k1 k2 kem_
instance VersionRangeI (E2ERatchetParamsUri s a) where
type VersionT (E2ERatchetParamsUri s a) = (E2ERatchetParams s a)
versionRange (E2ERatchetParamsUri vr _ _ _) = vr
toVersionT (E2ERatchetParamsUri _ k1 k2 kem_) v = E2ERatchetParams v k1 k2 kem_
type RcvE2ERatchetParamsUri a = E2ERatchetParamsUri 'RKSProposed a
data E2ERatchetParamsUri (s :: RatchetKEMState) (a :: Algorithm)
= E2ERatchetParamsUri VersionRange (PublicKey a) (PublicKey a) (Maybe (RKEMParams s))
deriving (Show)
data AE2ERatchetParamsUri (a :: Algorithm)
= forall s.
RatchetKEMStateI s =>
AE2ERatchetParamsUri (SRatchetKEMState s) (E2ERatchetParamsUri s a)
deriving instance Show (AE2ERatchetParamsUri a)
data AnyE2ERatchetParamsUri
= forall s a.
(RatchetKEMStateI s, DhAlgorithm a, AlgorithmI a) =>
AnyE2ERatchetParamsUri (SRatchetKEMState s) (SAlgorithm a) (E2ERatchetParamsUri s a)
deriving instance Show AnyE2ERatchetParamsUri
instance (RatchetKEMStateI s, AlgorithmI a) => StrEncoding (E2ERatchetParamsUri s a) where
strEncode (E2ERatchetParamsUri vs key1 key2 kem_) =
strEncode . QSP QNoEscaping $
[("v", strEncode vs), ("x3dh", strEncodeList [key1, key2])]
<> maybe [] encodeKem kem_
where
encodeKem kem
| maxVersion vs < pqRatchetVersion = []
| otherwise = case kem of
RKParamsProposed k -> [("kem_key", strEncode k)]
RKParamsAccepted ct k -> [("kem_ct", strEncode ct), ("kem_key", strEncode k)]
strP = toParamsURI <$?> strP
where
toParamsURI = \case
AE2ERatchetParamsUri _ (E2ERatchetParamsUri vr k1 k2 Nothing) -> Right $ E2ERatchetParamsUri vr k1 k2 Nothing
AE2ERatchetParamsUri _ ps -> checkRatchetKEMState ps
instance AlgorithmI a => StrEncoding (AE2ERatchetParamsUri a) where
strEncode (AE2ERatchetParamsUri _ ps) = strEncode ps
strP = (\(AnyE2ERatchetParamsUri s _ ps) -> (AE2ERatchetParamsUri s) <$> checkAlgorithm ps) <$?> strP
instance StrEncoding AnyE2ERatchetParamsUri where
strEncode (AnyE2ERatchetParamsUri _ _ ps) = strEncode ps
strP = do
query <- strP
vs <- queryParam "v" query
vr :: VersionRange <- queryParam "v" query
keys <- L.toList <$> queryParam "x3dh" query
case keys of
[key1, key2] -> pure $ E2ERatchetParamsUri vs key1 key2
[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
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 >= pqRatchetVersion =
queryParam_ "kem_key" query
$>>= \k -> (Just . kemParams k <$> queryParam_ "kem_ct" query)
| otherwise = pure Nothing
kemParams k = \case
Nothing -> ARKP SRKSProposed $ RKParamsProposed k
Just ct -> ARKP SRKSAccepted $ RKParamsAccepted ct k
generateE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> Version -> STM (PrivateKey a, PrivateKey a, E2ERatchetParams a)
generateE2EParams g v = do
(k1, pk1) <- generateKeyPair g
(k2, pk2) <- generateKeyPair g
pure (pk1, pk2, E2ERatchetParams v k1 k2)
type RcvE2ERatchetParams a = E2ERatchetParams 'RKSProposed a
type SndE2ERatchetParams a = AE2ERatchetParams a
data PrivRKEMParams (s :: RatchetKEMState) where
PrivateRKParamsProposed :: KEMKeyPair -> PrivRKEMParams 'RKSProposed
PrivateRKParamsAccepted :: KEMCiphertext -> KEMSharedKey -> KEMKeyPair -> PrivRKEMParams 'RKSAccepted
data APrivRKEMParams = forall s. RatchetKEMStateI s => APRKP (SRatchetKEMState s) (PrivRKEMParams s)
type RcvPrivRKEMParams = PrivRKEMParams 'RKSProposed
instance RatchetKEMStateI s => Encoding (PrivRKEMParams s) where
smpEncode = \case
PrivateRKParamsProposed k -> smpEncode ('P', k)
PrivateRKParamsAccepted ct shared k -> smpEncode ('A', ct, shared, k)
smpP = (\(APRKP _ ps) -> checkRatchetKEMState' ps) <$?> smpP
instance Encoding (APrivRKEMParams) where
smpEncode (APRKP _ ps) = smpEncode ps
smpP =
smpP >>= \case
'P' -> APRKP SRKSProposed . PrivateRKParamsProposed <$> smpP
'A' -> APRKP SRKSAccepted .:. PrivateRKParamsAccepted <$> smpP <*> smpP <*> smpP
_ -> fail "bad APrivRKEMParams"
instance RatchetKEMStateI s => ToField (PrivRKEMParams s) where toField = toField . smpEncode
instance (Typeable s, RatchetKEMStateI s) => FromField (PrivRKEMParams s) where fromField = blobFieldDecoder smpDecode
data UseKEM (s :: RatchetKEMState) where
ProposeKEM :: UseKEM 'RKSProposed
AcceptKEM :: KEMPublicKey -> UseKEM 'RKSAccepted
data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s)
generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> Version -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a)
generateE2EParams g v useKEM_ = do
(k1, pk1) <- atomically $ generateKeyPair g
(k2, pk2) <- atomically $ generateKeyPair g
kems <- kemParams
pure (pk1, pk2, snd <$> kems, E2ERatchetParams v k1 k2 (fst <$> kems))
where
kemParams :: IO (Maybe (RKEMParams s, PrivRKEMParams s))
kemParams = case useKEM_ of
Just useKem | v >= pqRatchetVersion -> 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
-- used by party initiating connection, Bob in double-ratchet spec
generateRcvE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> Version -> PQEncryption -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed), E2ERatchetParams 'RKSProposed a)
generateRcvE2EParams g v = generateE2EParams g v . proposeKEM_
where
proposeKEM_ :: PQEncryption -> Maybe (UseKEM 'RKSProposed)
proposeKEM_ = \case
PQEncOn -> Just ProposeKEM
PQEncOff -> Nothing
-- used by party accepting connection, Alice in double-ratchet spec
generateSndE2EParams :: forall a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> Version -> Maybe AUseKEM -> IO (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams, AE2ERatchetParams a)
generateSndE2EParams g v = \case
Nothing -> do
(pk1, pk2, _, e2eParams) <- generateE2EParams g v Nothing
pure (pk1, pk2, Nothing, AE2ERatchetParams SRKSProposed e2eParams)
Just (AUseKEM s useKEM) -> do
(pk1, pk2, pKem, e2eParams) <- generateE2EParams g v (Just useKEM)
pure (pk1, pk2, APRKP s <$> pKem, AE2ERatchetParams s e2eParams)
data RatchetInitParams = RatchetInitParams
{ assocData :: Str,
ratchetKey :: RatchetKey,
sndHK :: HeaderKey,
rcvNextHK :: HeaderKey
rcvNextHK :: HeaderKey,
kemAccepted :: Maybe RatchetKEMAccepted
}
deriving (Eq, Show)
deriving (Show)
x3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
x3dhSnd spk1 spk2 (E2ERatchetParams _ rk1 rk2) =
x3dh (publicKey spk1, rk1) (dh' rk1 spk2) (dh' rk2 spk1) (dh' rk2 spk2)
-- this is used by the peer joining the connection
pqX3dhSnd :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> Maybe APrivRKEMParams -> E2ERatchetParams 'RKSProposed a -> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
-- 3. replied 2. received
pqX3dhSnd spk1 spk2 spKem_ (E2ERatchetParams v 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 >= pqRatchetVersion -> 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)
x3dhRcv :: DhAlgorithm a => PrivateKey a -> PrivateKey a -> E2ERatchetParams a -> RatchetInitParams
x3dhRcv rpk1 rpk2 (E2ERatchetParams _ sk1 sk2) =
x3dh (sk1, publicKey rpk1) (dh' sk2 rpk1) (dh' sk1 rpk2) (dh' sk2 rpk2)
-- this is used by the peer that created new connection, after receiving the reply
pqX3dhRcv :: forall s a. (RatchetKEMStateI s, DhAlgorithm a) => PrivateKey a -> PrivateKey a -> Maybe (PrivRKEMParams 'RKSProposed) -> 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
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 >= pqRatchetVersion -> case rpKem_ of
Just (PrivateRKParamsProposed ks@(_, pk)) -> do
shared <- liftIO $ sntrup761Dec ct pk
pure $ Just (ks, RatchetKEMAccepted k' shared ct)
Nothing -> throwError CERatchetKEMState
_ -> pure Nothing -- both parties can send "proposal" in case of ratchet renegotiation
x3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> RatchetInitParams
x3dh (sk1, rk1) dh1 dh2 dh3 =
RatchetInitParams {assocData, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk}
pqX3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> Maybe RatchetKEMAccepted -> RatchetInitParams
pqX3dh (sk1, rk1) dh1 dh2 dh3 kemAccepted =
RatchetInitParams {assocData, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk, kemAccepted}
where
assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1
dhs = dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3
dhs = dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3 <> pq
pq = maybe "" (\RatchetKEMAccepted {rcPQRss = KEMSharedKey ss} -> BA.convert ss) kemAccepted
(hk, nhk, sk) =
let salt = B.replicate 64 '\0'
in hkdf3 salt dhs "SimpleXX3DH"
@@ -129,6 +389,11 @@ data Ratchet a = Ratchet
-- associated data - must be the same in both parties ratchets
rcAD :: Str,
rcDHRs :: PrivateKey a,
rcKEM :: Maybe RatchetKEM,
-- TODO PQ make them optional via JSON parser for PQEncryption
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
rcRK :: RatchetKey,
rcSnd :: Maybe (SndRatchet a),
rcRcv :: Maybe RcvRatchet,
@@ -138,20 +403,33 @@ data Ratchet a = Ratchet
rcNHKs :: HeaderKey,
rcNHKr :: HeaderKey
}
deriving (Eq, Show)
deriving (Show)
data SndRatchet a = SndRatchet
{ rcDHRr :: PublicKey a,
rcCKs :: RatchetKey,
rcHKs :: HeaderKey
}
deriving (Eq, Show)
deriving (Show)
data RcvRatchet = RcvRatchet
{ rcCKr :: RatchetKey,
rcHKr :: HeaderKey
}
deriving (Eq, Show)
deriving (Show)
data RatchetKEM = RatchetKEM
{ rcPQRs :: KEMKeyPair,
rcKEMs :: Maybe RatchetKEMAccepted
}
deriving (Show)
data RatchetKEMAccepted = RatchetKEMAccepted
{ rcPQRr :: KEMPublicKey, -- received key
rcPQRss :: KEMSharedKey, -- computed shared secret
rcPQRct :: KEMCiphertext -- sent encaps(rcPQRr, rcPQRss)
}
deriving (Show)
type SkippedMsgKeys = Map HeaderKey SkippedHdrMsgKeys
@@ -189,7 +467,7 @@ instance Encoding MessageKey where
-- | Input key material for double ratchet HKDF functions
newtype RatchetKey = RatchetKey ByteString
deriving (Eq, Show)
deriving (Show)
instance ToJSON RatchetKey where
toJSON (RatchetKey k) = strToJSON k
@@ -202,19 +480,32 @@ instance ToField MessageKey where toField = toField . smpEncode
instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
-- | Sending ratchet initialization, equivalent to RatchetInitAliceHE in double ratchet spec
-- | Sending ratchet initialization
--
-- Please note that sPKey is not stored, and its public part together with random salt
-- is sent to the recipient.
-- @
-- RatchetInitAlicePQ2HE(state, SK, bob_dh_public_key, shared_hka, shared_nhkb, bob_pq_kem_encapsulation_key)
-- // below added for post-quantum KEM
-- state.PQRs = GENERATE_PQKEM()
-- state.PQRr = bob_pq_kem_encapsulation_key
-- state.PQRss = random // shared secret for KEM
-- state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret
-- // above added for KEM
-- @
initSndRatchet ::
forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PublicKey a -> PrivateKey a -> RatchetInitParams -> Ratchet a
initSndRatchet rcVersion rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} = do
-- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr))
let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs
forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PublicKey a -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> Ratchet a
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)
in Ratchet
{ rcVersion,
rcAD = assocData,
rcDHRs,
rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_,
rcEnableKEM = PQEncryption $ isJust rcPQRs_,
rcSndKEM = PQEncryption $ isJust kemAccepted,
rcRcvKEM = PQEncOff,
rcRK,
rcSnd = Just SndRatchet {rcDHRr, rcCKs, rcHKs = sndHK},
rcRcv = Nothing,
@@ -225,17 +516,28 @@ initSndRatchet rcVersion rcDHRr rcDHRs RatchetInitParams {assocData, ratchetKey,
rcNHKr = rcvNextHK
}
-- | Receiving ratchet initialization, equivalent to RatchetInitBobHE in double ratchet spec
-- | Receiving ratchet initialization, equivalent to RatchetInitBobPQ2HE in double ratchet spec
--
-- def RatchetInitBobPQ2HE(state, SK, bob_dh_key_pair, shared_hka, shared_nhkb, bob_pq_kem_key_pair)
--
-- Please note that the public part of rcDHRs was sent to the sender
-- as part of the connection request and random salt was received from the sender.
initRcvRatchet ::
forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PrivateKey a -> RatchetInitParams -> Ratchet a
initRcvRatchet rcVersion rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK} =
forall a. (AlgorithmI a, DhAlgorithm a) => VersionRange -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> PQEncryption -> Ratchet a
initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) rcEnableKEM =
Ratchet
{ rcVersion,
rcAD = assocData,
rcDHRs,
-- rcKEM:
-- state.PQRs = bob_pq_kem_key_pair
-- state.PQRr = None
-- state.PQRss = None
-- state.PQRct = None
rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_,
rcEnableKEM,
rcSndKEM = PQEncOff,
rcRcvKEM = PQEncOff,
rcRK = ratchetKey,
rcSnd = Nothing,
rcRcv = Nothing,
@@ -246,14 +548,17 @@ initRcvRatchet rcVersion rcDHRs RatchetInitParams {assocData, ratchetKey, sndHK,
rcNHKr = sndHK
}
-- encaps = state.PQRs.encaps, // added for KEM #2
-- ct = state.PQRct // added for KEM #1
data MsgHeader a = MsgHeader
{ -- | max supported ratchet version
msgMaxVersion :: Version,
msgDHRs :: PublicKey a,
msgKEM :: Maybe ARKEMParams,
msgPN :: Word32,
msgNs :: Word32
}
deriving (Eq, Show)
deriving (Show)
data AMsgHeader
= forall a.
@@ -262,8 +567,10 @@ data AMsgHeader
-- to allow extension without increasing the size, the actual header length is:
-- 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 :: Int
paddedHeaderLen = 88
paddedHeaderLen = 2284
-- only used in tests to validate correct padding
-- (2 bytes - version size, 1 byte - header size, not to have it fixed or version-dependent)
@@ -271,14 +578,16 @@ fullHeaderLen :: Int
fullHeaderLen = 2 + 1 + paddedHeaderLen + authTagSize + ivSize @AES256
instance AlgorithmI a => Encoding (MsgHeader a) where
smpEncode MsgHeader {msgMaxVersion, msgDHRs, msgPN, msgNs} =
smpEncode (msgMaxVersion, msgDHRs, msgPN, msgNs)
smpEncode MsgHeader {msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs}
| msgMaxVersion >= pqRatchetVersion = smpEncode (msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs)
| otherwise = smpEncode (msgMaxVersion, msgDHRs, msgPN, msgNs)
smpP = do
msgMaxVersion <- smpP
msgDHRs <- smpP
msgKEM <- if msgMaxVersion >= pqRatchetVersion then smpP else pure Nothing
msgPN <- smpP
msgNs <- smpP
pure MsgHeader {msgMaxVersion, msgDHRs, msgPN, msgNs}
pure MsgHeader {msgMaxVersion, msgDHRs, msgKEM, msgPN, msgNs}
data EncMessageHeader = EncMessageHeader
{ ehVersion :: Version,
@@ -288,10 +597,12 @@ data EncMessageHeader = EncMessageHeader
}
instance Encoding EncMessageHeader where
smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody} =
smpEncode (ehVersion, ehIV, ehAuthTag, ehBody)
smpEncode EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody}
| ehVersion >= pqRatchetVersion = smpEncode (ehVersion, ehIV, ehAuthTag, Large ehBody)
| otherwise = smpEncode (ehVersion, ehIV, ehAuthTag, ehBody)
smpP = do
(ehVersion, ehIV, ehAuthTag, ehBody) <- smpP
(ehVersion, ehIV, ehAuthTag) <- smpP
ehBody <- if ehVersion >= pqRatchetVersion then unLarge <$> smpP else smpP
pure EncMessageHeader {ehVersion, ehIV, ehAuthTag, ehBody}
data EncRatchetMessage = EncRatchetMessage
@@ -300,37 +611,123 @@ data EncRatchetMessage = EncRatchetMessage
emBody :: ByteString
}
instance Encoding EncRatchetMessage where
smpEncode EncRatchetMessage {emHeader, emBody, emAuthTag} =
smpEncode (emHeader, emAuthTag, Tail emBody)
smpP = do
(emHeader, emAuthTag, Tail emBody) <- smpP
pure EncRatchetMessage {emHeader, emBody, emAuthTag}
encodeEncRatchetMessage :: Version -> EncRatchetMessage -> ByteString
encodeEncRatchetMessage v EncRatchetMessage {emHeader, emBody, emAuthTag}
| v >= pqRatchetVersion = smpEncode (Large emHeader, emAuthTag, Tail emBody)
| otherwise = smpEncode (emHeader, emAuthTag, Tail emBody)
rcEncrypt :: AlgorithmI a => Ratchet a -> Int -> ByteString -> ExceptT CryptoError IO (ByteString, Ratchet a)
rcEncrypt Ratchet {rcSnd = Nothing} _ _ = throwE CERatchetState
rcEncrypt rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcDHRs, rcNs, rcPN, rcAD = Str rcAD, rcVersion} paddedMsgLen msg = do
encRatchetMessageP :: Version -> Parser EncRatchetMessage
encRatchetMessageP v = do
emHeader <- if v >= pqRatchetVersion then unLarge <$> smpP else smpP
(emAuthTag, Tail emBody) <- smpP
pure EncRatchetMessage {emHeader, emBody, emAuthTag}
newtype PQEncryption = PQEncryption {enablePQ :: Bool}
deriving (Eq, Show)
pattern PQEncOn :: PQEncryption
pattern PQEncOn = PQEncryption True
pattern PQEncOff :: PQEncryption
pattern PQEncOff = PQEncryption False
{-# COMPLETE PQEncOn, PQEncOff #-}
instance ToJSON PQEncryption where
toEncoding (PQEncryption pq) = toEncoding pq
toJSON (PQEncryption pq) = toJSON pq
instance FromJSON PQEncryption where
parseJSON v = PQEncryption <$> parseJSON v
replyKEM_ :: PQEncryption -> Maybe (RKEMParams 'RKSProposed) -> Maybe AUseKEM
replyKEM_ pqEnc kem_ = case pqEnc of
PQEncOn -> Just $ case kem_ of
Just (RKParamsProposed k) -> AUseKEM SRKSAccepted $ AcceptKEM k
Nothing -> AUseKEM SRKSProposed ProposeKEM
PQEncOff -> Nothing
instance StrEncoding PQEncryption where
strEncode pqMode
| enablePQ pqMode = "pq=enable"
| otherwise = "pq=disable"
strP =
A.takeTill (== ' ') >>= \case
"pq=enable" -> pq True
"pq=disable" -> pq False
_ -> fail "bad PQEncryption"
where
pq = pure . PQEncryption
data InitialKeys = IKUsePQ | IKNoPQ PQEncryption
deriving (Eq, Show)
instance StrEncoding InitialKeys where
strEncode = \case
IKUsePQ -> "pq=invitation"
IKNoPQ pq -> strEncode pq
strP = IKNoPQ <$> strP <|> "pq=invitation" $> IKUsePQ
-- determines whether PQ key should be included in invitation link
initialPQEncryption :: InitialKeys -> PQEncryption
initialPQEncryption = \case
IKUsePQ -> PQEncOn
IKNoPQ _ -> PQEncOff -- default
-- determines whether PQ encryption should be used in connection
connPQEncryption :: InitialKeys -> PQEncryption
connPQEncryption = \case
IKUsePQ -> PQEncOn
IKNoPQ pq -> pq -- default for creating connection is IKNoPQ PQEncOn
-- determines whether PQ key should be included in invitation link sent to contact address
joinContactInitialKeys :: PQEncryption -> InitialKeys
joinContactInitialKeys = \case
PQEncOn -> IKUsePQ -- default
PQEncOff -> IKNoPQ PQEncOff
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 pqMode_ = do
-- state.CKs, mk = KDF_CK(state.CKs)
let (ck', mk, iv, ehIV) = chainKdf rcCKs
-- enc_header = HENCRYPT(state.HKs, header)
(ehAuthTag, ehBody) <- encryptAEAD rcHKs ehIV paddedHeaderLen rcAD msgHeader
-- return enc_header, ENCRYPT(mk, plaintext, CONCAT(AD, enc_header))
let emHeader = smpEncode EncMessageHeader {ehVersion = minVersion rcVersion, ehBody, ehAuthTag, ehIV}
-- TODO PQ versioning in Ratchet should change somehow
let emHeader = smpEncode EncMessageHeader {ehVersion = maxVersion rcVersion, ehBody, ehAuthTag, ehIV}
(emAuthTag, emBody) <- encryptAEAD mk iv paddedMsgLen (rcAD <> emHeader) msg
let msg' = smpEncode EncRatchetMessage {emHeader, emBody, emAuthTag}
let msg' = encodeEncRatchetMessage (maxVersion rcVersion) EncRatchetMessage {emHeader, emBody, emAuthTag}
-- state.Ns += 1
rc' = rc {rcSnd = Just sr {rcCKs = ck'}, rcNs = rcNs + 1}
pure (msg', rc')
rc'' = case pqMode_ of
Nothing -> rc'
Just rcEnableKEM
| enablePQ rcEnableKEM -> rc' {rcEnableKEM}
| otherwise ->
let rcKEM' = (\rck -> rck {rcKEMs = Nothing}) <$> rcKEM
in rc' {rcEnableKEM, rcKEM = rcKEM'}
pure (msg', rc'')
where
-- header = HEADER(state.DHRs, state.PN, state.Ns)
-- header = HEADER_PQ2(
-- dh = state.DHRs.public,
-- kem = state.PQRs.public, // added for KEM #2
-- ct = state.PQRct, // added for KEM #1
-- pn = state.PN,
-- n = state.Ns
-- )
msgHeader =
smpEncode
MsgHeader
{ msgMaxVersion = maxVersion rcVersion,
msgDHRs = publicKey rcDHRs,
msgKEM = msgKEMParams <$> rcKEM,
msgPN = rcPN,
msgNs = rcNs
}
msgKEMParams RatchetKEM {rcPQRs = (k, _), rcKEMs} = case rcKEMs of
Nothing -> ARKP SRKSProposed $ RKParamsProposed k
Just RatchetKEMAccepted {rcPQRct} -> ARKP SRKSAccepted $ RKParamsAccepted rcPQRct k
data SkippedMessage a
= SMMessage (DecryptResult a)
@@ -338,7 +735,7 @@ data SkippedMessage a
| SMNone
data RatchetStep = AdvanceRatchet | SameRatchet
deriving (Eq)
deriving (Eq, Show)
type DecryptResult a = (Either CryptoError ByteString, Ratchet a, SkippedMsgDiff)
@@ -353,8 +750,9 @@ rcDecrypt ::
SkippedMsgKeys ->
ByteString ->
ExceptT CryptoError IO (DecryptResult a)
rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError smpP msg'
rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD, rcVersion} rcMKSkipped msg' = do
-- TODO PQ versioning should change
encMsg@EncRatchetMessage {emHeader} <- parseE CryptoHeaderError (encRatchetMessageP $ maxVersion rcVersion) msg'
encHdr <- parseE CryptoHeaderError smpP emHeader
-- plaintext = TrySkippedMessageKeysHE(state, enc_header, cipher-text, AD)
decryptSkipped encHdr encMsg >>= \case
@@ -368,7 +766,7 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
SMMessage r -> pure r
where
decryptRcMessage :: RatchetStep -> MsgHeader a -> EncRatchetMessage -> ExceptT CryptoError IO (DecryptResult a)
decryptRcMessage rcStep MsgHeader {msgDHRs, msgPN, msgNs} encMsg = do
decryptRcMessage rcStep MsgHeader {msgDHRs, msgKEM, msgPN, msgNs} encMsg = do
-- if dh_ratchet:
(rc', smks1) <- ratchetStep rcStep
case skipMessageKeys msgNs rc' of
@@ -392,15 +790,23 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
case skipMessageKeys msgPN rc of
Left e -> throwE e
Right (rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr}, hmks) -> do
-- DHRatchetHE(state, header)
-- DHRatchetPQ2HE(state, header)
(kemSS, kemSS', rcKEM') <- pqRatchetStep rc' msgKEM
-- state.DHRs = GENERATE_DH()
(_, rcDHRs') <- atomically $ generateKeyPair @a g
-- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))
let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs
-- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))
(rcRK'', rcCKs', rcNHKs') = rootKdf rcRK' msgDHRs rcDHRs'
-- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || ss)
let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs rcDHRs kemSS
-- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr) || state.PQRss)
(rcRK'', rcCKs', rcNHKs') = rootKdf rcRK' msgDHRs rcDHRs' kemSS'
sndKEM = isJust kemSS'
rcvKEM = isJust kemSS
rc'' =
rc'
{ rcDHRs = rcDHRs',
rcKEM = rcKEM',
rcEnableKEM = PQEncryption $ sndKEM || rcvKEM,
rcSndKEM = PQEncryption sndKEM,
rcRcvKEM = PQEncryption rcvKEM,
rcRK = rcRK'',
rcSnd = Just SndRatchet {rcDHRr = msgDHRs, rcCKs = rcCKs', rcHKs = rcNHKs},
rcRcv = Just RcvRatchet {rcCKr = rcCKr', rcHKr = rcNHKr},
@@ -411,6 +817,39 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
rcNHKr = rcNHKr'
}
pure (rc'', hmks)
pqRatchetStep :: Ratchet a -> Maybe ARKEMParams -> ExceptT CryptoError IO (Maybe KEMSharedKey, Maybe KEMSharedKey, Maybe RatchetKEM)
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 -> 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 -> do
-- state.PQRr = header.kem
(ss, rcPQRr) <- sharedSecret
-- state.PQRct = PQKEM-ENC(state.PQRr, state.PQRss) // encapsulated additional shared secret KEM #1
(rcPQRct, rcPQRss) <- liftIO $ sntrup761Enc g rcPQRr
-- state.PQRs = GENERATE_PQKEM()
rcPQRs <- liftIO $ sntrup761Keypair g
let kem' = RatchetKEM {rcPQRs, rcKEMs = Just RatchetKEMAccepted {rcPQRr, rcPQRss, rcPQRct}}
pure (ss, Just rcPQRss, Just kem')
| otherwise -> do
-- state.PQRr = header.kem
(ss, _) <- sharedSecret
pure (ss, Nothing, Nothing)
where
sharedSecret = case ps of
RKParamsProposed k -> pure (Nothing, k)
RKParamsAccepted ct k -> case rcKEM of
Nothing -> throwE CERatchetKEMState
-- ss = PQKEM-DEC(state.PQRs.private, header.ct)
Just RatchetKEM {rcPQRs} -> do
ss <- liftIO $ sntrup761Dec ct (snd rcPQRs)
pure (Just ss, k)
skipMessageKeys :: Word32 -> Ratchet a -> Either CryptoError (Ratchet a, SkippedMsgKeys)
skipMessageKeys _ r@Ratchet {rcRcv = Nothing} = Right (r, M.empty)
skipMessageKeys untilN r@Ratchet {rcRcv = Just rr@RcvRatchet {rcCKr, rcHKr}, rcNr}
@@ -465,10 +904,13 @@ rcDecrypt g rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
-- DECRYPT(mk, cipher-text, CONCAT(AD, enc_header))
tryE $ decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag
rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> (RatchetKey, RatchetKey, Key)
rootKdf (RatchetKey rk) k pk =
let dhOut = dhBytes' $ dh' k pk
(rk', ck, nhk) = hkdf3 rk dhOut "SimpleXRootRatchet"
rootKdf :: (AlgorithmI a, DhAlgorithm a) => RatchetKey -> PublicKey a -> PrivateKey a -> Maybe KEMSharedKey -> (RatchetKey, RatchetKey, Key)
rootKdf (RatchetKey rk) k pk kemSecret_ =
let dhOut = dhBytes' (dh' k pk)
ss = case kemSecret_ of
Just (KEMSharedKey s) -> dhOut <> BA.convert s
Nothing -> dhOut
(rk', ck, nhk) = hkdf3 rk ss "SimpleXRootRatchet"
in (RatchetKey rk', RatchetKey ck, Key nhk)
chainKdf :: RatchetKey -> (RatchetKey, Key, IV, IV)
@@ -487,6 +929,10 @@ hkdf3 salt ikm info = (s1, s2, s3)
$(JQ.deriveJSON defaultJSON ''RcvRatchet)
$(JQ.deriveJSON defaultJSON ''RatchetKEMAccepted)
$(JQ.deriveJSON defaultJSON ''RatchetKEM)
instance AlgorithmI a => ToJSON (SndRatchet a) where
toEncoding = $(JQ.mkToEncoding defaultJSON ''SndRatchet)
toJSON = $(JQ.mkToJSON defaultJSON ''SndRatchet)
src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs
+53 -4
View File
@@ -19,16 +19,20 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
newtype KEMPublicKey = KEMPublicKey ByteString
deriving (Show)
deriving (Eq, Show)
newtype KEMSecretKey = KEMSecretKey ScrubbedBytes
deriving (Show)
deriving (Eq, Show)
newtype KEMCiphertext = KEMCiphertext ByteString
deriving (Show)
deriving (Eq, Show)
newtype KEMSharedKey = KEMSharedKey ScrubbedBytes
deriving (Show)
deriving (Eq, Show)
unsafeRevealKEMSharedKey :: KEMSharedKey -> String
unsafeRevealKEMSharedKey (KEMSharedKey scrubbed) = show (BA.convert scrubbed :: ByteString)
{-# DEPRECATED unsafeRevealKEMSharedKey "unsafeRevealKEMSharedKey left in code" #-}
type KEMKeyPair = (KEMPublicKey, KEMSecretKey)
@@ -60,6 +64,18 @@ sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) =
KEMSharedKey
<$> BA.alloc c_SNTRUP761_SIZE (\kPtr -> c_sntrup761_dec kPtr cPtr skPtr)
instance Encoding KEMSecretKey where
smpEncode (KEMSecretKey c) = smpEncode . Large $ BA.convert c
smpP = KEMSecretKey . BA.convert . unLarge <$> smpP
instance StrEncoding KEMSecretKey where
strEncode (KEMSecretKey pk) = strEncode (BA.convert pk :: ByteString)
strP = KEMSecretKey . BA.convert <$> strP @ByteString
instance Encoding KEMPublicKey where
smpEncode (KEMPublicKey pk) = smpEncode . Large $ BA.convert pk
smpP = KEMPublicKey . BA.convert . unLarge <$> smpP
instance StrEncoding KEMPublicKey where
strEncode (KEMPublicKey pk) = strEncode (BA.convert pk :: ByteString)
strP = KEMPublicKey . BA.convert <$> strP @ByteString
@@ -68,6 +84,25 @@ instance Encoding KEMCiphertext where
smpEncode (KEMCiphertext c) = smpEncode . Large $ BA.convert c
smpP = KEMCiphertext . BA.convert . unLarge <$> smpP
instance Encoding KEMSharedKey where
smpEncode (KEMSharedKey c) = smpEncode (BA.convert c :: ByteString)
smpP = KEMSharedKey . BA.convert <$> smpP @ByteString
instance StrEncoding KEMCiphertext where
strEncode (KEMCiphertext pk) = strEncode (BA.convert pk :: ByteString)
strP = KEMCiphertext . BA.convert <$> strP @ByteString
instance StrEncoding KEMSharedKey where
strEncode (KEMSharedKey pk) = strEncode (BA.convert pk :: ByteString)
strP = KEMSharedKey . BA.convert <$> strP @ByteString
instance ToJSON KEMSecretKey where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON KEMSecretKey where
parseJSON = strParseJSON "KEMSecretKey"
instance ToJSON KEMPublicKey where
toJSON = strToJSON
toEncoding = strToJEncoding
@@ -75,8 +110,22 @@ instance ToJSON KEMPublicKey where
instance FromJSON KEMPublicKey where
parseJSON = strParseJSON "KEMPublicKey"
instance ToJSON KEMCiphertext where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON KEMCiphertext where
parseJSON = strParseJSON "KEMCiphertext"
instance ToField KEMSharedKey where
toField (KEMSharedKey k) = toField (BA.convert k :: ByteString)
instance FromField KEMSharedKey where
fromField f = KEMSharedKey . BA.convert @ByteString <$> fromField f
instance ToJSON KEMSharedKey where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON KEMSharedKey where
parseJSON = strParseJSON "KEMSharedKey"
src/Simplex/Messaging/Encoding/String.hs
+6
View File
@@ -179,6 +179,12 @@ instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncodin
strP = (,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
instance (StrEncoding a, StrEncoding b, StrEncoding c, StrEncoding d, StrEncoding e, StrEncoding f) => StrEncoding (a, b, c, d, e, f) where
strEncode (a, b, c, d, e, f) = B.unwords [strEncode a, strEncode b, strEncode c, strEncode d, strEncode e, strEncode f]
{-# INLINE strEncode #-}
strP = (,,,,,) <$> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP_ <*> strP
{-# INLINE strP #-}
strP_ :: StrEncoding a => Parser a
strP_ = strP <* A.space
src/Simplex/Messaging/Protocol.hs
+2 -7
View File
@@ -175,7 +175,7 @@ import Data.Functor (($>))
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (isJust, isNothing)
import Data.Maybe (isNothing)
import Data.String
import Data.Time.Clock.System (SystemTime (..))
import Data.Type.Equality
@@ -272,7 +272,7 @@ data RawTransmission = RawTransmission
data TransmissionAuth
= TASignature C.ASignature
| TAAuthenticator C.CbAuthenticator
deriving (Eq, Show)
deriving (Show)
-- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TAuthorization
tAuthBytes :: Maybe TransmissionAuth -> ByteString
@@ -338,8 +338,6 @@ data Command (p :: Party) where
deriving instance Show (Command p)
deriving instance Eq (Command p)
data SubscriptionMode = SMSubscribe | SMOnlyCreate
deriving (Eq, Show)
@@ -746,9 +744,6 @@ data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p
deriving instance Show AProtocolType
instance Eq AProtocolType where
AProtocolType p == AProtocolType p' = isJust $ testEquality p p'
instance TestEquality SProtocolType where
testEquality SPSMP SPSMP = Just Refl
testEquality SPNTF SPNTF = Just Refl
src/Simplex/Messaging/Server/QueueStore.hs
+2 -2
View File
@@ -17,14 +17,14 @@ data QueueRec = QueueRec
notifier :: !(Maybe NtfCreds),
status :: !ServerQueueStatus
}
deriving (Eq, Show)
deriving (Show)
data NtfCreds = NtfCreds
{ notifierId :: !NotifierId,
notifierKey :: !NtfPublicAuthKey,
rcvNtfDhSecret :: !RcvNtfDhSecret
}
deriving (Eq, Show)
deriving (Show)
instance StrEncoding NtfCreds where
strEncode NtfCreds {notifierId, notifierKey, rcvNtfDhSecret} = strEncode (notifierId, notifierKey, rcvNtfDhSecret)