mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-05 20:57:16 +00:00
agent: PQ rachet security code, store AD and pqAD in database, bulk reading (#1874)
* agent: PQ rachet security code, store AD and pqAD in database, bulk reading * rename to verify code * diff * refactor * query * reduce transactions * request binding * simplify * fix query and security code derivation --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
This commit is contained in:
co-authored by
Evgeny @ SimpleX Chat
parent
900c45ffae
commit
5294b7d8b7
@@ -194,6 +194,7 @@ library
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes
|
||||
else
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Agent.Store.SQLite
|
||||
@@ -248,6 +249,7 @@ library
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes
|
||||
Simplex.Messaging.Agent.Store.SQLite.Util
|
||||
if flag(client_postgres) || flag(server_postgres)
|
||||
exposed-modules:
|
||||
|
||||
@@ -106,7 +106,8 @@ module Simplex.Messaging.Agent
|
||||
deleteConnection,
|
||||
deleteConnections,
|
||||
getConnectionServers,
|
||||
getConnectionRatchetAdHash,
|
||||
getConnectionVerifyCodes,
|
||||
getConnectionsVerifyCodes,
|
||||
setProtocolServers,
|
||||
setUserEntitlement,
|
||||
checkUserServers,
|
||||
@@ -484,12 +485,12 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne
|
||||
-- the caller of joinConnection saves connection ID to the database.
|
||||
-- Instead of it we could send confirmation asynchronously, but then it would be harder to report
|
||||
-- "link deleted" (SMP AUTH) interactively, so this approach is simpler overall.
|
||||
prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId
|
||||
prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE (ConnId, ContactRequestBinding)
|
||||
prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs Nothing
|
||||
{-# INLINE prepareConnectionToJoin #-}
|
||||
|
||||
-- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID).
|
||||
prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> InvitationId -> PQSupport -> AE ConnId
|
||||
prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> InvitationId -> PQSupport -> AE (ConnId, ContactRequestBinding)
|
||||
prepareConnectionToAccept c userId enableNtfs = withAgentEnv c .: newConnToAccept c userId "" enableNtfs
|
||||
{-# INLINE prepareConnectionToAccept #-}
|
||||
|
||||
@@ -673,9 +674,13 @@ getConnectionServers c = withAgentEnv c . getConnectionServers' c
|
||||
{-# INLINE getConnectionServers #-}
|
||||
|
||||
-- | get connection ratchet associated data hash for verification (should match peer AD hash)
|
||||
getConnectionRatchetAdHash :: AgentClient -> ConnId -> AE ByteString
|
||||
getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
|
||||
{-# INLINE getConnectionRatchetAdHash #-}
|
||||
getConnectionVerifyCodes :: AgentClient -> ConnId -> AE ConnVerifyCodes
|
||||
getConnectionVerifyCodes c = withAgentEnv c . getConnectionVerifyCodes' c
|
||||
{-# INLINE getConnectionVerifyCodes #-}
|
||||
|
||||
getConnectionsVerifyCodes :: AgentClient -> [ConnId] -> AE (Map ConnId ConnVerifyCodes)
|
||||
getConnectionsVerifyCodes c = withAgentEnv c . getConnectionsVerifyCodes' c
|
||||
{-# INLINE getConnectionsVerifyCodes #-}
|
||||
|
||||
-- | Test protocol server
|
||||
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
@@ -1311,8 +1316,13 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userLinkData_ clientData pqIni
|
||||
SCMInvitation -> do
|
||||
g <- asks random
|
||||
let pqEnc = CR.initialPQEncryption (isJust userLinkData_) pqInitKeys
|
||||
(pks, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pks
|
||||
e2eRcvParams <- withStore' c $ \db -> do
|
||||
lockConnForUpdate db connId
|
||||
getRatchetX3dhKeys db connId >>= \case
|
||||
Right keys -> pure $ CR.mkRcvE2ERatchetParams (maxVersion e2eEncryptVRange) keys
|
||||
Left _ -> do
|
||||
(pks, e2eRcvParams) <- CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
|
||||
e2eRcvParams <$ createRatchetX3dhKeys db connId pks
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
setLinkDataRatchetKeys :: Maybe AddressRatchetKeys -> UserConnLinkData c -> UserConnLinkData c
|
||||
setLinkDataRatchetKeys ks = \case
|
||||
@@ -1370,30 +1380,47 @@ newQueueNtfSubscription c RcvQueue {userId, connId, server, clientNtfCreds} ntfS
|
||||
ns <- asks ntfSupervisor
|
||||
liftIO $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
|
||||
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Maybe UTCTime -> ConnectionRequestUri c -> PQSupport -> AM ConnId
|
||||
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Maybe UTCTime -> ConnectionRequestUri c -> PQSupport -> AM (ConnId, ContactRequestBinding)
|
||||
newConnToJoin c userId connId enableNtfs serviceRequestExpiresAt cReq pqSupport = case cReq of
|
||||
CRInvitationUri {} ->
|
||||
lift (compatibleInvitationUri cReq) >>= \case
|
||||
Just (_, _, aVersion) -> create aVersion
|
||||
Just (_, Compatible e2eRcvParams, aVersion) -> create aVersion $ Right e2eRcvParams
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
CRContactUri {} ->
|
||||
lift (compatibleContactUri cReq) >>= \case
|
||||
Just (_, _, aVersion) -> create aVersion
|
||||
Just (Compatible SMPQueueInfo {queueAddress = SMPQueueAddress {senderId}}, ratchet_, aVersion) ->
|
||||
create aVersion $ case ratchet_ of
|
||||
Just (_, Compatible e2eRcvParams) -> Right e2eRcvParams
|
||||
Nothing -> Left senderId
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
where
|
||||
create :: Compatible VersionSMPA -> AM ConnId
|
||||
create (Compatible connAgentVersion) = do
|
||||
create :: Compatible VersionSMPA -> Either SMP.SenderId (CR.RcvE2ERatchetParams 'C.X448) -> AM (ConnId, ContactRequestBinding)
|
||||
create (Compatible connAgentVersion) addrOrParams = do
|
||||
g <- asks random
|
||||
maxSupported <- asks $ maxVersion . e2eEncryptVRange . config
|
||||
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt}
|
||||
withStore c $ \db -> createNewConn db g cData SCMInvitation
|
||||
withStore c $ \db -> runExceptT $ do
|
||||
connId' <- ExceptT $ createNewConn db g cData SCMInvitation
|
||||
binding <- case addrOrParams of
|
||||
Right e2eRcvParams -> CRBRatchet . ratchetVerifyCodes . fst <$> createRatchet_ db g connId' maxSupported pqSupport e2eRcvParams
|
||||
Left senderId -> do
|
||||
let pqEnc = CR.initialPQEncryption False $ CR.joinContactInitialKeys pqSupport
|
||||
(pks, CR.E2ERatchetParams _ k1 k2 kem_) <- liftIO $ CR.generateRcvE2EParams g maxSupported pqEnc
|
||||
liftIO $ CRBRequest (requestCode k1 k2 kem_ senderId) <$ createRatchetX3dhKeys db connId' pks
|
||||
pure (connId', binding)
|
||||
|
||||
newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> PQSupport -> AM ConnId
|
||||
requestCode :: C.PublicKeyX448 -> C.PublicKeyX448 -> Maybe (CR.RKEMParams 'CR.RKSProposed) -> SMP.SenderId -> ByteString
|
||||
requestCode k1 k2 kem_ sndId = C.sha256Hash $ smpEncode (k1, k2, kem_, sndId)
|
||||
|
||||
newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> PQSupport -> AM (ConnId, ContactRequestBinding)
|
||||
newConnToAccept c userId connId enableNtfs invId pqSup = do
|
||||
Invitation {connReq} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId
|
||||
case connReq of
|
||||
CRInvitation cReq -> newConnToJoin c userId connId enableNtfs Nothing cReq pqSup
|
||||
CRInvitationDR dr -> (\ConnData {connId = connId'} -> connId') <$> newConnToAcceptDR c userId connId dr enableNtfs
|
||||
|
||||
CRInvitationDR dr@DRInvitation {ratchetState} -> do
|
||||
ConnData {connId = connId'} <- newConnToAcceptDR c userId connId dr enableNtfs
|
||||
pure (connId', CRBRatchet $ ratchetVerifyCodes ratchetState)
|
||||
|
||||
newConnToAcceptDR :: AgentClient -> UserId -> ConnId -> DRInvitation -> Bool -> AM ConnData
|
||||
newConnToAcceptDR c userId connId DRInvitation {agentVersion, pqSupport} enableNtfs = do
|
||||
g <- asks random
|
||||
@@ -1436,7 +1463,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSupport =
|
||||
(q, _) <- lift $ newSndQueue userId "" qInfo sndKey_
|
||||
withStore c $ \db -> runExceptT $ do
|
||||
liftIO $ lockConnForUpdate db connId
|
||||
e2eSndParams <- snd <$> createRatchet_ db g connId maxSupported pqSupport e2eRcvParams
|
||||
(_, e2eSndParams) <- liftIO (getSndRatchet db connId v) >>= either (const $ createRatchet_ db g connId maxSupported pqSupport e2eRcvParams) pure
|
||||
sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
|
||||
pure ((cData, sq'), (Just e2eSndParams, lnkId_))
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
@@ -1729,7 +1756,7 @@ serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) timeout_ doSend = do
|
||||
when (isNothing addrKeys_) $ throwE $ AGENT $ A_SERVICE ASENotDRAddress
|
||||
reqTimeout <- maybe (asks $ serviceRequestTimeout . config) pure timeout_
|
||||
expiresAt <- addUTCTime reqTimeout <$> liftIO getCurrentTime
|
||||
connId <- newConnToJoin c userId "" False (Just expiresAt) cReqUri PQSupportOn
|
||||
(connId, _) <- newConnToJoin c userId "" False (Just expiresAt) cReqUri PQSupportOn
|
||||
var <- atomically newEmptyTMVar
|
||||
atomically $ TM.insert connId var (serviceRequests c)
|
||||
r <- tryAllErrors $ do
|
||||
@@ -2989,10 +3016,12 @@ getConnectionServers' c connId = do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
connectionStats c conn
|
||||
|
||||
getConnectionRatchetAdHash' :: AgentClient -> ConnId -> AM ByteString
|
||||
getConnectionRatchetAdHash' c connId = do
|
||||
CR.Ratchet {rcAD = Str rcAD} <- withStore c (`getRatchet` connId)
|
||||
pure $ C.sha256Hash rcAD
|
||||
getConnectionVerifyCodes' :: AgentClient -> ConnId -> AM ConnVerifyCodes
|
||||
getConnectionVerifyCodes' c connId =
|
||||
getConnectionsVerifyCodes' c [connId] >>= maybe (throwE $ CONN NOT_FOUND "") pure . M.lookup connId
|
||||
|
||||
getConnectionsVerifyCodes' :: AgentClient -> [ConnId] -> AM (Map ConnId ConnVerifyCodes)
|
||||
getConnectionsVerifyCodes' c connIds = withStore' c (`getRatchetVerifyCodes` connIds)
|
||||
|
||||
connectionStats :: AgentClient -> Connection c -> AM ConnectionStats
|
||||
connectionStats c = \case
|
||||
@@ -4040,14 +4069,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
|
||||
enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} (EREADY lastExternalSndId)
|
||||
|
||||
smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM ()
|
||||
smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do
|
||||
smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData (CR.E2ERatchetParamsUri _ k1 k2 kem_)) cInfo = do
|
||||
logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret' srvMsgId
|
||||
case conn' of
|
||||
ContactConnection {} -> do
|
||||
ContactConnection _ RcvQueue {sndId} -> do
|
||||
-- show connection request even if invitaion via contact address is not compatible.
|
||||
invId <- storeInvitation (CRInvitation connReq) cInfo False
|
||||
let srvs = L.map qServer $ crSmpQueues crData
|
||||
notify $ REQ invId PQSupportOn srvs cInfo False
|
||||
notify $ REQ invId PQSupportOn srvs cInfo (CRBRequest $ requestCode k1 k2 kem_ sndId) False
|
||||
_ -> prohibited "inv: sent to message conn"
|
||||
|
||||
storeInvitation :: ContactRequest -> ConnInfo -> Bool -> AM InvitationId
|
||||
@@ -4074,7 +4103,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
|
||||
parseMessage "3" agentMsgBody >>= \case
|
||||
AgentConnInfoReply (replyQueue :| _) cInfo -> do
|
||||
invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) cInfo False
|
||||
notify $ REQ invId PQSupportOn (qServer replyQueue :| []) cInfo True
|
||||
notify $ REQ invId PQSupportOn (qServer replyQueue :| []) cInfo (CRBRatchet $ ratchetVerifyCodes ratchetState) True
|
||||
AgentServiceRequest (replyQueue :| _) sig_ payload ->
|
||||
case verifyServiceReq rc payload sig_ of
|
||||
Left err -> logError ("service request: " <> T.pack err) >> notify (ERR $ AGENT $ A_SERVICE ASEBadSignature)
|
||||
|
||||
@@ -166,6 +166,8 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnId,
|
||||
ConfirmationId,
|
||||
InvitationId,
|
||||
ConnVerifyCodes (..),
|
||||
ContactRequestBinding (..),
|
||||
MsgIntegrity (..),
|
||||
MsgErrorType (..),
|
||||
QueueStatus (..),
|
||||
@@ -404,7 +406,7 @@ data AEvent (e :: AEntity) where
|
||||
LINK :: ConnShortLink 'CMContact -> UserConnLinkData 'CMContact -> AEvent AEConn
|
||||
LDATA :: FixedLinkData 'CMContact -> ConnLinkData 'CMContact -> ConnectionRequestUri 'CMContact -> AEvent AEConn
|
||||
CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
|
||||
REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> Bool -> AEvent AEConn -- ConnInfo is from sender; Bool - rejection reason can be sent
|
||||
REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> ContactRequestBinding -> Bool -> AEvent AEConn -- ConnInfo is from sender; Bool - rejection reason can be sent
|
||||
SREQ :: InvitationId -> Maybe C.PublicKeyEd25519 -> MsgBody -> AEvent AEConn
|
||||
SSENT :: AgentMsgId -> Maybe SMPServer -> AEvent AEConn
|
||||
RJCT :: ConnInfo -> AEvent AEConn
|
||||
@@ -1372,6 +1374,15 @@ type ConfirmationId = ByteString
|
||||
|
||||
type InvitationId = ByteString
|
||||
|
||||
data ConnVerifyCodes = ConnVerifyCodes
|
||||
{ codeAD :: ByteString,
|
||||
codePQ :: Maybe ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ContactRequestBinding = CRBRatchet ConnVerifyCodes | CRBRequest ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
extraSMPServerHosts :: Map TransportHost TransportHost
|
||||
extraSMPServerHosts =
|
||||
M.fromList
|
||||
|
||||
@@ -165,6 +165,8 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
createRatchet,
|
||||
deleteRatchet,
|
||||
getRatchet,
|
||||
getRatchetVerifyCodes,
|
||||
ratchetVerifyCodes,
|
||||
getRatchetForUpdate,
|
||||
getSkippedMsgKeys,
|
||||
updateRatchet,
|
||||
@@ -291,6 +293,7 @@ import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (foldl', sortBy)
|
||||
@@ -1474,9 +1477,11 @@ createSndRatchet db connId ratchetState (CR.AE2ERatchetParams s (CR.E2ERatchetPa
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO ratchets
|
||||
(conn_id, ratchet_state, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem) VALUES (?, ?, ?, ?, ?)
|
||||
(conn_id, ratchet_state, rc_verify_code_ad, rc_verify_code_pq, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem) VALUES (?, ?, ?, ?, ?, ?, ?)
|
||||
ON CONFLICT (conn_id) DO UPDATE SET
|
||||
ratchet_state = EXCLUDED.ratchet_state,
|
||||
rc_verify_code_ad = EXCLUDED.rc_verify_code_ad,
|
||||
rc_verify_code_pq = EXCLUDED.rc_verify_code_pq,
|
||||
x3dh_priv_key_1 = NULL,
|
||||
x3dh_priv_key_2 = NULL,
|
||||
x3dh_pub_key_1 = EXCLUDED.x3dh_pub_key_1,
|
||||
@@ -1484,7 +1489,13 @@ createSndRatchet db connId ratchetState (CR.AE2ERatchetParams s (CR.E2ERatchetPa
|
||||
pq_priv_kem = NULL,
|
||||
pq_pub_kem = EXCLUDED.pq_pub_kem
|
||||
|]
|
||||
(connId, ratchetState, x3dhPubKey1, x3dhPubKey2, CR.ARKP s <$> pqPubKem)
|
||||
((connId, ratchetState) :. verifyCodesRow (ratchetVerifyCodes ratchetState) :. (x3dhPubKey1, x3dhPubKey2, CR.ARKP s <$> pqPubKem))
|
||||
|
||||
ratchetVerifyCodes :: RatchetX448 -> ConnVerifyCodes
|
||||
ratchetVerifyCodes CR.Ratchet {rcAD, rcVCPQ} = ConnVerifyCodes {codeAD = C.sha256Hash $ unStr rcAD, codePQ = unStr <$> rcVCPQ}
|
||||
|
||||
verifyCodesRow :: ConnVerifyCodes -> (Binary ByteString, Maybe (Binary ByteString))
|
||||
verifyCodesRow ConnVerifyCodes {codeAD, codePQ} = (Binary codeAD, Binary <$> codePQ)
|
||||
|
||||
getSndRatchet :: DB.Connection -> ConnId -> CR.VersionE2E -> IO (Either StoreError (RatchetX448, CR.AE2ERatchetParams 'C.X448))
|
||||
getSndRatchet db connId v =
|
||||
@@ -1505,10 +1516,12 @@ createRatchet db connId rc =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO ratchets (conn_id, ratchet_state)
|
||||
VALUES (?, ?)
|
||||
INSERT INTO ratchets (conn_id, ratchet_state, rc_verify_code_ad, rc_verify_code_pq)
|
||||
VALUES (?, ?, ?, ?)
|
||||
ON CONFLICT (conn_id) DO UPDATE SET
|
||||
ratchet_state = ?,
|
||||
ratchet_state = EXCLUDED.ratchet_state,
|
||||
rc_verify_code_ad = EXCLUDED.rc_verify_code_ad,
|
||||
rc_verify_code_pq = EXCLUDED.rc_verify_code_pq,
|
||||
x3dh_priv_key_1 = NULL,
|
||||
x3dh_priv_key_2 = NULL,
|
||||
x3dh_pub_key_1 = NULL,
|
||||
@@ -1516,7 +1529,42 @@ createRatchet db connId rc =
|
||||
pq_priv_kem = NULL,
|
||||
pq_pub_kem = NULL
|
||||
|]
|
||||
(connId, rc, rc)
|
||||
((connId, rc) :. verifyCodesRow (ratchetVerifyCodes rc))
|
||||
|
||||
getRatchetVerifyCodes :: DB.Connection -> [ConnId] -> IO (Map ConnId ConnVerifyCodes)
|
||||
getRatchetVerifyCodes db connIds = do
|
||||
(saved, computed) <- partitionEithers . mapMaybe rowCodes <$> selectCodes
|
||||
stored <- saveCodes computed
|
||||
pure $ M.fromList $ saved <> stored
|
||||
where
|
||||
rowCodes (connId, codeAD_, codePQ_, rc_) = case codeAD_ of
|
||||
Just codeAD -> Just $ Left $ toCodes (connId, codeAD, codePQ_)
|
||||
Nothing -> Right . (connId,) . ratchetVerifyCodes <$> rc_
|
||||
toCodes (connId, Binary codeAD, codePQ_) = (connId, ConnVerifyCodes {codeAD, codePQ = fromBinary <$> codePQ_})
|
||||
codesRow (connId, cs) = verifyCodesRow cs :. Only connId
|
||||
codesQuery :: Query
|
||||
codesQuery = "SELECT conn_id, rc_verify_code_ad, rc_verify_code_pq, CASE WHEN rc_verify_code_ad IS NULL THEN ratchet_state END FROM ratchets"
|
||||
selectCodes :: IO [(ConnId, Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe RatchetX448)]
|
||||
saveCodes :: [(ConnId, ConnVerifyCodes)] -> IO [(ConnId, ConnVerifyCodes)]
|
||||
#if defined(dbPostgres)
|
||||
selectCodes = DB.query db (codesQuery <> " WHERE conn_id IN ?") (Only (In connIds))
|
||||
saveCodes cs =
|
||||
map toCodes
|
||||
<$> DB.returning
|
||||
db
|
||||
[sql|
|
||||
UPDATE ratchets r
|
||||
SET rc_verify_code_ad = COALESCE(r.rc_verify_code_ad, (upd.rc_verify_code_ad :: BYTEA)),
|
||||
rc_verify_code_pq = CASE WHEN r.rc_verify_code_ad IS NULL THEN (upd.rc_verify_code_pq :: BYTEA) ELSE r.rc_verify_code_pq END
|
||||
FROM (VALUES(?, ?, ?)) AS upd(rc_verify_code_ad, rc_verify_code_pq, conn_id)
|
||||
WHERE r.conn_id = (upd.conn_id :: BYTEA)
|
||||
RETURNING r.conn_id, r.rc_verify_code_ad, r.rc_verify_code_pq
|
||||
|]
|
||||
(map codesRow cs)
|
||||
#else
|
||||
selectCodes = concat <$> mapM (DB.query db (codesQuery <> " WHERE conn_id = ?") . Only) connIds
|
||||
saveCodes cs = cs <$ unless (null cs) (DB.executeMany db "UPDATE ratchets SET rc_verify_code_ad = ?, rc_verify_code_pq = ? WHERE conn_id = ?" $ map codesRow cs)
|
||||
#endif
|
||||
|
||||
deleteRatchet :: DB.Connection -> ConnId -> IO ()
|
||||
deleteRatchet db connId =
|
||||
|
||||
@@ -13,6 +13,7 @@ module Simplex.Messaging.Agent.Store.Postgres.DB
|
||||
execute,
|
||||
execute_,
|
||||
executeMany,
|
||||
returning,
|
||||
query,
|
||||
query_,
|
||||
blobFieldDecoder,
|
||||
@@ -60,6 +61,10 @@ executeMany :: ToRow q => PSQL.Connection -> Query -> [q] -> IO ()
|
||||
executeMany db q qs = void $ PSQL.executeMany db q qs `E.catch` addSql q
|
||||
{-# INLINE executeMany #-}
|
||||
|
||||
returning :: (ToRow q, FromRow r) => PSQL.Connection -> Query -> [q] -> IO [r]
|
||||
returning db q qs = PSQL.returning db q qs `E.catch` addSql q
|
||||
{-# INLINE returning #-}
|
||||
|
||||
query :: (ToRow q, FromRow r) => PSQL.Connection -> Query -> q -> IO [r]
|
||||
query db q qs = PSQL.query db q qs `E.catch` addSql q
|
||||
{-# INLINE query #-}
|
||||
|
||||
@@ -15,6 +15,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attem
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
@@ -29,7 +30,8 @@ schemaMigrations =
|
||||
("20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts),
|
||||
("20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
|
||||
("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
|
||||
("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement)
|
||||
("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
|
||||
("20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
+21
@@ -0,0 +1,21 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20260919_ratchet_verify_codes :: Text
|
||||
m20260919_ratchet_verify_codes =
|
||||
[r|
|
||||
ALTER TABLE ratchets ADD COLUMN rc_verify_code_ad BYTEA;
|
||||
ALTER TABLE ratchets ADD COLUMN rc_verify_code_pq BYTEA;
|
||||
|]
|
||||
|
||||
down_m20260919_ratchet_verify_codes :: Text
|
||||
down_m20260919_ratchet_verify_codes =
|
||||
[r|
|
||||
ALTER TABLE ratchets DROP COLUMN rc_verify_code_pq;
|
||||
ALTER TABLE ratchets DROP COLUMN rc_verify_code_ad;
|
||||
|]
|
||||
@@ -448,7 +448,9 @@ CREATE TABLE smp_agent_test_protocol_schema.ratchets (
|
||||
x3dh_pub_key_1 bytea,
|
||||
x3dh_pub_key_2 bytea,
|
||||
pq_priv_kem bytea,
|
||||
pq_pub_kem bytea
|
||||
pq_pub_kem bytea,
|
||||
rc_verify_code_ad bytea,
|
||||
rc_verify_code_pq bytea
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -51,6 +51,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempt
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@@ -101,7 +102,8 @@ schemaMigrations =
|
||||
("m20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts),
|
||||
("m20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
|
||||
("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
|
||||
("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement)
|
||||
("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
|
||||
("m20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,20 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20260919_ratchet_verify_codes :: Query
|
||||
m20260919_ratchet_verify_codes =
|
||||
[sql|
|
||||
ALTER TABLE ratchets ADD COLUMN rc_verify_code_ad BLOB;
|
||||
ALTER TABLE ratchets ADD COLUMN rc_verify_code_pq BLOB;
|
||||
|]
|
||||
|
||||
down_m20260919_ratchet_verify_codes :: Query
|
||||
down_m20260919_ratchet_verify_codes =
|
||||
[sql|
|
||||
ALTER TABLE ratchets DROP COLUMN rc_verify_code_pq;
|
||||
ALTER TABLE ratchets DROP COLUMN rc_verify_code_ad;
|
||||
|]
|
||||
@@ -182,7 +182,9 @@ CREATE TABLE ratchets(
|
||||
x3dh_pub_key_1 BLOB,
|
||||
x3dh_pub_key_2 BLOB,
|
||||
pq_priv_kem BLOB,
|
||||
pq_pub_kem BLOB
|
||||
pq_pub_kem BLOB,
|
||||
rc_verify_code_ad BLOB,
|
||||
rc_verify_code_pq BLOB
|
||||
) WITHOUT ROWID, STRICT;
|
||||
CREATE TABLE skipped_messages(
|
||||
skipped_message_id INTEGER PRIMARY KEY,
|
||||
|
||||
@@ -451,6 +451,7 @@ generateSndE2EParams g v = \case
|
||||
|
||||
data RatchetInitParams = RatchetInitParams
|
||||
{ assocData :: Str,
|
||||
rcVerifyCodePQ :: Str,
|
||||
ratchetKey :: RatchetKey,
|
||||
sndHK :: HeaderKey,
|
||||
rcvNextHK :: HeaderKey,
|
||||
@@ -493,14 +494,14 @@ pqX3dhRcv (rpk1, rpk2, rpKem_) (E2ERatchetParams _ sk1 sk2 sKem_) = do
|
||||
|
||||
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}
|
||||
RatchetInitParams {assocData, rcVerifyCodePQ = Str vcPQ, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk, kemAccepted}
|
||||
where
|
||||
assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1
|
||||
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"
|
||||
salt = B.replicate 64 '\0'
|
||||
(hk, nhk, sk) = hkdf3 salt dhs "SimpleXX3DH"
|
||||
vcPQ = hkdf salt dhs "SimpleXVerifyCode" 32
|
||||
|
||||
type RatchetX448 = Ratchet 'X448
|
||||
|
||||
@@ -509,6 +510,8 @@ data Ratchet a = Ratchet
|
||||
rcVersion :: RatchetVersions,
|
||||
-- associated data - must be the same in both parties ratchets
|
||||
rcAD :: Str,
|
||||
-- verification code covering all handshake keys, absent in the ratchets created before it was added
|
||||
rcVCPQ :: Maybe Str,
|
||||
rcDHRs :: PrivateKey a,
|
||||
rcKEM :: Maybe RatchetKEM,
|
||||
rcSupportKEM :: PQSupport, -- defines header size, can only be enabled once
|
||||
@@ -637,13 +640,14 @@ instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
|
||||
-- @
|
||||
initSndRatchet ::
|
||||
forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PublicKey a -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> Ratchet a
|
||||
initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) = do
|
||||
initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, rcVerifyCodePQ, 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)
|
||||
pqOn = isJust rcPQRs_
|
||||
in Ratchet
|
||||
{ rcVersion,
|
||||
rcAD = assocData,
|
||||
rcVCPQ = Just rcVerifyCodePQ,
|
||||
rcDHRs,
|
||||
rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_,
|
||||
rcSupportKEM = PQSupport pqOn,
|
||||
@@ -668,10 +672,11 @@ initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, ratchetKey
|
||||
-- as part of the connection request and random salt was received from the sender.
|
||||
initRcvRatchet ::
|
||||
forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> PQSupport -> Ratchet a
|
||||
initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) pqSupport =
|
||||
initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) pqSupport =
|
||||
Ratchet
|
||||
{ rcVersion,
|
||||
rcAD = assocData,
|
||||
rcVCPQ = Just rcVerifyCodePQ,
|
||||
rcDHRs,
|
||||
-- rcKEM:
|
||||
-- state.PQRs = bob_pq_kem_key_pair
|
||||
|
||||
@@ -53,6 +53,7 @@ doubleRatchetTests = do
|
||||
it "should propose KEM during agreement, but no shared secret" $ testAlgs testPqX3dhProposeInReply
|
||||
it "should agree shared secret using KEM" $ testAlgs testPqX3dhProposeAccept
|
||||
it "should reject proposed KEM in reply" $ testAlgs testPqX3dhProposeReject
|
||||
it "should agree different PQ associated data with substituted KEM key" $ testAlgs testPqX3dhSubstitutedKem
|
||||
it "should allow second proposal in reply" $ testAlgs testPqX3dhProposeAgain
|
||||
describe "hybrid KEM key agreement errors" $ do
|
||||
it "should fail if reply contains acceptance without proposal" $ testAlgs testPqX3dhAcceptWithoutProposalError
|
||||
@@ -362,6 +363,7 @@ testDecodeV2RatchetJSON :: IO ()
|
||||
testDecodeV2RatchetJSON = do
|
||||
let v2RatchetJSON = "{\"rcVersion\":[2,2],\"rcAD\":\"2GEJrq48TmQse6NR16I-hrI0tSySZQ57E_g46nDceAPRAiF6j0drq26RTE7be6X7uiB4RaGJGf4QRXzcYuVtWw==\",\"rcDHRs\":\"TUM0Q0FRQXdCUVlESzJWdUJDSUVJRkNYbUxtSHQ3SUNfeHpGTi1Qb3ZqTVQ3S2p6XzZlZlBjOG9fRFY2RWxKOQ==\",\"rcRK\":\"BOX2X7YW5qDSp2XknY_lqacSrtDqQNPvS6iJlZIs3G0=\",\"rcNs\":0,\"rcNr\":0,\"rcPN\":0,\"rcNHKs\":\"IMouSkXUvzT_mo0WM-pqEUK09-HTLk9WOTCFQglyQxU=\",\"rcNHKr\":\"g-tus1clYPV0rGlzkf5a959tUqDYQVZ1FpcPeXdKwxI=\"}"
|
||||
Right (r :: Ratchet X25519) <- pure $ J.eitherDecodeStrict' v2RatchetJSON
|
||||
rcVCPQ r `shouldBe` Nothing
|
||||
rcSupportKEM r `shouldBe` PQSupportOff
|
||||
rcEnableKEM r `shouldBe` PQEncOff
|
||||
rcSndKEM r `shouldBe` PQEncOff
|
||||
@@ -417,6 +419,18 @@ testPqX3dhProposeAccept _ = do
|
||||
Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
paramsAlice `compatibleRatchets` paramsBob
|
||||
|
||||
testPqX3dhSubstitutedKem :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
testPqX3dhSubstitutedKem _ = do
|
||||
g <- C.newRandom
|
||||
let v = currentE2EEncryptVersion
|
||||
(pksAlice@(_, _, Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
(_, E2ERatchetParams _ _ _ (Just (RKParamsProposed mallorysKem))) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
|
||||
(pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM mallorysKem)
|
||||
Right (paramsBob, _) <- pure $ pqX3dhSnd pksBob e2eAlice
|
||||
Right (paramsAlice, _) <- runExceptT $ pqX3dhRcv pksAlice e2eBob
|
||||
assocData paramsAlice `shouldBe` assocData paramsBob
|
||||
rcVerifyCodePQ paramsAlice `shouldNotBe` rcVerifyCodePQ paramsBob
|
||||
|
||||
testPqX3dhProposeReject :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
|
||||
testPqX3dhProposeReject _ = do
|
||||
g <- C.newRandom
|
||||
@@ -459,9 +473,9 @@ testPqX3dhProposeAgain _ = do
|
||||
|
||||
compatibleRatchets :: (RatchetInitParams, x) -> (RatchetInitParams, x) -> Expectation
|
||||
compatibleRatchets
|
||||
(RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, _)
|
||||
(RatchetInitParams {assocData = ad, ratchetKey = rk, sndHK = shk, rcvNextHK = rnhk, kemAccepted = ka}, _) = do
|
||||
assocData == ad && ratchetKey == rk && sndHK == shk && rcvNextHK == rnhk `shouldBe` True
|
||||
(RatchetInitParams {assocData, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, _)
|
||||
(RatchetInitParams {assocData = ad, rcVerifyCodePQ = vcPQ, ratchetKey = rk, sndHK = shk, rcvNextHK = rnhk, kemAccepted = ka}, _) = do
|
||||
assocData == ad && rcVerifyCodePQ == vcPQ && ratchetKey == rk && sndHK == shk && rcvNextHK == rnhk `shouldBe` True
|
||||
case (kemAccepted, ka) of
|
||||
(Just RatchetKEMAccepted {rcPQRr, rcPQRss, rcPQRct}, Just RatchetKEMAccepted {rcPQRr = pqk, rcPQRss = pqss, rcPQRct = pqct}) ->
|
||||
pqk /= rcPQRr && pqss == rcPQRss && pqct == rcPQRct `shouldBe` True
|
||||
|
||||
@@ -204,7 +204,7 @@ pattern INFO :: ConnInfo -> AEvent 'AEConn
|
||||
pattern INFO connInfo = A.INFO PQSupportOn connInfo
|
||||
|
||||
pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> AEvent e
|
||||
pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo _
|
||||
pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo _ _
|
||||
|
||||
pattern CON :: AEvent 'AEConn
|
||||
pattern CON = A.CON PQEncOn
|
||||
@@ -293,7 +293,7 @@ createConnection c userId enableNtfs cMode clientData subMode = do
|
||||
|
||||
joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
|
||||
joinConnection c userId enableNtfs cReq connInfo subMode = do
|
||||
connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
|
||||
(connId, _) <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
|
||||
sndSecure <- A.joinConnection c NRMInteractive userId connId enableNtfs cReq connInfo PQSupportOn subMode
|
||||
pure (connId, sndSecure)
|
||||
|
||||
@@ -581,9 +581,9 @@ functionalAPITests ps = do
|
||||
it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation))
|
||||
it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` Left authErr
|
||||
it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` Left authErr
|
||||
describe "getRatchetAdHash" $
|
||||
it "should return the same data for both peers" $
|
||||
withSmpServer ps testRatchetAdHash
|
||||
describe "getConnectionVerifyCodes" $
|
||||
it "should return the same codes for both peers" $
|
||||
withSmpServer ps testConnectionVerifyCodes
|
||||
describe "Delivery receipts" $ do
|
||||
it "should send and receive delivery receipt" $ withSmpServer ps testDeliveryReceipts
|
||||
it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent ps
|
||||
@@ -755,7 +755,7 @@ runAgentClientTestPQ :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (A
|
||||
runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing aPQ False SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
sqSecured' <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
@@ -984,12 +984,12 @@ runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (Agent
|
||||
runAgentClientContactTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(_, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ False SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
sqSecuredJoin <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo" _) <- get alice
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo" _ _) <- get alice
|
||||
liftIO $ pqSup' `shouldBe` PQSupportOn
|
||||
bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
|
||||
(bobId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
|
||||
sqSecured' <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` sqSecured
|
||||
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
|
||||
@@ -1053,7 +1053,7 @@ runAgentClientContactDRTest_ asyncAccept asyncJoin addrIK useDR bPQ ps = withSmp
|
||||
Nothing -> expectationFailure "address must advertise DR ratchet keys"
|
||||
-- classic (non-DR) join drops the address keys from the request
|
||||
let connReqJoin = if useDR then connReq' else case connReq' of CRContactUri d _ -> CRContactUri d Nothing
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True connReqJoin bPQ
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReqJoin bPQ
|
||||
if asyncJoin
|
||||
then do
|
||||
A.joinConnectionAsync bob "join" False aliceId True connReqJoin "bob's connInfo" bPQ SMSubscribe
|
||||
@@ -1061,9 +1061,9 @@ runAgentClientContactDRTest_ asyncAccept asyncJoin addrIK useDR bPQ ps = withSmp
|
||||
else do
|
||||
sqSecuredJoin <- A.joinConnection bob NRMInteractive 1 aliceId True connReqJoin "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False
|
||||
("", _, A.REQ invId reqPQ _ "bob's connInfo" _) <- get alice
|
||||
("", _, A.REQ invId reqPQ _ "bob's connInfo" _ _) <- get alice
|
||||
liftIO $ reqPQ `shouldBe` PQSupportOn
|
||||
bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
(bobId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
if asyncAccept
|
||||
then do
|
||||
acceptContactAsync alice "accept" bobId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe
|
||||
@@ -1093,10 +1093,10 @@ runCreateConnectionDRTest_ asyncNew addrIK bPQ ps = withSmpServer ps $ withAgent
|
||||
liftIO $ case addrKeys_ of
|
||||
Just (_, CR.E2ERatchetParamsUri _ _ _ kem_) -> isJust kem_ `shouldBe` supportPQ (CR.initialPQEncryption False addrIK)
|
||||
Nothing -> expectationFailure "createConnection must advertise DR ratchet keys"
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True connReq bPQ
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReq bPQ
|
||||
void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" bPQ SMSubscribe
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
|
||||
bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
|
||||
(bobId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
void $ acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe
|
||||
("", _, A.CONF confId _ _ "alice's connInfo") <- get bob
|
||||
allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc
|
||||
@@ -1118,10 +1118,10 @@ testContactDRMatrix ps = do
|
||||
|
||||
joinContactDR :: HasCallStack => AgentClient -> AgentClient -> ConnectionRequestUri 'CMContact -> InitialKeys -> PQEncryption -> ExceptT AgentErrorType IO ()
|
||||
joinContactDR alice requester connReq addrIK pqEnc = do
|
||||
aliceId <- A.prepareConnectionToJoin requester 1 True connReq PQSupportOn
|
||||
(aliceId, _) <- A.prepareConnectionToJoin requester 1 True connReq PQSupportOn
|
||||
void $ A.joinConnection requester NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
|
||||
reqId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
|
||||
(reqId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
void $ acceptContact alice 1 reqId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe
|
||||
("", _, A.CONF confId _ _ "alice's connInfo") <- get requester
|
||||
allowConfirmGreet alice reqId requester aliceId confId addrIK pqEnc
|
||||
@@ -1149,7 +1149,7 @@ testAddressKeyRotation ps = withSmpServer ps $ withAgentClients3 $ \alice bob ca
|
||||
joinContactDR alice carol connReq2 addrIK pqEnc
|
||||
void $ A.setConnShortLink alice NRMInteractive addrConnId SCMContact userLinkData Nothing True (Just addrIK)
|
||||
void $ A.setConnShortLink alice NRMInteractive addrConnId SCMContact userLinkData Nothing True (Just addrIK)
|
||||
aId <- A.prepareConnectionToJoin bob 1 True connReq1 PQSupportOn
|
||||
(aId, _) <- A.prepareConnectionToJoin bob 1 True connReq1 PQSupportOn
|
||||
void $ A.joinConnection bob NRMInteractive 1 aId True connReq1 "bob's connInfo" PQSupportOn SMSubscribe
|
||||
get alice =##> \case ("", _, A.ERR _) -> True; _ -> False
|
||||
|
||||
@@ -1192,11 +1192,11 @@ testAddressUpdatePreservesDRKeys ps = withSmpServer ps $ withAgentClients2 $ \al
|
||||
liftIO $ shortLink' `shouldBe` shortLink
|
||||
(_, ContactLinkData _ updated, connReq') <- getConnShortLink bob 1 shortLink
|
||||
liftIO $ ratchetKeys updated `shouldBe` ratchetKeys published
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True connReq' bPQ
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReq' bPQ
|
||||
sqSecuredJoin <- A.joinConnection bob NRMInteractive 1 aliceId True connReq' "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
|
||||
bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
|
||||
(bobId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
_ <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe
|
||||
("", _, A.CONF confId _ _ "alice's connInfo") <- get bob
|
||||
allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc
|
||||
@@ -1216,10 +1216,10 @@ testAcceptContactDRResumeAfterOffline ps = withAgentClients2 $ \alice bob -> do
|
||||
(ccLink@(CCLink _ (Just shortLink)), preparedParams) <- A.prepareConnectionLink alice 1 rootKey linkEntId True Nothing connIK True Nothing
|
||||
_ <- A.createConnectionForLink alice NRMInteractive 1 True ccLink preparedParams (UserContactLinkData userCtData) SMSubscribe
|
||||
(_, _, connReq') <- getConnShortLink bob 1 shortLink
|
||||
aId <- A.prepareConnectionToJoin bob 1 True connReq' PQSupportOn
|
||||
(aId, _) <- A.prepareConnectionToJoin bob 1 True connReq' PQSupportOn
|
||||
_ <- A.joinConnection bob NRMInteractive 1 aId True connReq' "bob's connInfo" PQSupportOn SMSubscribe
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
|
||||
bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
|
||||
(bId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
|
||||
pure (bId, invId, aId)
|
||||
("", "", DOWN _ _) <- nGet alice
|
||||
("", "", DOWN _ _) <- nGet bob
|
||||
@@ -1244,12 +1244,12 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
|
||||
where
|
||||
msgId = subtract baseId . fst
|
||||
connectViaContact b pq qInfo = do
|
||||
aId <- A.prepareConnectionToJoin b 1 True qInfo pq
|
||||
(aId, _) <- A.prepareConnectionToJoin b 1 True qInfo pq
|
||||
sqSecuredJoin <- A.joinConnection b NRMInteractive 1 aId True qInfo "bob's connInfo" pq SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo" _) <- get alice
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo" _ _) <- get alice
|
||||
liftIO $ pqSup' `shouldBe` PQSupportOn
|
||||
bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
|
||||
(bId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
|
||||
sqSecuredAccept <- acceptContact alice 1 bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
|
||||
liftIO $ sqSecuredAccept `shouldBe` True
|
||||
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
|
||||
@@ -1290,10 +1290,10 @@ testRejectContactRequest :: HasCallStack => IO ()
|
||||
testRejectContactRequest =
|
||||
withAgentClients2 $ \alice bob -> runRight_ $ do
|
||||
(_addrConnId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn False SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
|
||||
("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _) <- get alice
|
||||
("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _ _) <- get alice
|
||||
Left (A.CMD PROHIBITED _) <- tryError $ rejectContact alice NRMInteractive 1 invId (Just "no rejection without double ratchet")
|
||||
rejectContact alice NRMInteractive 1 invId Nothing
|
||||
liftIO $ noMessages bob "nothing delivered to bob"
|
||||
@@ -1303,9 +1303,9 @@ testRejectContactRequestDR =
|
||||
withAgentClients2 $ \alice bob -> runRight_ $ do
|
||||
let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing}
|
||||
(_addrConnId, CCLink connReq _) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just userLinkData) Nothing IKPQOn True SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn
|
||||
void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
|
||||
rejectContact alice NRMInteractive 1 invId (Just "not now")
|
||||
("", _, A.RJCT "not now") <- get bob
|
||||
pure ()
|
||||
@@ -1315,9 +1315,9 @@ testRejectContactRequestDRAsync =
|
||||
withAgentClients2 $ \alice bob -> runRight_ $ do
|
||||
let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing}
|
||||
(_addrConnId, CCLink connReq _) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just userLinkData) Nothing IKPQOn True SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn
|
||||
void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
|
||||
("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
|
||||
rejectContactAsync alice "1" 1 invId (Just "not now")
|
||||
("", _, A.RJCT "not now") <- get bob
|
||||
pure ()
|
||||
@@ -1430,7 +1430,7 @@ testUpdateConnectionUserId =
|
||||
(connId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
||||
newUserId <- createUser alice False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
|
||||
_ <- changeConnectionUser alice 1 connId newUserId
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured' <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
@@ -1589,7 +1589,7 @@ testInvitationErrors ps restart = do
|
||||
b <- getAgentB
|
||||
(bId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMInvitation Nothing SMSubscribe
|
||||
("", "", DOWN _ [_]) <- nGet a
|
||||
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
||||
(aId, _) <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
||||
-- fails to secure the queue on testPort
|
||||
BROKER srv (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(testPort `isSuffixOf` srv) `shouldBe` True
|
||||
@@ -1659,7 +1659,7 @@ testContactErrors ps restart = do
|
||||
b <- getAgentB
|
||||
(contactId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMContact Nothing SMSubscribe
|
||||
("", "", DOWN _ [_]) <- nGet a
|
||||
aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
||||
(aId, _) <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
|
||||
-- fails to create queue on testPort2
|
||||
BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
(testPort2 `isSuffixOf` srv2) `shouldBe` True
|
||||
@@ -1681,10 +1681,10 @@ testContactErrors ps restart = do
|
||||
Right r -> error $ "unexpected result " <> show r
|
||||
Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend
|
||||
loopSend
|
||||
("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _) <- get a
|
||||
("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _ _) <- get a
|
||||
pure invId
|
||||
("", "", DOWN _ [_]) <- nGet a
|
||||
bId <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
(bId, _) <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
withServer2 ps $ do
|
||||
("", "", UP _ [_]) <- nGet b''
|
||||
let loopSecure = do
|
||||
@@ -1764,7 +1764,7 @@ testInvitationShortLink viaProxy a b =
|
||||
|
||||
testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO ()
|
||||
testJoinConn_ viaProxy sndSecure a bId b connReq = do
|
||||
aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
|
||||
(aId, _) <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
|
||||
sndSecure' <- A.joinConnection b NRMInteractive 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sndSecure' `shouldBe` sndSecure
|
||||
("", _, CONF confId _ "bob's connInfo") <- get a
|
||||
@@ -1792,7 +1792,7 @@ testInvitationShortLinkAsync viaProxy a b = do
|
||||
connReq' `shouldBe` connReq
|
||||
linkUserData connData' `shouldBe` userData
|
||||
runRight $ do
|
||||
aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
|
||||
(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
|
||||
@@ -1834,7 +1834,7 @@ testContactShortLink viaProxy a b =
|
||||
(aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
|
||||
liftIO $ sndSecure `shouldBe` False
|
||||
("", _, REQ invId _ "bob's connInfo") <- get a
|
||||
bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
(bId, _) <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
sndSecure' <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sndSecure' `shouldBe` True
|
||||
("", _, CONF confId _ "alice's connInfo") <- get b
|
||||
@@ -1887,7 +1887,7 @@ testAddContactShortLink viaProxy a b =
|
||||
(aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
|
||||
liftIO $ sndSecure `shouldBe` False
|
||||
("", _, REQ invId _ "bob's connInfo") <- get a
|
||||
bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
(bId, _) <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
sndSecure' <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sndSecure' `shouldBe` True
|
||||
("", _, CONF confId _ "alice's connInfo") <- get b
|
||||
@@ -2046,7 +2046,7 @@ testPrepareCreateConnectionLink ps = withSmpServer ps $ withAgentClients2 $ \a b
|
||||
(bId, sndSecure) <- joinConnection b 1 True connReq' "bob's connInfo" SMSubscribe
|
||||
liftIO $ sndSecure `shouldBe` False
|
||||
("", _, REQ invId _ "bob's connInfo") <- get a
|
||||
aId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
(aId, _) <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
|
||||
sndSecure' <- acceptContact a 1 aId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sndSecure' `shouldBe` True
|
||||
("", _, CONF confId _ "alice's connInfo") <- get b
|
||||
@@ -2749,7 +2749,7 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn
|
||||
makeConnectionForUsers_ :: HasCallStack => PQSupport -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
||||
makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do
|
||||
(bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive aliceUserId True True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) False SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
|
||||
sqSecured' <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
@@ -3031,7 +3031,7 @@ testAsyncCommands alice bob baseId =
|
||||
createConnectionAsync alice "1" bobId True SCMInvitation IKPQOn False SMSubscribe
|
||||
("1", bobId', INV (ACR _ qInfo)) <- get alice
|
||||
liftIO $ bobId' `shouldBe` bobId
|
||||
aliceId <- prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(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
|
||||
@@ -3101,7 +3101,7 @@ testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
|
||||
-- complete connection via contact address
|
||||
(aliceId, _) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
|
||||
("", _, REQ invId _ "bob's connInfo") <- get alice
|
||||
bobId <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
|
||||
(bobId, _) <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
|
||||
_ <- acceptContact alice 1 bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
("", _, CONF confId _ "alice's connInfo") <- get bob
|
||||
allowConnection bob aliceId confId "bob's connInfo"
|
||||
@@ -3129,7 +3129,7 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
|
||||
liftIO $ aliceId' `shouldBe` aliceId
|
||||
-- complete connection
|
||||
("", _, REQ invId _ "bob's connInfo") <- get alice
|
||||
bobId <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
|
||||
(bobId, _) <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
|
||||
_ <- acceptContact alice 1 bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
("", _, CONF confId _ "alice's connInfo") <- get bob
|
||||
allowConnection bob aliceId confId "bob's connInfo"
|
||||
@@ -3159,7 +3159,7 @@ testAcceptContactAsync 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 <- prepareConnectionToAccept alice 1 True invId PQSupportOn
|
||||
(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' == True; _ -> False
|
||||
("", _, CONF confId _ "alice's connInfo") <- get bob
|
||||
@@ -3440,7 +3440,7 @@ testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do
|
||||
createConnectionAsync a "1" bId True SCMInvitation IKPQOn False SMSubscribe
|
||||
("1", bId', INV (ACR _ qInfo)) <- get a
|
||||
liftIO $ bId' `shouldBe` bId
|
||||
aId <- prepareConnectionToJoin b 1 True qInfo PQSupportOn
|
||||
(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
|
||||
@@ -4023,13 +4023,23 @@ testServerInformation =
|
||||
serverCountry = Nothing
|
||||
}
|
||||
|
||||
testRatchetAdHash :: HasCallStack => IO ()
|
||||
testRatchetAdHash =
|
||||
testConnectionVerifyCodes :: HasCallStack => IO ()
|
||||
testConnectionVerifyCodes =
|
||||
withAgentClients2 $ \a b -> runRight_ $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
ad1 <- getConnectionRatchetAdHash a bId
|
||||
ad2 <- getConnectionRatchetAdHash b aId
|
||||
liftIO $ ad1 `shouldBe` ad2
|
||||
codes1 <- getConnectionVerifyCodes a bId
|
||||
codes2 <- getConnectionVerifyCodes b aId
|
||||
liftIO $ do
|
||||
codes1 `shouldBe` codes2
|
||||
codePQ codes1 `shouldNotBe` Nothing
|
||||
liftIO $ withTransaction (store $ agentEnv a) $ \db ->
|
||||
DB.execute_ db "UPDATE ratchets SET rc_verify_code_ad = NULL, rc_verify_code_pq = NULL"
|
||||
codes1' <- getConnectionVerifyCodes a bId
|
||||
liftIO $ codes1' `shouldBe` codes1
|
||||
liftIO $ withTransaction (store $ agentEnv a) $ \db ->
|
||||
DB.execute_ db "UPDATE ratchets SET ratchet_state = NULL"
|
||||
codes1'' <- getConnectionVerifyCodes a bId
|
||||
liftIO $ codes1'' `shouldBe` codes1
|
||||
|
||||
testDeliveryReceipts :: HasCallStack => IO ()
|
||||
testDeliveryReceipts =
|
||||
|
||||
@@ -229,7 +229,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
|
||||
withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
|
||||
withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
|
||||
(bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
@@ -285,7 +285,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
|
||||
-- otherwise the CONF messages would get mixed with MSG
|
||||
prePair alice bob = do
|
||||
(bobId, CCLink qInfo Nothing) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
|
||||
aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(aliceId, _) <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
confId <-
|
||||
@@ -344,7 +344,7 @@ agentViaProxyRetryOffline = do
|
||||
withServer $ \_ -> do
|
||||
(aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
|
||||
(bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
(aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
|
||||
Reference in New Issue
Block a user