mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 02:22:45 +00:00
Compare commits
13
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
5884d2cf03 | ||
|
|
27a37387be | ||
|
|
d65d790a20 | ||
|
|
7d0820dd44 | ||
|
|
efaad8e734 | ||
|
|
1b4dcfe63e | ||
|
|
f7e8ed52bf | ||
|
|
399c5fe8c6 | ||
|
|
43e46dd8cc | ||
|
|
551de8039f | ||
|
|
a45d764eaa | ||
|
|
836254a4c6 | ||
|
|
93925b257c |
+1
-1
@@ -1,7 +1,7 @@
|
||||
cabal-version: 3.0
|
||||
|
||||
name: simplexmq
|
||||
version: 7.0.0.3
|
||||
version: 7.0.1.0
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
|
||||
@@ -49,6 +49,7 @@ module Simplex.Messaging.Agent
|
||||
deleteUser,
|
||||
setUserService,
|
||||
connRequestPQSupport,
|
||||
prepareConnectionToCreate,
|
||||
createConnectionAsync,
|
||||
setConnShortLinkAsync,
|
||||
getConnShortLinkAsync,
|
||||
@@ -358,9 +359,14 @@ setUserService :: AgentClient -> UserId -> Bool -> AE ()
|
||||
setUserService c = withAgentEnv c .: setUserService' c
|
||||
{-# INLINE setUserService #-}
|
||||
|
||||
-- | Create SMP agent connection (NEW command) asynchronously, synchronous response is new connection id
|
||||
createConnectionAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AE ConnId
|
||||
createConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:. newConnAsync c userId aCorrId enableNtfs
|
||||
-- | Create SMP agent connection without queue (to be used with createConnectionAsync).
|
||||
prepareConnectionToCreate :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AE ConnId
|
||||
prepareConnectionToCreate c userId enableNtfs = withAgentEnv c .: newConnNoQueues c userId enableNtfs
|
||||
{-# INLINE prepareConnectionToCreate #-}
|
||||
|
||||
-- | Enqueue NEW command for a prepared connection.
|
||||
createConnectionAsync :: ConnectionModeI c => AgentClient -> ACorrId -> ConnId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AE ()
|
||||
createConnectionAsync c aCorrId connId enableNtfs = withAgentEnv c .:. newConnAsync c aCorrId connId enableNtfs
|
||||
{-# INLINE createConnectionAsync #-}
|
||||
|
||||
-- | Create or update user's contact connection short link (LSET command) asynchronously, no synchronous response
|
||||
@@ -373,10 +379,9 @@ getConnShortLinkAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Con
|
||||
getConnShortLinkAsync c = withAgentEnv c .:: getConnShortLinkAsync' c
|
||||
{-# INLINE getConnShortLinkAsync #-}
|
||||
|
||||
-- | Join SMP agent connection (JOIN command) asynchronously, synchronous response is new connection id.
|
||||
-- If connId is provided (for contact URIs), it updates the existing connection record created by getConnShortLinkAsync.
|
||||
joinConnectionAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId
|
||||
joinConnectionAsync c userId aCorrId connId_ enableNtfs = withAgentEnv c .:: joinConnAsync c userId aCorrId connId_ enableNtfs
|
||||
-- | Enqueue JOIN command for a prepared connection.
|
||||
joinConnectionAsync :: AgentClient -> ACorrId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ()
|
||||
joinConnectionAsync c aCorrId updateConn connId enableNtfs = withAgentEnv c .:: joinConnAsync c aCorrId updateConn connId enableNtfs
|
||||
{-# INLINE joinConnectionAsync #-}
|
||||
|
||||
-- | Allow connection to continue after CONF notification (LET command), no synchronous response
|
||||
@@ -384,9 +389,9 @@ allowConnectionAsync :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> Co
|
||||
allowConnectionAsync c = withAgentEnv c .:: allowConnectionAsync' c
|
||||
{-# INLINE allowConnectionAsync #-}
|
||||
|
||||
-- | Accept contact after REQ notification (ACPT command) asynchronously, synchronous response is new connection id
|
||||
acceptContactAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId
|
||||
acceptContactAsync c userId aCorrId enableNtfs = withAgentEnv c .:: acceptContactAsync' c userId aCorrId enableNtfs
|
||||
-- | Accept contact after REQ notification (ACPT command) asynchronously, for a prepared connection.
|
||||
acceptContactAsync :: AgentClient -> ACorrId -> ConnId -> Bool -> ConfirmationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ()
|
||||
acceptContactAsync c aCorrId connId enableNtfs = withAgentEnv c .:: acceptContactAsync' c aCorrId connId enableNtfs
|
||||
{-# INLINE acceptContactAsync #-}
|
||||
|
||||
-- | Acknowledge message (ACK command) asynchronously, no synchronous response
|
||||
@@ -418,8 +423,9 @@ createConnection c nm userId enableNtfs checkNotices = withAgentEnv c .::. newCo
|
||||
-- Caller provides root signing key pair and link entity ID.
|
||||
-- Returns the created link and internal params.
|
||||
-- The link address is fully determined at this point.
|
||||
prepareConnectionLink :: AgentClient -> UserId -> C.KeyPairEd25519 -> ByteString -> Bool -> Maybe CRClientData -> AE (CreatedConnLink 'CMContact, PreparedLinkParams)
|
||||
prepareConnectionLink c userId rootKey linkEntityId checkNotices = withAgentEnv c . prepareConnectionLink' c userId rootKey linkEntityId checkNotices
|
||||
prepareConnectionLink :: AgentClient -> UserId -> C.KeyPairEd25519 -> ByteString -> Bool -> Maybe CRClientData -> Maybe SMPServerWithAuth -> AE (CreatedConnLink 'CMContact, PreparedLinkParams)
|
||||
prepareConnectionLink c userId rootKey linkEntityId checkNotices clientData srv_ =
|
||||
withAgentEnv c $ prepareConnectionLink' c userId rootKey linkEntityId checkNotices clientData srv_
|
||||
{-# INLINE prepareConnectionLink #-}
|
||||
|
||||
-- | Create connection for prepared link (single network call).
|
||||
@@ -445,7 +451,7 @@ getConnShortLink c = withAgentEnv c .:. getConnShortLink' c
|
||||
-- | Resolve a SimpleX name (PFWD RSLV). The agent owns server selection: it
|
||||
-- picks a names-capable server (ServerRoles.names) from the user's nameSrvs, so
|
||||
-- chat clients just pass the parsed domain.
|
||||
resolveSimplexName :: AgentClient -> NetworkRequestMode -> UserId -> SimplexNameDomain -> AE NameRecord
|
||||
resolveSimplexName :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AE NameRecord
|
||||
resolveSimplexName c nm userId domain = withAgentEnv c $ resolveSimplexName' c nm userId domain
|
||||
{-# INLINE resolveSimplexName #-}
|
||||
|
||||
@@ -846,11 +852,10 @@ setUserService' c userId enable = do
|
||||
unless ok $ throwE $ CMD PROHIBITED "setUserService"
|
||||
when (changed && not enable) $ withStore' c (`deleteClientServices` userId)
|
||||
|
||||
newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
|
||||
newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
|
||||
connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
newConnAsync :: ConnectionModeI c => AgentClient -> ACorrId -> ConnId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ()
|
||||
newConnAsync c corrId connId enableNtfs cMode pqInitKeys subMode =
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pqInitKeys subMode
|
||||
pure connId
|
||||
{-# INLINE newConnAsync #-}
|
||||
|
||||
newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
|
||||
newConnNoQueues c userId enableNtfs cMode pqSupport = do
|
||||
@@ -861,34 +866,21 @@ newConnNoQueues c userId enableNtfs cMode pqSupport = do
|
||||
|
||||
-- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection,
|
||||
-- and join should retry, the same as 1-time invitation joins.
|
||||
joinConnAsync :: AgentClient -> UserId -> ACorrId -> Maybe ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
|
||||
joinConnAsync c userId corrId connId_ enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do
|
||||
when (isJust connId_) $ throwE $ CMD PROHIBITED "joinConnAsync: connId not allowed for invitation URI"
|
||||
withInvLock c (strEncode cReqUri) "joinConnAsync" $ do
|
||||
joinConnAsync :: AgentClient -> ACorrId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ()
|
||||
joinConnAsync c corrId updateConn connId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do
|
||||
when updateConn $ throwE $ CMD PROHIBITED "joinConnAsync: updateConn not allowed for invitation URI"
|
||||
withInvLock c (strEncode cReqUri) "joinConnAsync" $
|
||||
lift (compatibleInvitationUri cReqUri) >>= \case
|
||||
Just (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do
|
||||
g <- asks random
|
||||
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v)
|
||||
cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
|
||||
connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo
|
||||
pure connId
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
joinConnAsync c userId corrId connId_ enableNtfs cReqUri@(CRContactUri _) cInfo pqSup subMode = do
|
||||
joinConnAsync c corrId updateConn connId enableNtfs cReqUri@(CRContactUri _) cInfo pqSup subMode =
|
||||
lift (compatibleContactUri cReqUri) >>= \case
|
||||
Just (_, Compatible connAgentVersion) -> do
|
||||
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion Nothing
|
||||
connId <- case connId_ of
|
||||
Just cId -> do
|
||||
-- update connection record created by getConnShortLinkAsync
|
||||
withStore' c $ \db -> updateNewConnJoin db cId connAgentVersion pqSupport enableNtfs
|
||||
pure cId
|
||||
Nothing -> do
|
||||
g <- asks random
|
||||
let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
|
||||
withStore c $ \db -> createNewConn db g cData SCMInvitation
|
||||
when updateConn $ withStore' c $ \db -> updateNewConnJoin db connId connAgentVersion pqSupport enableNtfs
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo
|
||||
pure connId
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
|
||||
allowConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> AM ()
|
||||
@@ -904,11 +896,11 @@ allowConnectionAsync' c corrId connId confId ownConnInfo =
|
||||
-- and also it can't be triggered by user concurrently several times in a row. It could be improved similarly to
|
||||
-- `acceptContact` by creating a new map for invitation locks and taking lock here, and removing `unacceptInvitation`
|
||||
-- while marking invitation as accepted inside "lock level transaction" after successful `joinConnAsync`.
|
||||
acceptContactAsync' :: AgentClient -> UserId -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
|
||||
acceptContactAsync' c userId corrId enableNtfs invId ownConnInfo pqSupport subMode = do
|
||||
acceptContactAsync' :: AgentClient -> ACorrId -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ()
|
||||
acceptContactAsync' c corrId connId enableNtfs invId ownConnInfo pqSupport subMode = do
|
||||
Invitation {connReq} <- withStore c $ \db -> getInvitation db "acceptContactAsync'" invId
|
||||
withStore' c $ \db -> acceptInvitation db invId ownConnInfo
|
||||
joinConnAsync c userId corrId Nothing enableNtfs connReq ownConnInfo pqSupport subMode `catchAllErrors` \err -> do
|
||||
joinConnAsync c corrId False connId enableNtfs connReq ownConnInfo pqSupport subMode `catchAllErrors` \err -> do
|
||||
withStore' c (`unacceptInvitation` invId)
|
||||
throwE err
|
||||
|
||||
@@ -974,10 +966,10 @@ newConn c nm userId enableNtfs checkNotices cMode linkData_ clientData pqInitKey
|
||||
|
||||
-- | Prepare connection link for contact mode (no network, no database).
|
||||
-- Caller provides root signing key pair and link entity ID.
|
||||
prepareConnectionLink' :: AgentClient -> UserId -> C.KeyPairEd25519 -> ByteString -> Bool -> Maybe CRClientData -> AM (CreatedConnLink 'CMContact, PreparedLinkParams)
|
||||
prepareConnectionLink' c userId rootKey@(_, plpRootPrivKey) linkEntityId checkNotices clientData = do
|
||||
prepareConnectionLink' :: AgentClient -> UserId -> C.KeyPairEd25519 -> ByteString -> Bool -> Maybe CRClientData -> Maybe SMPServerWithAuth -> AM (CreatedConnLink 'CMContact, PreparedLinkParams)
|
||||
prepareConnectionLink' c userId rootKey@(_, plpRootPrivKey) linkEntityId checkNotices clientData srv_ = do
|
||||
g <- asks random
|
||||
plpSrvWithAuth@(ProtoServerWithAuth srv _) <- getSMPServer c userId
|
||||
plpSrvWithAuth@(ProtoServerWithAuth srv _) <- maybe (getSMPServer c userId) pure srv_
|
||||
when checkNotices $ checkClientNotices c plpSrvWithAuth
|
||||
AgentConfig {smpClientVRange, smpAgentVRange} <- asks config
|
||||
plpNonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g
|
||||
@@ -1191,7 +1183,7 @@ getConnShortLink' c nm userId = \case
|
||||
deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM ()
|
||||
deleteLocalInvShortLink' c (CSLInvitation _ srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId
|
||||
|
||||
resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SimplexNameDomain -> AM NameRecord
|
||||
resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AM NameRecord
|
||||
resolveSimplexName' c nm userId domain = do
|
||||
resolverSrv <- getNextNameServer c userId
|
||||
resolveName c nm userId resolverSrv domain
|
||||
@@ -1233,8 +1225,8 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userLinkData_ clientData pqIni
|
||||
SCMInvitation -> do
|
||||
g <- asks random
|
||||
let pqEnc = CR.initialPQEncryption (isJust userLinkData_) pqInitKeys
|
||||
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
(pks, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pks
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
prepareLinkData :: UserConnLinkData c -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
|
||||
prepareLinkData userLinkData e2eDhKey = do
|
||||
@@ -1355,9 +1347,9 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup =
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
where
|
||||
createRatchet_ db g maxSupported pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do
|
||||
(pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport)
|
||||
(pks, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport)
|
||||
(_, rcDHRs) <- atomically $ C.generateKeyPair g
|
||||
rcParams <- liftEitherWith (SEAgentError . cryptoError) $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams
|
||||
rcParams <- liftEitherWith (SEAgentError . cryptoError) $ CR.pqX3dhSnd pks e2eRcvParams
|
||||
let rcVs = CR.RatchetVersions {current = v, maxSupported}
|
||||
rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
|
||||
liftIO $ createSndRatchet db connId rc e2eSndParams
|
||||
@@ -1434,8 +1426,8 @@ joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup su
|
||||
Left e -> do
|
||||
nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no rcv ratchet " <> show e))
|
||||
let pqEnc = CR.initialPQEncryption False pqInitKeys
|
||||
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eVR) pqEnc
|
||||
createRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
(pks, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eVR) pqEnc
|
||||
createRatchetX3dhKeys db connId pks
|
||||
pure e2eRcvParams
|
||||
let cReq = CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eVR
|
||||
pure $ CCLink cReq Nothing
|
||||
@@ -2483,11 +2475,11 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
|
||||
let cData' = cData {pqSupport = pqSupport'} :: ConnData
|
||||
AgentConfig {e2eEncryptVRange} <- asks config
|
||||
g <- asks random
|
||||
(pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqSupport'
|
||||
(pks, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqSupport'
|
||||
enqueueRatchetKeyMsgs c sqs e2eParams
|
||||
withStore' c $ \db -> do
|
||||
setConnRatchetSync db connId RSStarted
|
||||
setRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
setRatchetX3dhKeys db connId pks
|
||||
let cData'' = cData' {ratchetSyncState = RSStarted} :: ConnData
|
||||
conn' = DuplexConnection cData'' rqs sqs
|
||||
connectionStats c conn'
|
||||
@@ -3418,8 +3410,8 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
|
||||
-- party initiating connection
|
||||
(RcvConnection _ _, Just (CR.AE2ERatchetParams _ e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _ _))) -> do
|
||||
unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwE $ AGENT A_VERSION)
|
||||
(pk1, rcDHRs, pKem) <- withStore c (`getRatchetX3dhKeys` connId)
|
||||
rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 rcDHRs pKem e2eSndParams
|
||||
pks@(_, rcDHRs, _) <- withStore c (`getRatchetX3dhKeys` connId)
|
||||
rcParams <- liftError cryptoError $ CR.pqX3dhRcv pks e2eSndParams
|
||||
let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange}
|
||||
pqSupport' = pqSupport `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just e2eVersion)
|
||||
rc = CR.initRcvRatchet rcVs rcDHRs rcParams pqSupport'
|
||||
@@ -3660,7 +3652,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
|
||||
exists <- checkRatchetKeyHashExists db connId rkHashRcv
|
||||
unless exists $ addProcessedRatchetKeyHash db connId rkHashRcv
|
||||
pure exists
|
||||
getSendRatchetKeys :: AM (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams)
|
||||
getSendRatchetKeys :: AM (CR.RcvE2EPrivRatchetParams 'C.X448)
|
||||
getSendRatchetKeys = case rss of
|
||||
RSOk -> sendReplyKey -- receiving client
|
||||
RSAllowed -> sendReplyKey
|
||||
@@ -3676,9 +3668,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
|
||||
where
|
||||
sendReplyKey = do
|
||||
g <- asks random
|
||||
(pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g e2eVersion pqSupport
|
||||
(pks, e2eParams) <- liftIO $ CR.generateRcvE2EParams g e2eVersion pqSupport
|
||||
enqueueRatchetKeyMsgs c sqs e2eParams
|
||||
pure (pk1, pk2, pKem)
|
||||
pure pks
|
||||
notifyRatchetSyncError = do
|
||||
let cData'' = cData' {ratchetSyncState = RSRequired} :: ConnData
|
||||
conn'' = updateConnection cData'' conn'
|
||||
@@ -3697,14 +3689,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
|
||||
createRatchet db connId rc
|
||||
-- compare public keys `k1` in AgentRatchetKey messages sent by self and other party
|
||||
-- to determine ratchet initilization ordering
|
||||
initRatchet :: CR.RatchetVersions -> (C.PrivateKeyX448, C.PrivateKeyX448, Maybe CR.RcvPrivRKEMParams) -> AM ()
|
||||
initRatchet :: CR.RatchetVersions -> CR.RcvE2EPrivRatchetParams 'C.X448 -> AM ()
|
||||
initRatchet rcVs (pk1, pk2, pKem)
|
||||
| rkHash (C.publicKey pk1) (C.publicKey pk2) <= rkHashRcv = do
|
||||
rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 pk2 pKem e2eOtherPartyParams
|
||||
rcParams <- liftError cryptoError $ CR.pqX3dhRcv (pk1, pk2, pKem) e2eOtherPartyParams
|
||||
recreateRatchet $ CR.initRcvRatchet rcVs pk2 rcParams pqSupport
|
||||
| otherwise = do
|
||||
(_, rcDHRs) <- atomically . C.generateKeyPair =<< asks random
|
||||
rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 (CR.APRKP CR.SRKSProposed <$> pKem) e2eOtherPartyParams
|
||||
rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd (pk1, pk2, CR.APRKP CR.SRKSProposed <$> pKem) e2eOtherPartyParams
|
||||
recreateRatchet $ CR.initSndRatchet rcVs k2Rcv rcDHRs rcParams
|
||||
void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
|
||||
|
||||
|
||||
@@ -1986,7 +1986,7 @@ getQueueLink c nm userId server lnkId =
|
||||
-- resolver) and falls back to a direct send when the proxy is unavailable
|
||||
-- (faster but exposes the client IP). Mode selection is delegated to
|
||||
-- `sendOrProxySMPCommand`, which honours the network config (SPMNever etc.).
|
||||
resolveName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexNameDomain -> AM NameRecord
|
||||
resolveName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexDomain -> AM NameRecord
|
||||
resolveName c nm userId server domain =
|
||||
snd <$> sendOrProxySMPCommand c nm userId server "" "RSLV" NoEntity resolveViaProxy resolveDirectly
|
||||
where
|
||||
|
||||
@@ -123,7 +123,7 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnectionLink (..),
|
||||
AConnectionLink (..),
|
||||
SimplexNameInfo (..),
|
||||
SimplexNameDomain (..),
|
||||
SimplexDomain (..),
|
||||
SimplexTLD (..),
|
||||
SimplexNameType (..),
|
||||
ConnShortLink (..),
|
||||
@@ -238,7 +238,7 @@ import Simplex.Messaging.Crypto.Ratchet
|
||||
)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..), fullDomainName, shortNameInfoStr)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..), fullDomainName, shortNameInfoStr)
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol
|
||||
( AProtocolType,
|
||||
@@ -1691,6 +1691,10 @@ ctTypeChar = \case
|
||||
CCTRelay -> 'R'
|
||||
{-# INLINE ctTypeChar #-}
|
||||
|
||||
instance StrEncoding ContactConnType where
|
||||
strEncode = B.singleton . ctTypeChar
|
||||
strP = A.anyChar >>= ctTypeP
|
||||
|
||||
-- the servers passed to this function should be all preset servers, not servers configured by the user.
|
||||
shortenShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m
|
||||
shortenShortLink presetSrvs = \case
|
||||
|
||||
@@ -1359,11 +1359,11 @@ deleteSndMsgsExpired db ttl limit = do
|
||||
|]
|
||||
(cutoffTs, limit)
|
||||
|
||||
createRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO ()
|
||||
createRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
|
||||
createRatchetX3dhKeys :: DB.Connection -> ConnId -> CR.RcvE2EPrivRatchetParams 'C.X448 -> 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, Maybe CR.RcvPrivRKEMParams))
|
||||
getRatchetX3dhKeys :: DB.Connection -> ConnId -> IO (Either StoreError (CR.RcvE2EPrivRatchetParams 'C.X448))
|
||||
getRatchetX3dhKeys db 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)
|
||||
@@ -1373,8 +1373,8 @@ getRatchetX3dhKeys db connId =
|
||||
_ -> Left SEX3dhKeysNotFound
|
||||
|
||||
-- used to remember new keys when starting ratchet re-synchronization
|
||||
setRatchetX3dhKeys :: DB.Connection -> ConnId -> C.PrivateKeyX448 -> C.PrivateKeyX448 -> Maybe CR.RcvPrivRKEMParams -> IO ()
|
||||
setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
|
||||
setRatchetX3dhKeys :: DB.Connection -> ConnId -> CR.RcvE2EPrivRatchetParams 'C.X448 -> IO ()
|
||||
setRatchetX3dhKeys db connId (x3dhPrivKey1, x3dhPrivKey2, pqPrivKem) =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
|
||||
@@ -50,7 +50,6 @@ import Data.Bits (xor)
|
||||
import Data.ByteArray (ScrubbedBytes)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Functor (($>))
|
||||
import Data.IORef
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
@@ -166,7 +166,7 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Protocol.Types
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport
|
||||
@@ -1054,7 +1054,7 @@ proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm p
|
||||
-- through `proxySMPCommand` and pattern-matches the expected RNAME response.
|
||||
-- Version-gated on the destination relay (mirrors `connectSMPProxiedRelay`):
|
||||
-- the client never sends RSLV to a relay that predates names support.
|
||||
proxyResolveName :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SimplexNameDomain -> ExceptT SMPClientError IO (Either ProxyClientError NameRecord)
|
||||
proxyResolveName :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SimplexDomain -> ExceptT SMPClientError IO (Either ProxyClientError NameRecord)
|
||||
proxyResolveName c nm proxiedRelay name
|
||||
| prVersion proxiedRelay >= namesSMPVersion =
|
||||
proxySMPCommand c nm proxiedRelay Nothing NoEntity (RSLV name) >>= \case
|
||||
@@ -1068,7 +1068,7 @@ proxyResolveName c nm proxiedRelay name
|
||||
-- proxy fallback in the agent. RSLV requires no entity ID or authorization
|
||||
-- (see `noAuthCmd` in Protocol.hs). Version-gated on the session here, not the
|
||||
-- encoder, so an old server never receives RSLV.
|
||||
directResolveName :: SMPClient -> NetworkRequestMode -> SimplexNameDomain -> ExceptT SMPClientError IO NameRecord
|
||||
directResolveName :: SMPClient -> NetworkRequestMode -> SimplexDomain -> ExceptT SMPClientError IO NameRecord
|
||||
directResolveName c nm name
|
||||
| thVersion (thParams c) >= namesSMPVersion =
|
||||
sendProtocolCommand c nm Nothing NoEntity (Cmd SResolver (RSLV name)) >>= \case
|
||||
|
||||
@@ -107,7 +107,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig
|
||||
{ smpCfg :: ProtocolClientConfig SMPVersion,
|
||||
reconnectInterval :: RetryInterval,
|
||||
persistErrorInterval :: NominalDiffTime,
|
||||
msgQSize :: Natural,
|
||||
msgQSize :: Maybe Natural,
|
||||
agentQSize :: Natural,
|
||||
agentSubsBatchSize :: Int,
|
||||
ownServerDomains :: [ByteString]
|
||||
@@ -124,7 +124,7 @@ defaultSMPClientAgentConfig =
|
||||
maxInterval = 10 * second
|
||||
},
|
||||
persistErrorInterval = 30, -- seconds
|
||||
msgQSize = 2048,
|
||||
msgQSize = Just 2048,
|
||||
agentQSize = 2048,
|
||||
agentSubsBatchSize = 1360,
|
||||
ownServerDomains = []
|
||||
@@ -138,7 +138,7 @@ data SMPClientAgent p = SMPClientAgent
|
||||
dbService :: Maybe DBService,
|
||||
active :: TVar Bool,
|
||||
startedAt :: UTCTime,
|
||||
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
|
||||
msgQ :: Maybe (TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg)),
|
||||
agentQ :: TBQueue SMPClientAgentEvent,
|
||||
randomDrg :: TVar ChaChaDRG,
|
||||
smpClients :: TMap SMPServer SMPClientVar,
|
||||
@@ -162,7 +162,8 @@ newSMPClientAgent :: SParty p -> SMPClientAgentConfig -> Maybe DBService -> TVar
|
||||
newSMPClientAgent agentParty agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} dbService randomDrg = do
|
||||
active <- newTVarIO True
|
||||
startedAt <- getCurrentTime
|
||||
msgQ <- newTBQueueIO msgQSize
|
||||
-- Only subscribing agents receive server transmissions, should not be created until processed to prevent deadlock.
|
||||
msgQ <- mapM newTBQueueIO msgQSize
|
||||
agentQ <- newTBQueueIO agentQSize
|
||||
smpClients <- TM.emptyIO
|
||||
smpSessions <- TM.emptyIO
|
||||
@@ -264,7 +265,7 @@ connectClient ca@SMPClientAgent {agentCfg, dbService, smpClients, smpSessions, m
|
||||
Nothing -> getClient cfg
|
||||
where
|
||||
cfg = smpCfg agentCfg
|
||||
getClient cfg' = getProtocolClient randomDrg NRMBackground (1, srv, Nothing) cfg' [] (Just msgQ) startedAt clientDisconnected
|
||||
getClient cfg' = getProtocolClient randomDrg NRMBackground (1, srv, Nothing) cfg' [] msgQ startedAt clientDisconnected
|
||||
|
||||
clientDisconnected :: SMPClient -> IO ()
|
||||
clientDisconnected smp = do
|
||||
|
||||
@@ -45,6 +45,7 @@ module Simplex.Messaging.Crypto.Ratchet
|
||||
AE2ERatchetParams (..),
|
||||
E2ERatchetParamsUri (..),
|
||||
E2ERatchetParams (..),
|
||||
RcvE2EPrivRatchetParams,
|
||||
VersionE2E,
|
||||
VersionRangeE2E,
|
||||
pattern VersionE2E,
|
||||
@@ -403,24 +404,30 @@ instance RatchetKEMStateI s => ToField (PrivRKEMParams s) where toField = toFiel
|
||||
|
||||
instance (Typeable s, RatchetKEMStateI s) => FromField (PrivRKEMParams s) where fromField = blobFieldDecoder smpDecode
|
||||
|
||||
type E2EPrivRatchetParams s a = (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s))\
|
||||
|
||||
type RcvE2EPrivRatchetParams a = E2EPrivRatchetParams 'RKSProposed a
|
||||
|
||||
type AE2EPrivRatchetParams a = (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams)
|
||||
|
||||
data UseKEM (s :: RatchetKEMState) where
|
||||
ProposeKEM :: UseKEM 'RKSProposed
|
||||
AcceptKEM :: KEMPublicKey -> UseKEM 'RKSAccepted
|
||||
|
||||
data AUseKEM = forall s. RatchetKEMStateI s => AUseKEM (SRatchetKEMState s) (UseKEM s)
|
||||
|
||||
mkRcvE2ERatchetParams :: VersionE2E -> (PrivateKey a, PrivateKey a, Maybe RcvPrivRKEMParams) -> RcvE2ERatchetParams a
|
||||
mkRcvE2ERatchetParams :: VersionE2E -> RcvE2EPrivRatchetParams a -> RcvE2ERatchetParams a
|
||||
mkRcvE2ERatchetParams v (pk1, pk2, pKem) = E2ERatchetParams v (publicKey pk1) (publicKey pk2) (mkKem <$> pKem)
|
||||
where
|
||||
mkKem :: RcvPrivRKEMParams -> RcvRKEMParams
|
||||
mkKem (PrivateRKParamsProposed (k, _)) = RKParamsProposed k
|
||||
|
||||
generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams s), E2ERatchetParams s a)
|
||||
generateE2EParams :: forall s a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe (UseKEM s) -> IO (E2EPrivRatchetParams s a, 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))
|
||||
pure ((pk1, pk2, snd <$> kems), E2ERatchetParams v k1 k2 (fst <$> kems))
|
||||
where
|
||||
kemParams :: IO (Maybe (RKEMParams s, PrivRKEMParams s))
|
||||
kemParams = case useKEM_ of
|
||||
@@ -436,7 +443,7 @@ generateE2EParams g v useKEM_ = do
|
||||
_ -> pure Nothing
|
||||
|
||||
-- used by party initiating connection, Bob in double-ratchet spec
|
||||
generateRcvE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> PQSupport -> IO (PrivateKey a, PrivateKey a, Maybe (PrivRKEMParams 'RKSProposed), E2ERatchetParams 'RKSProposed a)
|
||||
generateRcvE2EParams :: (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> PQSupport -> IO (RcvE2EPrivRatchetParams a, RcvE2ERatchetParams a)
|
||||
generateRcvE2EParams g v = generateE2EParams g v . proposeKEM_
|
||||
where
|
||||
proposeKEM_ :: PQSupport -> Maybe (UseKEM 'RKSProposed)
|
||||
@@ -445,14 +452,14 @@ generateRcvE2EParams g v = generateE2EParams g v . proposeKEM_
|
||||
PQSupportOff -> Nothing
|
||||
|
||||
-- used by party accepting connection, Alice in double-ratchet spec
|
||||
generateSndE2EParams :: forall a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe AUseKEM -> IO (PrivateKey a, PrivateKey a, Maybe APrivRKEMParams, AE2ERatchetParams a)
|
||||
generateSndE2EParams :: forall a. (AlgorithmI a, DhAlgorithm a) => TVar ChaChaDRG -> VersionE2E -> Maybe AUseKEM -> IO (AE2EPrivRatchetParams a, AE2ERatchetParams a)
|
||||
generateSndE2EParams g v = \case
|
||||
Nothing -> do
|
||||
(pk1, pk2, _, e2eParams) <- generateE2EParams g v Nothing
|
||||
pure (pk1, pk2, Nothing, AE2ERatchetParams SRKSProposed e2eParams)
|
||||
((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)
|
||||
((pk1, pk2, pKem), e2eParams) <- generateE2EParams g v (Just useKEM)
|
||||
pure ((pk1, pk2, APRKP s <$> pKem), AE2ERatchetParams s e2eParams)
|
||||
|
||||
data RatchetInitParams = RatchetInitParams
|
||||
{ assocData :: Str,
|
||||
@@ -464,9 +471,9 @@ data RatchetInitParams = RatchetInitParams
|
||||
deriving (Show)
|
||||
|
||||
-- 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)
|
||||
pqX3dhSnd :: DhAlgorithm a => AE2EPrivRatchetParams a -> E2ERatchetParams 'RKSProposed a -> Either CryptoError (RatchetInitParams, Maybe KEMKeyPair)
|
||||
-- 3. replied 2. received
|
||||
pqX3dhSnd spk1 spk2 spKem_ (E2ERatchetParams v rk1 rk2 rKem_) = do
|
||||
pqX3dhSnd (spk1, spk2, spKem_) (E2ERatchetParams 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_)
|
||||
@@ -480,9 +487,9 @@ pqX3dhSnd spk1 spk2 spKem_ (E2ERatchetParams v rk1 rk2 rKem_) = do
|
||||
_ -> Right (Nothing, Nothing)
|
||||
|
||||
-- this is used by the peer that created new connection, after receiving the reply
|
||||
pqX3dhRcv :: forall s a. (RatchetKEMStateI s, DhAlgorithm a) => PrivateKey a -> PrivateKey a -> Maybe (PrivRKEMParams 'RKSProposed) -> E2ERatchetParams s a -> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
|
||||
pqX3dhRcv :: forall s a. (RatchetKEMStateI s, DhAlgorithm a) => RcvE2EPrivRatchetParams a -> E2ERatchetParams s a -> ExceptT CryptoError IO (RatchetInitParams, Maybe KEMKeyPair)
|
||||
-- 1. sent 4. received in reply
|
||||
pqX3dhRcv rpk1 rpk2 rpKem_ (E2ERatchetParams v sk1 sk2 sKem_) = do
|
||||
pqX3dhRcv (rpk1, rpk2, rpKem_) (E2ERatchetParams 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_)
|
||||
|
||||
@@ -34,6 +34,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Functor (($>))
|
||||
import Data.Hashable (hash)
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.IntSet as IS
|
||||
@@ -526,10 +527,10 @@ subscribeNtfs NtfSubscriber {smpSubscribers, subscriberSeq, smpAgent = ca} st sm
|
||||
subscribeQueuesNtfs ca smpServer' [sub]
|
||||
|
||||
ntfSubscriber :: NtfSubscriber -> M ()
|
||||
ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
|
||||
ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ = msgQ_, agentQ}} =
|
||||
race_ receiveSMP receiveAgent
|
||||
where
|
||||
receiveSMP = do
|
||||
receiveSMP = forM_ msgQ_ $ \msgQ -> do
|
||||
st <- asks store
|
||||
ps <- asks pushServer
|
||||
stats <- asks serverStats
|
||||
@@ -643,9 +644,13 @@ pushNotification :: NtfPushServer -> Maybe T.Text -> OwnServer -> NtfTknRec -> P
|
||||
pushNotification s srvHost_ isOwn tkn@NtfTknRec {token = token@(DeviceToken pp _)} ntf =
|
||||
ifM
|
||||
(pushProviderAllowed token)
|
||||
(getOrCreatePushWorker s (srvHost_, pp) isOwn >>= atomically . (`writeTBQueue` (tkn, ntf)))
|
||||
(getOrCreatePushWorker s (srvHost_, pp, pushTokenShardId 8 tkn) isOwn >>= atomically . (`writeTBQueue` (tkn, ntf)))
|
||||
(logWarn "skipping disabled APNS test push provider")
|
||||
|
||||
pushTokenShardId :: Int -> NtfTknRec -> Int
|
||||
pushTokenShardId pushWorkersPerServer NtfTknRec {ntfTknId} =
|
||||
hash (unEntityId ntfTknId) `mod` pushWorkersPerServer
|
||||
|
||||
pushProviderAllowed :: DeviceToken -> M Bool
|
||||
pushProviderAllowed (DeviceToken PPApnsTest _) = asks (allowTestPushProvider . config)
|
||||
pushProviderAllowed _ = pure True
|
||||
@@ -657,8 +662,8 @@ guardPushProvider token action =
|
||||
action
|
||||
(pure $ NRErr $ CMD SMP.PROHIBITED)
|
||||
|
||||
getOrCreatePushWorker :: NtfPushServer -> (Maybe T.Text, PushProvider) -> OwnServer -> M (TBQueue (NtfTknRec, PushNotification))
|
||||
getOrCreatePushWorker s@NtfPushServer {pushWorkers, pushWorkerSeq, pushQSize} key@(srvHost_, _) isOwn = do
|
||||
getOrCreatePushWorker :: NtfPushServer -> (Maybe T.Text, PushProvider, Int) -> OwnServer -> M (TBQueue (NtfTknRec, PushNotification))
|
||||
getOrCreatePushWorker s@NtfPushServer {pushWorkers, pushWorkerSeq, pushQSize} key@(srvHost_, _, _) isOwn = do
|
||||
ts <- liftIO getCurrentTime
|
||||
withGetSessVar' pushWorkerSeq key pushWorkers ts createWorker existingWorker
|
||||
where
|
||||
@@ -704,7 +709,7 @@ runPushWorker s srvHost_ isOwn q = forever $ do
|
||||
| otherwise = liftIO $ logError "bad notification token status"
|
||||
deliverNotification :: NtfPostgresStore -> PushProvider -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ())
|
||||
deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf' = do
|
||||
(deliver, clientVar) <- getPushClient s pp
|
||||
(deliver, clientVar) <- getPushClient s pp tokenShardId
|
||||
runExceptT (deliver tkn ntf') >>= \case
|
||||
Right _ -> pure $ Right ()
|
||||
Left e -> case e of
|
||||
@@ -717,11 +722,12 @@ runPushWorker s srvHost_ isOwn q = forever $ do
|
||||
err e
|
||||
PPPermanentError -> err e
|
||||
where
|
||||
tokenShardId = pushTokenShardId 8 tkn
|
||||
retryDeliver :: PushClientVar -> Text -> IO (Either PushProviderError ())
|
||||
retryDeliver oldVar reason = do
|
||||
logWarn $ "retrying push (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> reason
|
||||
atomically $ removeSessVar oldVar pp (pushClients s)
|
||||
(deliver, _) <- getPushClient s pp
|
||||
atomically $ removeSessVar oldVar (pp, tokenShardId) (pushClients s)
|
||||
(deliver, _) <- getPushClient s pp tokenShardId
|
||||
runExceptT (deliver tkn ntf') >>= \case
|
||||
Right _ -> pure $ Right ()
|
||||
Left e -> case e of
|
||||
@@ -731,7 +737,7 @@ runPushWorker s srvHost_ isOwn q = forever $ do
|
||||
_ -> err e
|
||||
err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e
|
||||
|
||||
pushWorkersQLength :: TMap (Maybe T.Text, PushProvider) PushWorkerVar -> IO Natural
|
||||
pushWorkersQLength :: TMap (Maybe T.Text, PushProvider, Int) PushWorkerVar -> IO Natural
|
||||
pushWorkersQLength workers = do
|
||||
ws <- readTVarIO workers
|
||||
foldM addQLength 0 ws
|
||||
|
||||
@@ -30,11 +30,9 @@ module Simplex.Messaging.Notifications.Server.Env
|
||||
import Control.Concurrent (ThreadId)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Random
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
@@ -66,7 +64,6 @@ import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
|
||||
import Simplex.Messaging.Util (liftEitherWith, tshow)
|
||||
import Simplex.Messaging.Util ()
|
||||
import System.Exit (exitFailure)
|
||||
import System.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
|
||||
@@ -174,10 +171,10 @@ data SMPSubscriber = SMPSubscriber
|
||||
}
|
||||
|
||||
data NtfPushServer = NtfPushServer
|
||||
{ pushWorkers :: TMap (Maybe T.Text, PushProvider) PushWorkerVar,
|
||||
{ pushWorkers :: TMap (Maybe T.Text, PushProvider, Int) PushWorkerVar, -- Int is the worker shard
|
||||
pushWorkerSeq :: TVar Int,
|
||||
pushQSize :: Natural,
|
||||
pushClients :: TMap PushProvider PushClientVar,
|
||||
pushClients :: TMap (PushProvider, Int) PushClientVar,
|
||||
pushClientSeq :: TVar Int,
|
||||
apnsConfig :: APNSPushClientConfig
|
||||
}
|
||||
@@ -203,11 +200,11 @@ newNtfPushServer pushQSize apnsConfig = do
|
||||
-- | Single-flight access to the per-provider push client with bounded retry.
|
||||
-- The returned PushClientVar is the handle retryDeliver passes to removeSessVar to evict
|
||||
-- this specific instance before re-fetching.
|
||||
getPushClient :: NtfPushServer -> PushProvider -> IO (PushProviderClient, PushClientVar)
|
||||
getPushClient s@NtfPushServer {apnsConfig = APNSPushClientConfig {reconnectInterval}} pp =
|
||||
getPushClient :: NtfPushServer -> PushProvider -> Int -> IO (PushProviderClient, PushClientVar)
|
||||
getPushClient s@NtfPushServer {apnsConfig = APNSPushClientConfig {reconnectInterval}} pp tokenShardId =
|
||||
withRetryIntervalCount reconnectInterval $ \n _delay loop -> do
|
||||
ts <- getCurrentTime
|
||||
E.try (atomically (getSessVar (pushClientSeq s) pp (pushClients s) ts) >>= either (newPushClient s pp) waitForPushClient) >>= \case
|
||||
E.try (atomically (getSessVar (pushClientSeq s) (pp, tokenShardId) (pushClients s) ts) >>= either (newPushClient s pp tokenShardId) waitForPushClient) >>= \case
|
||||
Right result -> pure result
|
||||
Left e
|
||||
| n < 2 -> do
|
||||
@@ -215,15 +212,15 @@ getPushClient s@NtfPushServer {apnsConfig = APNSPushClientConfig {reconnectInter
|
||||
loop
|
||||
| otherwise -> E.throwIO e
|
||||
|
||||
newPushClient :: NtfPushServer -> PushProvider -> PushClientVar -> IO (PushProviderClient, PushClientVar)
|
||||
newPushClient NtfPushServer {pushClients, apnsConfig} pp v = do
|
||||
newPushClient :: NtfPushServer -> PushProvider -> Int -> PushClientVar -> IO (PushProviderClient, PushClientVar)
|
||||
newPushClient NtfPushServer {pushClients, apnsConfig} pp tokenShardId v = do
|
||||
r <- E.try $ case apnsProviderHost pp of
|
||||
Nothing -> pure $ \_ _ -> pure ()
|
||||
Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
|
||||
atomically $ do
|
||||
putTMVar (sessionVar v) r
|
||||
case r of
|
||||
Left _ -> removeSessVar v pp pushClients
|
||||
Left _ -> removeSessVar v (pp, tokenShardId) pushClients
|
||||
Right _ -> pure ()
|
||||
either E.throwIO (\c -> pure (c, v)) r
|
||||
|
||||
|
||||
@@ -270,7 +270,7 @@ import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol.Types
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.ServiceScheme
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain)
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
|
||||
import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
@@ -608,7 +608,7 @@ data Command (p :: Party) where
|
||||
-- - corrId: unique correlation ID between proxy and relay, also used as a nonce to encrypt forwarded transmission
|
||||
RFWD :: EncFwdTransmission -> Command ProxyService -- use CorrId as CbNonce, proxy to relay
|
||||
-- Resolve SimpleX name.
|
||||
RSLV :: SimplexNameDomain -> Command Resolver
|
||||
RSLV :: SimplexDomain -> Command Resolver
|
||||
|
||||
deriving instance Show (Command p)
|
||||
|
||||
@@ -1546,11 +1546,14 @@ queueIdHash = IdsHash . C.md5Hash . unEntityId
|
||||
{-# INLINE queueIdHash #-}
|
||||
|
||||
addServiceSubs :: (Int64, IdsHash) -> (Int64, IdsHash) -> (Int64, IdsHash)
|
||||
addServiceSubs (n', idsHash') (n, idsHash) = (n + n', idsHash <> idsHash')
|
||||
addServiceSubs (n', idsHash') (n, idsHash) =
|
||||
let !n'' = n + n'
|
||||
!h = idsHash <> idsHash'
|
||||
in (n'', h)
|
||||
|
||||
subtractServiceSubs :: (Int64, IdsHash) -> (Int64, IdsHash) -> (Int64, IdsHash)
|
||||
subtractServiceSubs (n', idsHash') (n, idsHash)
|
||||
| n > n' = (n - n', idsHash <> idsHash') -- concat is a reversible xor: (x `xor` y) `xor` y == x
|
||||
| n > n' = let !n'' = n - n'; !h = idsHash <> idsHash' in (n'', h) -- concat is a reversible xor: (x `xor` y) `xor` y == x
|
||||
| otherwise = (0, mempty)
|
||||
|
||||
data ProtocolErrorType = PECmdSyntax | PECmdUnknown | PESession | PEBlock
|
||||
|
||||
@@ -103,7 +103,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain)
|
||||
import Simplex.Messaging.Server.Control
|
||||
import Simplex.Messaging.Server.Env.STM as Env
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
@@ -1497,7 +1497,7 @@ client
|
||||
Just nenv -> pure (Just nenv)
|
||||
-- Runs on a forked thread so RSLV does not block other commands;
|
||||
-- concurrency is limited by serverResolverConcurrency in forkCmd.
|
||||
resolveNameMsg :: NamesEnv -> SimplexNameDomain -> M s BrokerMsg
|
||||
resolveNameMsg :: NamesEnv -> SimplexDomain -> M s BrokerMsg
|
||||
resolveNameMsg nenv d = do
|
||||
st <- asks (rslvStats . serverStats)
|
||||
(selector, msg) <-
|
||||
|
||||
@@ -604,6 +604,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
}
|
||||
},
|
||||
ownServerDomains = either (const []) textToOwnServers $ lookupValue "PROXY" "own_server_domains" ini,
|
||||
msgQSize = Nothing, -- to prevent accumulation of late responses, and deadlocks in SMP proxy
|
||||
persistErrorInterval = 30 -- seconds
|
||||
},
|
||||
allowSMPProxy = True,
|
||||
|
||||
@@ -30,7 +30,7 @@ import Simplex.Messaging.Server.Names.HttpResolver
|
||||
newResolverEnv,
|
||||
resolveHttp,
|
||||
)
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain, fullDomainName)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain, fullDomainName)
|
||||
import System.Timeout (timeout)
|
||||
|
||||
data NamesConfig = NamesConfig
|
||||
@@ -58,7 +58,7 @@ pingEndpoint :: NamesEnv -> IO (Either ResolverError ())
|
||||
pingEndpoint NamesEnv {resolverEnv, config} =
|
||||
fromMaybe (Left ResolverTimeout) <$> timeout (resolverTimeoutMs config * 1000) (healthHttp resolverEnv)
|
||||
|
||||
resolveName :: NamesEnv -> SimplexNameDomain -> IO (Either NameErrorType NameRecord)
|
||||
resolveName :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
|
||||
resolveName env d = do
|
||||
r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env d))
|
||||
case r of
|
||||
@@ -69,7 +69,7 @@ resolveName env d = do
|
||||
logError $ "[NAMES] resolver fetch raised " <> T.pack (E.displayException e)
|
||||
pure (Left (RESOLVER "resolver error"))
|
||||
|
||||
fetch :: NamesEnv -> SimplexNameDomain -> IO (Either NameErrorType NameRecord)
|
||||
fetch :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
|
||||
fetch NamesEnv {resolverEnv} d =
|
||||
first mapResolverError <$> resolveHttp resolverEnv (fullDomainName d)
|
||||
|
||||
|
||||
@@ -6,7 +6,7 @@
|
||||
|
||||
module Simplex.Messaging.SimplexName
|
||||
( SimplexNameInfo (..),
|
||||
SimplexNameDomain (..),
|
||||
SimplexDomain (..),
|
||||
SimplexTLD (..),
|
||||
SimplexNameType (..),
|
||||
fullDomainName,
|
||||
@@ -33,11 +33,11 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
|
||||
data SimplexNameInfo = SimplexNameInfo
|
||||
{ nameType :: SimplexNameType,
|
||||
nameDomain :: SimplexNameDomain
|
||||
nameDomain :: SimplexDomain
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SimplexNameDomain = SimplexNameDomain
|
||||
data SimplexDomain = SimplexDomain
|
||||
{ nameTLD :: SimplexTLD,
|
||||
domain :: Text,
|
||||
subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex
|
||||
@@ -87,9 +87,9 @@ instance StrEncoding SimplexNameInfo where
|
||||
infoP NTPublicGroup = SimplexNameInfo NTPublicGroup <$> (strP <|> bareName)
|
||||
infoP NTContact = SimplexNameInfo NTContact <$> strP
|
||||
bareName = parseBare . safeDecodeUtf8 <$?> boundedNonSpace
|
||||
parseBare s = (\name -> SimplexNameDomain TLDSimplex (T.toLower name) []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s
|
||||
parseBare s = (\name -> SimplexDomain TLDSimplex (T.toLower name) []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s
|
||||
|
||||
instance StrEncoding SimplexNameDomain where
|
||||
instance StrEncoding SimplexDomain where
|
||||
strEncode = encodeUtf8 . fullDomainName
|
||||
strP = parseDomain . safeDecodeUtf8 <$?> boundedNonSpace
|
||||
where
|
||||
@@ -97,18 +97,18 @@ instance StrEncoding SimplexNameDomain where
|
||||
mkDomain labels = case reverse lowered of
|
||||
[] -> Left "empty name"
|
||||
[_] -> Left "domain requires TLD"
|
||||
"simplex" : name : sub -> Right (SimplexNameDomain TLDSimplex name sub)
|
||||
"testing" : name : sub -> Right (SimplexNameDomain TLDTesting name sub)
|
||||
_ -> Right (SimplexNameDomain TLDWeb (T.intercalate "." lowered) [])
|
||||
"simplex" : name : sub -> Right (SimplexDomain TLDSimplex name sub)
|
||||
"testing" : name : sub -> Right (SimplexDomain TLDTesting name sub)
|
||||
_ -> Right (SimplexDomain TLDWeb (T.intercalate "." lowered) [])
|
||||
where
|
||||
lowered = map T.toLower labels
|
||||
|
||||
instance Encoding SimplexNameDomain where
|
||||
instance Encoding SimplexDomain where
|
||||
smpEncode = strEncode
|
||||
smpP = strP
|
||||
|
||||
fullDomainName :: SimplexNameDomain -> Text
|
||||
fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
|
||||
fullDomainName :: SimplexDomain -> Text
|
||||
fullDomainName SimplexDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
|
||||
where
|
||||
tld' = case nameTLD of
|
||||
TLDSimplex -> ["simplex"]
|
||||
@@ -117,21 +117,21 @@ fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate ".
|
||||
|
||||
shortNameInfoStr :: SimplexNameInfo -> Text
|
||||
shortNameInfoStr = \case
|
||||
SimplexNameInfo {nameType = NTPublicGroup, nameDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain
|
||||
SimplexNameInfo {nameType = NTPublicGroup, nameDomain = SimplexDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain
|
||||
info -> pfx <> fullDomainName (nameDomain info)
|
||||
where
|
||||
pfx = case nameType info of
|
||||
NTPublicGroup -> "#"
|
||||
NTContact -> "@"
|
||||
|
||||
instance ToField SimplexNameInfo where toField = toField . decodeLatin1 . strEncode
|
||||
instance ToField SimplexDomain where toField = toField . decodeLatin1 . strEncode
|
||||
|
||||
instance FromField SimplexNameInfo where fromField = fromTextField_ (eitherToMaybe . strDecode . encodeUtf8)
|
||||
instance FromField SimplexDomain where fromField = fromTextField_ (eitherToMaybe . strDecode . encodeUtf8)
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''SimplexNameDomain)
|
||||
$(J.deriveJSON defaultJSON ''SimplexDomain)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''SimplexNameInfo)
|
||||
|
||||
@@ -381,19 +381,19 @@ testX3dh :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
testX3dh _ = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
(pkBob1, pkBob2, Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v Nothing
|
||||
(pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
|
||||
let paramsBob = pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
|
||||
paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
|
||||
(pksBob@(_, _, Nothing), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v Nothing
|
||||
(pksAlice@(_, _, Nothing), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
|
||||
let paramsBob = pqX3dhSnd pksBob e2eAlice
|
||||
paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
paramsAlice `shouldBe` paramsBob
|
||||
|
||||
testX3dhV1 :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
testX3dhV1 _ = do
|
||||
g <- C.newRandom
|
||||
(pkBob1, pkBob2, Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g (VersionE2E 1) Nothing
|
||||
(pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g (VersionE2E 1) PQSupportOff
|
||||
let paramsBob = pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
|
||||
paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
|
||||
(pksBob@(_, _, Nothing), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g (VersionE2E 1) Nothing
|
||||
(pksAlice@(_, _, Nothing), e2eAlice) <- liftIO $ generateRcvE2EParams @a g (VersionE2E 1) PQSupportOff
|
||||
let paramsBob = pqX3dhSnd pksBob e2eAlice
|
||||
paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
paramsAlice `shouldBe` paramsBob
|
||||
|
||||
testPqX3dhProposeInReply :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
@@ -401,11 +401,11 @@ testPqX3dhProposeInReply _ = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (no KEM)
|
||||
(pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
|
||||
(pksAlice@(_, _, Nothing), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
|
||||
-- propose KEM in reply
|
||||
(pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSProposed ProposeKEM)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSProposed ProposeKEM)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
paramsAlice `compatibleRatchets` paramsBob
|
||||
|
||||
testPqX3dhProposeAccept :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
@@ -413,12 +413,12 @@ testPqX3dhProposeAccept _ = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (propose KEM)
|
||||
(pkAlice1, pkAlice2, pKemAlice_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
(pksAlice@(_, _, Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
E2ERatchetParams _ _ _ (Just (RKParamsProposed aliceKem)) <- pure e2eAlice
|
||||
-- accept KEM
|
||||
(pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM aliceKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKemAlice_ e2eBob
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM aliceKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
paramsAlice `compatibleRatchets` paramsBob
|
||||
|
||||
testPqX3dhProposeReject :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
@@ -426,12 +426,12 @@ testPqX3dhProposeReject _ = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (propose KEM)
|
||||
(pkAlice1, pkAlice2, pKemAlice_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
(pksAlice@(_, _, Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
E2ERatchetParams _ _ _ (Just (RKParamsProposed _)) <- pure e2eAlice
|
||||
-- reject KEM
|
||||
(pkBob1, pkBob2, Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v Nothing
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKemAlice_ e2eBob
|
||||
(pksBob@(_, _, Nothing), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v Nothing
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
paramsAlice `compatibleRatchets` paramsBob
|
||||
|
||||
testPqX3dhAcceptWithoutProposalError :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
@@ -439,26 +439,26 @@ testPqX3dhAcceptWithoutProposalError _ = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (no KEM)
|
||||
(pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
|
||||
(pksAlice@(_, _, Nothing), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOff
|
||||
E2ERatchetParams _ _ _ Nothing <- pure e2eAlice
|
||||
-- incorrectly accept KEM
|
||||
-- we don't have key in proposal, so we just generate it
|
||||
(k, _) <- sntrup761Keypair g
|
||||
(pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM k)
|
||||
pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice `shouldBe` Left C.CERatchetKEMState
|
||||
runExceptT (pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob) `shouldReturn` Left C.CERatchetKEMState
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM k)
|
||||
pqX3dhSnd pksBob e2eAlice `shouldBe` Left C.CERatchetKEMState
|
||||
runExceptT (pqX3dhRcv pksAlice e2eBob) `shouldReturn` Left C.CERatchetKEMState
|
||||
|
||||
testPqX3dhProposeAgain :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
testPqX3dhProposeAgain _ = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (propose KEM)
|
||||
(pkAlice1, pkAlice2, pKemAlice_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
(pksAlice@(_, _, Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
E2ERatchetParams _ _ _ (Just (RKParamsProposed _)) <- pure e2eAlice
|
||||
-- propose KEM again in reply - this is not an error
|
||||
(pkBob1, pkBob2, pKemBob_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSProposed ProposeKEM)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemBob_ e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKemAlice_ e2eBob
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSProposed ProposeKEM)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
paramsAlice `compatibleRatchets` paramsBob
|
||||
|
||||
compatibleRatchets :: (RatchetInitParams, x) -> (RatchetInitParams, x) -> Expectation
|
||||
@@ -515,10 +515,10 @@ initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a, Encry
|
||||
initRatchets = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
(pkBob1, pkBob2, _pKemParams@Nothing, AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v Nothing
|
||||
(pkAlice1, pkAlice2, _pKem@Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOff
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
|
||||
(pksBob@(_, _, Nothing), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v Nothing
|
||||
(pksAlice@(_, pkAlice2, Nothing), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOff
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
(_, pkBob3) <- atomically $ C.generateKeyPair g
|
||||
let vs = testRatchetVersions
|
||||
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
|
||||
@@ -530,12 +530,12 @@ initRatchetsKEMProposed = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (no KEM)
|
||||
(pkAlice1, pkAlice2, Nothing, e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOff
|
||||
(pksAlice@(_, pkAlice2, Nothing), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOff
|
||||
-- propose KEM in reply
|
||||
let useKem = AUseKEM SRKSProposed ProposeKEM
|
||||
(pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
(_, pkBob3) <- atomically $ C.generateKeyPair g
|
||||
let vs = testRatchetVersions
|
||||
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
|
||||
@@ -547,13 +547,13 @@ initRatchetsKEMAccepted = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (propose)
|
||||
(pkAlice1, pkAlice2, pKem_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOn
|
||||
(pksAlice@(_, pkAlice2, Just _), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOn
|
||||
E2ERatchetParams _ _ _ (Just (RKParamsProposed aliceKem)) <- pure e2eAlice
|
||||
-- accept
|
||||
let useKem = AUseKEM SRKSAccepted (AcceptKEM aliceKem)
|
||||
(pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
(_, pkBob3) <- atomically $ C.generateKeyPair g
|
||||
let vs = testRatchetVersions
|
||||
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
|
||||
@@ -565,12 +565,12 @@ initRatchetsKEMProposedAgain = do
|
||||
g <- C.newRandom
|
||||
let v = max pqRatchetE2EEncryptVersion currentE2EEncryptVersion
|
||||
-- initiate (propose KEM)
|
||||
(pkAlice1, pkAlice2, pKem_@(Just _), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOn
|
||||
(pksAlice@(_, pkAlice2, Just _), e2eAlice) <- liftIO $ generateRcvE2EParams g v PQSupportOn
|
||||
-- propose KEM again in reply
|
||||
let useKem = AUseKEM SRKSProposed ProposeKEM
|
||||
(pkBob1, pkBob2, pKemParams_@(Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams g v (Just useKem)
|
||||
Right paramsBob <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
(_, pkBob3) <- atomically $ C.generateKeyPair g
|
||||
let vs = testRatchetVersions
|
||||
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
|
||||
|
||||
@@ -1425,7 +1425,8 @@ testInvitationShortLinkAsync viaProxy a b = do
|
||||
connReq' `shouldBe` connReq
|
||||
linkUserData connData' `shouldBe` userData
|
||||
runRight $ do
|
||||
aId <- A.joinConnectionAsync b 1 "123" Nothing True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
|
||||
A.joinConnectionAsync b "123" False aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False
|
||||
("", _, CONF confId _ "bob's connInfo") <- get a
|
||||
allowConnection a bId confId "alice's connInfo"
|
||||
@@ -1662,7 +1663,7 @@ testPrepareCreateConnectionLink ps = withSmpServer ps $ withAgentClients2 $ \a b
|
||||
linkEntId <- atomically $ C.randomBytes 32 g
|
||||
runRight $ do
|
||||
(ccLink@(CCLink connReq (Just shortLink)), preparedParams) <-
|
||||
A.prepareConnectionLink a 1 rootKey linkEntId True Nothing
|
||||
A.prepareConnectionLink a 1 rootKey linkEntId True Nothing Nothing
|
||||
liftIO $ strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
||||
_ <- A.createConnectionForLink a NRMInteractive 1 True ccLink preparedParams userLinkData CR.IKPQOn SMSubscribe
|
||||
(FixedLinkData {linkConnReq = connReq', linkEntityId}, ContactLinkData _ userCtData') <- getConnShortLink b 1 shortLink
|
||||
@@ -2685,10 +2686,12 @@ receiveMsg c cId msgId msg = do
|
||||
testAsyncCommands :: SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
||||
testAsyncCommands sqSecured alice bob baseId =
|
||||
runRight_ $ do
|
||||
bobId <- createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
||||
bobId <- prepareConnectionToCreate alice 1 True SCMInvitation PQSupportOn
|
||||
createConnectionAsync alice "1" bobId True SCMInvitation IKPQOn SMSubscribe
|
||||
("1", bobId', INV (ACR _ qInfo)) <- get alice
|
||||
liftIO $ bobId' `shouldBe` bobId
|
||||
aliceId <- joinConnectionAsync bob 1 "2" Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
aliceId <- prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
joinConnectionAsync bob "2" False aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
("2", aliceId', JOINED sqSecured') <- get bob
|
||||
liftIO $ do
|
||||
aliceId' `shouldBe` aliceId
|
||||
@@ -2779,8 +2782,8 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
|
||||
liftIO $ qInfo' `shouldBe` qInfo
|
||||
liftIO $ userCtData' `shouldBe` userCtData
|
||||
-- join connection async using connId from getConnShortLinkAsync
|
||||
aliceId <- joinConnectionAsync bob 1 "2" (Just newId) True qInfo' "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ aliceId `shouldBe` newId
|
||||
joinConnectionAsync bob "2" True newId True qInfo' "bob's connInfo" PQSupportOn SMSubscribe
|
||||
let aliceId = newId
|
||||
("2", aliceId', JOINED False) <- get bob
|
||||
liftIO $ aliceId' `shouldBe` aliceId
|
||||
-- complete connection
|
||||
@@ -2796,7 +2799,10 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
|
||||
testAsyncCommandsRestore :: (ASrvTransport, AStoreType) -> IO ()
|
||||
testAsyncCommandsRestore ps = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
|
||||
bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
||||
bobId <- runRight $ do
|
||||
connId <- prepareConnectionToCreate alice 1 True SCMInvitation PQSupportOn
|
||||
createConnectionAsync alice "1" connId True SCMInvitation IKPQOn SMSubscribe
|
||||
pure connId
|
||||
liftIO $ noMessages alice "alice doesn't receive INV because server is down"
|
||||
disposeAgentClient alice
|
||||
withAgent 2 agentCfg initAgentServers testDB $ \alice' ->
|
||||
@@ -2812,7 +2818,8 @@ testAcceptContactAsync sqSecured alice bob baseId =
|
||||
(aliceId, sqSecuredJoin) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
||||
("", _, REQ invId _ "bob's connInfo") <- get alice
|
||||
bobId <- acceptContactAsync alice 1 "1" True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
bobId <- prepareConnectionToAccept alice 1 True invId PQSupportOn
|
||||
acceptContactAsync alice "1" bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
get alice =##> \case ("1", c, JOINED sqSecured') -> c == bobId && sqSecured' == sqSecured; _ -> False
|
||||
("", _, CONF confId _ "alice's connInfo") <- get bob
|
||||
allowConnection bob aliceId confId "bob's connInfo"
|
||||
@@ -3083,10 +3090,12 @@ testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do
|
||||
withAgent 1 cfg' initAgentServers testDB $ \a ->
|
||||
withAgent 2 cfg' initAgentServersSrv2 testDB2 $ \b -> do
|
||||
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
||||
bId <- createConnectionAsync a 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
||||
bId <- prepareConnectionToCreate a 1 True SCMInvitation PQSupportOn
|
||||
createConnectionAsync a "1" bId True SCMInvitation IKPQOn SMSubscribe
|
||||
("1", bId', INV (ACR _ qInfo)) <- get a
|
||||
liftIO $ bId' `shouldBe` bId
|
||||
aId <- joinConnectionAsync b 1 "2" Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
aId <- prepareConnectionToJoin b 1 True qInfo PQSupportOn
|
||||
joinConnectionAsync b "2" False aId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ threadDelay 500000
|
||||
ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
|
||||
pure (aId, bId)
|
||||
@@ -3128,10 +3137,12 @@ testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
withAgent 2 agentCfg initAgentServersSrv2 testDB2 $ \b -> do
|
||||
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
||||
bId <- createConnectionAsync a 1 "1" True SCMInvitation IKPQOn SMSubscribe
|
||||
bId <- prepareConnectionToCreate a 1 True SCMInvitation PQSupportOn
|
||||
createConnectionAsync a "1" bId True SCMInvitation IKPQOn SMSubscribe
|
||||
("1", bId', INV (ACR _ qInfo)) <- get a
|
||||
liftIO $ bId' `shouldBe` bId
|
||||
aId <- joinConnectionAsync b 1 "2" Nothing True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
aId <- prepareConnectionToJoin b 1 True qInfo PQSupportOn
|
||||
joinConnectionAsync b "2" False aId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ threadDelay 500000
|
||||
ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
|
||||
pure (aId, bId)
|
||||
|
||||
@@ -30,7 +30,7 @@ import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
|
||||
import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..), pattern NRMInteractive)
|
||||
import Simplex.Messaging.Protocol (SMPServer)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..))
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
|
||||
import Simplex.Messaging.Transport
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util (it)
|
||||
@@ -90,7 +90,7 @@ resolveNameTests = do
|
||||
testDirectNotFound :: HasCallStack => IO ()
|
||||
testDirectNotFound =
|
||||
withDirectResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
|
||||
@@ -98,7 +98,7 @@ testDirectNotFound =
|
||||
testProxyNotFound :: HasCallStack => IO ()
|
||||
testProxyNotFound =
|
||||
withProxyAndResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Left (SMP host (SMP.NAME SMP.NOT_FOUND)) | testPort `isInfixOf` host -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME NOT_FOUND)), got: " <> show r
|
||||
@@ -106,7 +106,7 @@ testProxyNotFound =
|
||||
testTestingTldNotFound :: HasCallStack => IO ()
|
||||
testTestingTldNotFound =
|
||||
withDirectResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDTesting "bob" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDTesting "bob" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
|
||||
@@ -114,7 +114,7 @@ testTestingTldNotFound =
|
||||
testWebTldNotFound :: HasCallStack => IO ()
|
||||
testWebTldNotFound =
|
||||
withDirectResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDWeb "example.com" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDWeb "example.com" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
|
||||
@@ -122,7 +122,7 @@ testWebTldNotFound =
|
||||
testNoResolver :: HasCallStack => IO ()
|
||||
testNoResolver =
|
||||
withNoResolver $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME SMP.NO_RESOLVER)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME NO_RESOLVER)), got: " <> show r
|
||||
@@ -130,7 +130,7 @@ testNoResolver =
|
||||
testNoNameServers :: HasCallStack => IO ()
|
||||
testNoNameServers =
|
||||
withNoNameServers $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Left NO_NAME_SERVERS -> pure ()
|
||||
_ -> expectationFailure $ "expected Left NO_NAME_SERVERS, got: " <> show r
|
||||
@@ -138,7 +138,7 @@ testNoNameServers =
|
||||
testBackendError :: HasCallStack => IO ()
|
||||
testBackendError =
|
||||
withDirectResolver (status502, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER ..))), got: " <> show r
|
||||
@@ -146,7 +146,7 @@ testBackendError =
|
||||
testDirectSuccess :: HasCallStack => IO ()
|
||||
testDirectSuccess =
|
||||
withDirectResolver (status200, J.encode testNameRecord) $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Right nr -> nr `shouldBe` testNameRecord
|
||||
_ -> expectationFailure $ "expected Right NameRecord, got: " <> show r
|
||||
|
||||
+3
-3
@@ -43,13 +43,13 @@ import Simplex.Messaging.Protocol
|
||||
tPut,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain)
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Version (mkVersionRange)
|
||||
import Test.Hspec hiding (fit, it)
|
||||
import Util (it)
|
||||
|
||||
domain :: Text -> SimplexNameDomain
|
||||
domain :: Text -> SimplexDomain
|
||||
domain = either error id . strDecode . encodeUtf8
|
||||
|
||||
withResolverServer :: (Status, LB.ByteString) -> IO a -> IO a
|
||||
@@ -63,7 +63,7 @@ withProxyAndResolver (st, body) runTest =
|
||||
withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ ->
|
||||
withSmpServerConfigOn (transport @TLS) (withNames port memCfg2) testPort2 (const runTest)
|
||||
|
||||
sendRslv :: Transport c => THandleSMP c 'TClient -> B.ByteString -> SimplexNameDomain -> IO (Transmission (Either ErrorType BrokerMsg))
|
||||
sendRslv :: Transport c => THandleSMP c 'TClient -> B.ByteString -> SimplexDomain -> IO (Transmission (Either ErrorType BrokerMsg))
|
||||
sendRslv h@THandle {params} corrId d = do
|
||||
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, NoEntity, Cmd SResolver (RSLV d))
|
||||
[Right ()] <- tPut h (Right (Nothing, tToSend) :| [])
|
||||
|
||||
+1
-1
@@ -275,7 +275,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
|
||||
smpServerVRange = supportedServerSMPRelayVRange,
|
||||
transportConfig = mkTransportServerConfig True (Just alpnSupportedSMPHandshakes) True,
|
||||
controlPort = Nothing,
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1, msgQSize = Nothing}, -- seconds
|
||||
allowSMPProxy = False,
|
||||
serverClientConcurrency = 2,
|
||||
serverResolverConcurrency = defaultNameResolverConcurrency,
|
||||
|
||||
@@ -27,7 +27,7 @@ import Simplex.Messaging.Server.Names
|
||||
resolveName,
|
||||
)
|
||||
import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..))
|
||||
import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..))
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
|
||||
import Test.Hspec
|
||||
|
||||
testNameRecord :: NameRecord
|
||||
@@ -51,7 +51,7 @@ smpNamesTests :: Spec
|
||||
smpNamesTests = do
|
||||
describe "NameRecord JSON (Protocol)" nameRecordEncodingSpec
|
||||
describe "ErrorType NAME wire encoding" errorWireSpec
|
||||
describe "Name parsing (SimplexNameDomain)" parseNameSpec
|
||||
describe "Name parsing (SimplexDomain)" parseNameSpec
|
||||
describe "HTTP resolver" resolverSpec
|
||||
describe "Resolver health probe" healthSpec
|
||||
describe "resolver_endpoint validation" validateUrlSpec
|
||||
@@ -136,7 +136,7 @@ parseNameSpec = do
|
||||
it "accepts a label of exactly 63 bytes" $
|
||||
parseN (T.replicate 63 "a" <> ".simplex") `shouldSatisfy` isRight
|
||||
where
|
||||
parseN :: T.Text -> Either String SimplexNameDomain
|
||||
parseN :: T.Text -> Either String SimplexDomain
|
||||
parseN = strDecode . encodeUtf8
|
||||
|
||||
resolverSpec :: Spec
|
||||
@@ -195,7 +195,7 @@ resolverSpec = do
|
||||
readIORef reqs `shouldReturn` [["resolve", "alice.simplex"]]
|
||||
|
||||
where
|
||||
aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
|
||||
aliceDomain = SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
|
||||
|
||||
healthSpec :: Spec
|
||||
healthSpec = do
|
||||
|
||||
+1
-1
@@ -9,7 +9,6 @@
|
||||
module XFTPClient where
|
||||
|
||||
import Control.Concurrent (ThreadId, threadDelay)
|
||||
import Control.Monad (void)
|
||||
import Data.String (fromString)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Network.Socket (ServiceName)
|
||||
@@ -25,6 +24,7 @@ import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
||||
import Simplex.Messaging.Transport.Server
|
||||
import Test.Hspec hiding (fit, it)
|
||||
#if defined(dbServerPostgres)
|
||||
import Control.Monad (void)
|
||||
import qualified Database.PostgreSQL.Simple as PSQL
|
||||
import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo)
|
||||
import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts)
|
||||
|
||||
Reference in New Issue
Block a user