mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-14 16:15:12 +00:00
smp protocol: create notification credentials via NEW command that creates the queue (#1586)
* smp protocol: create notification credentials via NEW command that creates the queue * create ntf subscription for queues created with ntf credetials * do not create ntf credentials when switching connection to another queue
This commit is contained in:
Evgeny
@@ -953,15 +953,12 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKey
|
||||
createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri)
|
||||
createRcvQueue nonce_ qd e2eKeys = do
|
||||
AgentConfig {smpClientVRange = vr} <- asks config
|
||||
-- TODO [notifications] send correct NTF credentials here
|
||||
-- let ntfCreds_ = Nothing
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue_ c nm userId connId srvWithAuth vr qd subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
ntfServer_ <- if enableNtfs then newQueueNtfServer else pure Nothing
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue_ c nm userId connId srvWithAuth vr qd (isJust ntfServer_) subMode nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
atomically $ incSMPServerStat c userId srv connCreated
|
||||
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
mapM_ (newQueueNtfSubscription c rq') ntfServer_
|
||||
pure (rq', qUri)
|
||||
createConnReq :: SMPQueueUri -> AM (ConnectionRequestUri c)
|
||||
createConnReq qUri = do
|
||||
@@ -981,7 +978,7 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKey
|
||||
nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g
|
||||
sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g
|
||||
AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config
|
||||
-- TODO [notifications] the remaining 24 bytes are reserved for notifier ID
|
||||
-- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol
|
||||
let sndId = SMP.EntityId $ B.take 24 $ C.sha3_384 corrId
|
||||
qm = case cMode of SCMContact -> QMContact; SCMInvitation -> QMMessaging
|
||||
qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey (Just qm)
|
||||
@@ -1015,6 +1012,21 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userData_ clientData pqInitKey
|
||||
CRInvitationUri crData e2eParams -> CRInvitationUri (updated crData) e2eParams
|
||||
in pure $ CCLink cReq' Nothing
|
||||
|
||||
newQueueNtfServer :: AM (Maybe NtfServer)
|
||||
newQueueNtfServer = fmap ntfServer_ . readTVarIO . ntfTkn =<< asks ntfSupervisor
|
||||
where
|
||||
ntfServer_ = \case
|
||||
Just tkn@NtfToken {ntfServer} | instantNotifications tkn -> Just ntfServer
|
||||
_ -> Nothing
|
||||
|
||||
newQueueNtfSubscription :: AgentClient -> RcvQueue -> NtfServer -> AM ()
|
||||
newQueueNtfSubscription c RcvQueue {userId, connId, server, clientNtfCreds} ntfServer = do
|
||||
forM_ clientNtfCreds $ \ClientNtfCreds {notifierId} -> do
|
||||
let sub = newNtfSubscription userId connId server (Just notifierId) ntfServer NASKey
|
||||
withStore c $ \db -> createNtfSubscription db sub (NSANtf NSACreate)
|
||||
ns <- asks ntfSupervisor
|
||||
liftIO $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
|
||||
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
|
||||
newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
|
||||
CRInvitationUri {} ->
|
||||
@@ -1192,15 +1204,13 @@ joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode
|
||||
|
||||
createReplyQueue :: AgentClient -> NetworkRequestMode -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM (SMPQueueInfo, Maybe ClientServiceId)
|
||||
createReplyQueue c nm ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
|
||||
-- TODO [notifications] send correct NTF credentials here
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode -- Nothing
|
||||
ntfServer_ <- if enableNtfs then newQueueNtfServer else pure Nothing
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv (versionToRange smpClientVersion) SCMInvitation (isJust ntfServer_) subMode
|
||||
atomically $ incSMPServerStat c userId (qServer rq) connCreated
|
||||
let qInfo = toVersionT qUri smpClientVersion
|
||||
rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
mapM_ (newQueueNtfSubscription c rq') ntfServer_
|
||||
pure (qInfo, clientServiceId rq')
|
||||
|
||||
-- | Approve confirmation (LET command) in Reader monad
|
||||
@@ -1256,8 +1266,7 @@ subscribeConnections' c connIds = do
|
||||
rcvRs <- lift $ connResults . fst <$> subscribeQueues c (concat $ M.elems rcvQs)
|
||||
rcvRs' <- storeClientServiceAssocs rcvRs
|
||||
ns <- asks ntfSupervisor
|
||||
tkn <- readTVarIO (ntfTkn ns)
|
||||
lift $ when (instantNotifications tkn) . void . forkIO . void $ sendNtfCreate ns rcvRs' cs
|
||||
lift $ whenM (liftIO $ hasInstantNotifications ns) . void . forkIO . void $ sendNtfCreate ns rcvRs' cs
|
||||
let rs = M.unions ([errs', subRs, rcvRs'] :: [Map ConnId (Either AgentErrorType (Maybe ClientServiceId))])
|
||||
notifyResultError rs
|
||||
pure rs
|
||||
@@ -1575,7 +1584,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
withStore' c $ \db -> deleteConnRcvQueue db rq'
|
||||
when (enableNtfs cData) $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
liftIO $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
let conn' = DuplexConnection cData (rq'' :| rqs') sqs
|
||||
notify $ SWITCH QDRcv SPCompleted $ connectionStats conn'
|
||||
_ -> internalErr "ICQDelete: cannot delete the only queue in connection"
|
||||
@@ -1990,8 +1999,9 @@ switchDuplexConnection c nm (DuplexConnection cData@ConnData {connId, userId} rq
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
|
||||
-- TODO [notifications] send correct NTF credentials here
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv' clientVRange SCMInvitation SMSubscribe -- Nothing
|
||||
-- TODO [notications] possible improvement would be to create ntf credentials here, to avoid creating them after rotation completes.
|
||||
-- The problem is that currently subscription already exists, and we do not support queues with credentials but without subscriptions.
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c nm userId connId srv' clientVRange SCMInvitation False SMSubscribe
|
||||
let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
lift $ addNewQueueSubscription c rq'' tSess sessId
|
||||
@@ -2399,7 +2409,7 @@ toggleConnectionNtfs' c connId enable = do
|
||||
withStore' c $ \db -> setConnectionNtfs db connId enable
|
||||
ns <- asks ntfSupervisor
|
||||
let cmd = if enable then NSCCreate else NSCSmpDelete
|
||||
atomically $ sendNtfSubCommand ns (cmd, [connId])
|
||||
liftIO $ sendNtfSubCommand ns (cmd, [connId])
|
||||
|
||||
withToken :: AgentClient -> NetworkRequestMode -> NtfToken -> Maybe (NtfTknStatus, NtfTknAction) -> (NtfTknStatus, Maybe NtfTknAction) -> AM a -> AM NtfTknStatus
|
||||
withToken c nm tkn@NtfToken {deviceToken, ntfMode} from_ (toStatus, toAction_) f = do
|
||||
|
||||
@@ -251,7 +251,6 @@ import Simplex.Messaging.Protocol
|
||||
ErrorType,
|
||||
MsgFlags (..),
|
||||
MsgId,
|
||||
NtfPublicAuthKey,
|
||||
NtfServer,
|
||||
NtfServerWithAuth,
|
||||
ProtoServer,
|
||||
@@ -261,12 +260,14 @@ import Simplex.Messaging.Protocol
|
||||
ProtocolType (..),
|
||||
ProtocolTypeI (..),
|
||||
QueueIdsKeys (..),
|
||||
ServerNtfCreds (..),
|
||||
RcvMessage (..),
|
||||
RcvNtfPublicDhKey,
|
||||
SMPMsgMeta (..),
|
||||
SProtocolType (..),
|
||||
SndPublicAuthKey,
|
||||
SubscriptionMode (..),
|
||||
NewNtfCreds (..),
|
||||
QueueReqData (..),
|
||||
QueueLinkData,
|
||||
UserProtocol,
|
||||
@@ -283,7 +284,7 @@ import Simplex.Messaging.Session
|
||||
import Simplex.Messaging.Agent.Store.Entity
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion)
|
||||
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion, newNtfCredsSMPVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
@@ -1240,8 +1241,7 @@ runSMPServerTest c nm userId (ProtoServerWithAuth srv auth) = do
|
||||
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
|
||||
(dhKey, _) <- atomically $ C.generateKeyPair g
|
||||
r <- runExceptT $ do
|
||||
-- TODO [notifications]
|
||||
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp nm Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) -- Nothing
|
||||
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp nm Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) Nothing
|
||||
liftError (testErr TSSecureQueue) $
|
||||
case queueMode of
|
||||
Just QMMessaging -> secureSndSMPQueue smp nm spKey sndId sKey
|
||||
@@ -1352,12 +1352,11 @@ getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode
|
||||
getSessionMode = fmap sessionMode . getNetworkConfig
|
||||
{-# INLINE getSessionMode #-}
|
||||
|
||||
-- TODO [notifications]
|
||||
newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c nm userId connId srv vRange cMode subMode = do
|
||||
newRcvQueue :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> Bool -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c nm userId connId srv vRange cMode enableNtfs subMode = do
|
||||
let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing
|
||||
e2eKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
newRcvQueue_ c nm userId connId srv vRange qrd subMode Nothing e2eKeys
|
||||
newRcvQueue_ c nm userId connId srv vRange qrd enableNtfs subMode Nothing e2eKeys
|
||||
|
||||
data ClntQueueReqData
|
||||
= CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData)))
|
||||
@@ -1374,21 +1373,21 @@ queueReqData = \case
|
||||
CQRMessaging d -> QRMessaging $ srvReq <$> d
|
||||
CQRContact d -> QRContact $ srvReq <$> d
|
||||
|
||||
newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode nonce_ (e2eDhKey, e2ePrivKey) = do
|
||||
newRcvQueue_ :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> Bool -> SubscriptionMode -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd enableNtfs subMode nonce_ (e2eDhKey, e2ePrivKey) = do
|
||||
C.AuthAlg a <- asks (rcvAuthAlg . config)
|
||||
g <- asks random
|
||||
rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
(dhKey, privDhKey) <- atomically $ C.generateKeyPair g
|
||||
logServer "-->" c srv NoEntity "NEW"
|
||||
tSess <- mkTransportSession c userId srv connId
|
||||
-- TODO [notifications]
|
||||
r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serviceId}) <-
|
||||
withClient c nm tSess $ \(SMPConnectedClient smp _) ->
|
||||
(thParams smp,) <$> createSMPQueue smp nm nonce_ rKeys dhKey auth subMode (queueReqData cqrd)
|
||||
(thParams', ntfKeys, qik@QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serviceId, serverNtfCreds}) <-
|
||||
withClient c nm tSess $ \(SMPConnectedClient smp _) -> do
|
||||
(ntfKeys, ntfCreds) <- liftIO $ mkNtfCreds a g smp
|
||||
(thParams smp,ntfKeys,) <$> createSMPQueue smp nm nonce_ rKeys dhKey auth subMode (queueReqData cqrd) ntfCreds
|
||||
-- TODO [certs rcv] validate that serviceId is the same as in the client session
|
||||
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
shortLink <- mkShortLinkCreds r
|
||||
shortLink <- mkShortLinkCreds thParams' qik
|
||||
let rq =
|
||||
RcvQueue
|
||||
{ userId,
|
||||
@@ -1409,14 +1408,26 @@ newRcvQueue_ c nm userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMo
|
||||
dbReplaceQueueId = Nothing,
|
||||
rcvSwchStatus = Nothing,
|
||||
smpClientVersion = maxVersion vRange,
|
||||
clientNtfCreds = Nothing,
|
||||
clientNtfCreds = mkClientNtfCreds ntfKeys serverNtfCreds,
|
||||
deleteErrors = 0
|
||||
}
|
||||
qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey queueMode
|
||||
pure (rq, qUri, tSess, sessionId thParams')
|
||||
where
|
||||
mkShortLinkCreds :: (THandleParams SMPVersion 'TClient, QueueIdsKeys) -> AM (Maybe ShortLinkCreds)
|
||||
mkShortLinkCreds (thParams', QIK {sndId, queueMode, linkId}) = case (cqrd, queueMode) of
|
||||
mkNtfCreds :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> TVar ChaChaDRG -> SMPClient -> IO (Maybe (C.AAuthKeyPair, C.PrivateKeyX25519), Maybe NewNtfCreds)
|
||||
mkNtfCreds a g smp
|
||||
| enableNtfs && thVersion (thParams smp) >= newNtfCredsSMPVersion = do
|
||||
authKeys@(k, _) <- atomically $ C.generateAuthKeyPair a g
|
||||
(dhk, dhpk) <- atomically $ C.generateKeyPair g
|
||||
pure (Just (authKeys, dhpk), Just $ NewNtfCreds k dhk)
|
||||
| otherwise = pure (Nothing, Nothing)
|
||||
mkClientNtfCreds :: Maybe (C.AAuthKeyPair, C.PrivateKeyX25519) -> Maybe ServerNtfCreds -> Maybe ClientNtfCreds
|
||||
mkClientNtfCreds ntfKeys serverNtfCreds = case (ntfKeys, serverNtfCreds) of
|
||||
(Just ((ntfPublicKey, ntfPrivateKey), dhpk), Just (ServerNtfCreds notifierId dhk')) ->
|
||||
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret = C.dh' dhk' dhpk}
|
||||
_ -> Nothing
|
||||
mkShortLinkCreds :: THandleParams SMPVersion 'TClient -> QueueIdsKeys -> AM (Maybe ShortLinkCreds)
|
||||
mkShortLinkCreds thParams' QIK {sndId, queueMode, linkId} = case (cqrd, queueMode) of
|
||||
(CQRMessaging ld, Just QMMessaging) ->
|
||||
withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (sndId', d)} ->
|
||||
if sndId == sndId'
|
||||
@@ -1807,7 +1818,7 @@ getQueueInfo c nm rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clie
|
||||
where
|
||||
enc = decodeLatin1 . B64.encode . unEntityId
|
||||
|
||||
agentNtfRegisterToken :: AgentClient -> NetworkRequestMode -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
|
||||
agentNtfRegisterToken :: AgentClient -> NetworkRequestMode -> NtfToken -> SMP.NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519)
|
||||
agentNtfRegisterToken c nm NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey =
|
||||
withClient c nm (0, ntfServer, Nothing) $ \ntf -> ntfRegisterToken ntf nm ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey)
|
||||
|
||||
|
||||
@@ -14,6 +14,7 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
|
||||
nsUpdateToken,
|
||||
nsRemoveNtfToken,
|
||||
sendNtfSubCommand,
|
||||
hasInstantNotifications,
|
||||
instantNotifications,
|
||||
deleteToken,
|
||||
closeNtfSupervisor,
|
||||
@@ -51,7 +52,7 @@ import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Protocol (NtfServer, sameSrvAddr)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow)
|
||||
import Simplex.Messaging.Util (diffToMicroseconds, threadDelay', tshow, whenM)
|
||||
import System.Random (randomR)
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent (forkIO)
|
||||
@@ -526,15 +527,19 @@ nsUpdateToken ns tkn = writeTVar (ntfTkn ns) $ Just tkn
|
||||
nsRemoveNtfToken :: NtfSupervisor -> STM ()
|
||||
nsRemoveNtfToken ns = writeTVar (ntfTkn ns) Nothing
|
||||
|
||||
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> STM ()
|
||||
sendNtfSubCommand ns cmd = do
|
||||
tkn <- readTVar (ntfTkn ns)
|
||||
when (instantNotifications tkn) $ writeTBQueue (ntfSubQ ns) cmd
|
||||
sendNtfSubCommand :: NtfSupervisor -> (NtfSupervisorCommand, NonEmpty ConnId) -> IO ()
|
||||
sendNtfSubCommand ns cmd =
|
||||
whenM (hasInstantNotifications ns) $ atomically $ writeTBQueue (ntfSubQ ns) cmd
|
||||
|
||||
instantNotifications :: Maybe NtfToken -> Bool
|
||||
instantNotifications = \case
|
||||
Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> True
|
||||
_ -> False
|
||||
hasInstantNotifications :: NtfSupervisor -> IO Bool
|
||||
hasInstantNotifications ns = do
|
||||
tkn <- readTVarIO $ ntfTkn ns
|
||||
pure $ maybe False instantNotifications tkn
|
||||
|
||||
instantNotifications :: NtfToken -> Bool
|
||||
instantNotifications NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} = True
|
||||
instantNotifications _ = False
|
||||
{-# INLINE instantNotifications #-}
|
||||
|
||||
deleteToken :: AgentClient -> NtfToken -> AM ()
|
||||
deleteToken c tkn@NtfToken {ntfServer, ntfTokenId, ntfPrivKey} = do
|
||||
|
||||
@@ -1969,15 +1969,22 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
|
||||
INSERT INTO rcv_queues
|
||||
( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
|
||||
snd_id, queue_mode, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
|
||||
link_id, link_key, link_priv_sig_key, link_enc_fixed_data
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
link_id, link_key, link_priv_sig_key, link_enc_fixed_data,
|
||||
ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
|]
|
||||
( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
|
||||
:. (sndId, queueMode, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
|
||||
:. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
|
||||
:. ntfCredsFields
|
||||
)
|
||||
-- TODO [certs rcv] save client service
|
||||
pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId, clientService = Nothing}
|
||||
where
|
||||
ntfCredsFields = case clientNtfCreds of
|
||||
Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} ->
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret)
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
-- * createSndConn helpers
|
||||
|
||||
|
||||
@@ -793,11 +793,10 @@ createSMPQueue ::
|
||||
Maybe BasicAuth ->
|
||||
SubscriptionMode ->
|
||||
QueueReqData ->
|
||||
-- TODO [notifications]
|
||||
-- Maybe NewNtfCreds ->
|
||||
Maybe NewNtfCreds ->
|
||||
ExceptT SMPClientError IO QueueIdsKeys
|
||||
createSMPQueue c nm nonce_ (rKey, rpKey) dhKey auth subMode qrd =
|
||||
sendProtocolCommand_ c nm nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd)) >>= \case
|
||||
createSMPQueue c nm nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds =
|
||||
sendProtocolCommand_ c nm nonce_ Nothing (Just rpKey) NoEntity (Cmd SCreator $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case
|
||||
IDS qik -> pure qik
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
|
||||
@@ -64,6 +64,8 @@ module Simplex.Messaging.Protocol
|
||||
EncFixedDataBytes,
|
||||
EncUserDataBytes,
|
||||
EncDataBytes (..),
|
||||
NewNtfCreds (..),
|
||||
ServerNtfCreds (..),
|
||||
Party (..),
|
||||
Cmd (..),
|
||||
QueueParty,
|
||||
@@ -583,9 +585,8 @@ data NewQueueReq = NewQueueReq
|
||||
rcvDhKey :: RcvPublicDhKey,
|
||||
auth_ :: Maybe BasicAuth,
|
||||
subMode :: SubscriptionMode,
|
||||
queueReqData :: Maybe QueueReqData
|
||||
-- TODO [notifications]
|
||||
-- ntfCreds :: Maybe NewNtfCreds
|
||||
queueReqData :: Maybe QueueReqData,
|
||||
ntfCreds :: Maybe NewNtfCreds
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@@ -629,8 +630,7 @@ instance ToField EncDataBytes where
|
||||
toField (EncDataBytes s) = toField (Binary s)
|
||||
{-# INLINE toField #-}
|
||||
|
||||
-- TODO [notifications]
|
||||
-- data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
|
||||
data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
|
||||
|
||||
instance StrEncoding SubscriptionMode where
|
||||
strEncode = \case
|
||||
@@ -661,10 +661,9 @@ instance Encoding QueueReqData where
|
||||
'C' -> QRContact <$> smpP
|
||||
_ -> fail "bad QueueReqData"
|
||||
|
||||
-- TODO [notifications]
|
||||
-- instance Encoding NewNtfCreds where
|
||||
-- smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
|
||||
-- smpP = NewNtfCreds <$> smpP <*> smpP
|
||||
instance Encoding NewNtfCreds where
|
||||
smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
|
||||
smpP = NewNtfCreds <$> smpP <*> smpP
|
||||
|
||||
newtype EncTransmission = EncTransmission ByteString
|
||||
deriving (Show)
|
||||
@@ -1397,19 +1396,17 @@ data QueueIdsKeys = QIK
|
||||
rcvPublicDhKey :: RcvPublicDhKey,
|
||||
queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
|
||||
linkId :: Maybe LinkId,
|
||||
serviceId :: Maybe ServiceId
|
||||
-- TODO [notifications]
|
||||
-- serverNtfCreds :: Maybe ServerNtfCreds
|
||||
serviceId :: Maybe ServiceId,
|
||||
serverNtfCreds :: Maybe ServerNtfCreds
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- TODO [notifications]
|
||||
-- data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
|
||||
-- deriving (Eq, Show)
|
||||
data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- instance Encoding ServerNtfCreds where
|
||||
-- smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey)
|
||||
-- smpP = ServerNtfCreds <$> smpP <*> smpP
|
||||
instance Encoding ServerNtfCreds where
|
||||
smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey)
|
||||
smpP = ServerNtfCreds <$> smpP <*> smpP
|
||||
|
||||
-- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
|
||||
--
|
||||
@@ -1654,7 +1651,8 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -
|
||||
instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
type Tag (Command p) = CommandTag p
|
||||
encodeProtocol v = \case
|
||||
NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData}
|
||||
NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
| v >= newNtfCredsSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds)
|
||||
| v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData)
|
||||
| v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData))
|
||||
| otherwise -> new <> auth <> e subMode
|
||||
@@ -1739,19 +1737,20 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
CT SCreator NEW_ -> Cmd SCreator <$> newCmd
|
||||
where
|
||||
newCmd
|
||||
| v >= shortLinksSMPVersion = new smpP smpP
|
||||
| v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP)
|
||||
| otherwise = new auth (pure Nothing)
|
||||
| v >= newNtfCredsSMPVersion = new smpP smpP smpP
|
||||
| v >= shortLinksSMPVersion = new smpP smpP nothing
|
||||
| v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP) nothing
|
||||
| otherwise = new auth nothing nothing
|
||||
where
|
||||
new p1 p2 = NEW <$> do
|
||||
nothing = pure Nothing
|
||||
new p1 p2 p3 = NEW <$> do
|
||||
rcvAuthKey <- _smpP
|
||||
rcvDhKey <- smpP
|
||||
auth_ <- p1
|
||||
subMode <- smpP
|
||||
queueReqData <- p2
|
||||
-- TODO [notifications]
|
||||
-- ntfCreds <- p3
|
||||
pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData} -- ntfCreds
|
||||
ntfCreds <- p3
|
||||
pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
auth = optional (A.char 'A' *> smpP)
|
||||
qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
|
||||
CT SRecipient tag ->
|
||||
@@ -1796,7 +1795,8 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
type Tag BrokerMsg = BrokerMsgTag
|
||||
encodeProtocol v = \case
|
||||
IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId}
|
||||
IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId, serverNtfCreds}
|
||||
| v >= newNtfCredsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId <> e serverNtfCreds
|
||||
| v >= serviceCertsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId
|
||||
| v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId
|
||||
| v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode)
|
||||
@@ -1837,23 +1837,23 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
where
|
||||
bodyP = EncRcvMsgBody . unTail <$> smpP
|
||||
IDS_
|
||||
| v >= serviceCertsSMPVersion -> ids smpP smpP smpP
|
||||
| v >= shortLinksSMPVersion -> ids smpP smpP nothing
|
||||
| v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing
|
||||
| otherwise -> ids nothing nothing nothing
|
||||
| v >= newNtfCredsSMPVersion -> ids smpP smpP smpP smpP
|
||||
| v >= serviceCertsSMPVersion -> ids smpP smpP smpP nothing
|
||||
| v >= shortLinksSMPVersion -> ids smpP smpP nothing nothing
|
||||
| v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing nothing
|
||||
| otherwise -> ids nothing nothing nothing nothing
|
||||
where
|
||||
qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
|
||||
nothing = pure Nothing
|
||||
ids p1 p2 p3 = do
|
||||
ids p1 p2 p3 p4 = do
|
||||
rcvId <- _smpP
|
||||
sndId <- smpP
|
||||
rcvPublicDhKey <- smpP
|
||||
queueMode <- p1
|
||||
linkId <- p2
|
||||
serviceId <- p3
|
||||
-- TODO [notifications]
|
||||
-- serverNtfCreds <- p3
|
||||
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId}
|
||||
serverNtfCreds <- p4
|
||||
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId, serverNtfCreds}
|
||||
LNK_ -> LNK <$> _smpP <*> smpP
|
||||
SOK_ -> SOK <$> _smpP
|
||||
SOKS_ -> SOKS <$> _smpP
|
||||
|
||||
@@ -1459,19 +1459,18 @@ client
|
||||
Cmd SRecipientService SUBS -> pure $ response $ err (CMD PROHIBITED) -- "TODO [certs rcv]"
|
||||
where
|
||||
createQueue :: NewQueueReq -> M s (Transmission BrokerMsg)
|
||||
createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData}
|
||||
createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds}
|
||||
| isJust clntServiceId && subMode == SMOnlyCreate = pure (corrId, entId, ERR $ CMD PROHIBITED)
|
||||
| otherwise = do
|
||||
g <- asks random
|
||||
idSize <- asks $ queueIdBytes . config
|
||||
updatedAt <- Just <$> liftIO getSystemDate
|
||||
(rcvPublicDhKey, privDhKey) <- atomically $ C.generateKeyPair g
|
||||
-- TODO [notifications]
|
||||
-- ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do
|
||||
-- (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
-- pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey)
|
||||
ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do
|
||||
(ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey)
|
||||
let randId = EntityId <$> atomically (C.randomBytes idSize g)
|
||||
-- TODO [notifications] the remaining 24 bytes are reserver for notifier ID
|
||||
-- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol
|
||||
sndId' = B.take 24 $ C.sha3_384 (bs corrId)
|
||||
tryCreate 0 = pure $ ERR INTERNAL
|
||||
tryCreate n = do
|
||||
@@ -1486,10 +1485,10 @@ client
|
||||
then pure $ ERR $ CMD PROHIBITED
|
||||
else do
|
||||
rcvId <- randId
|
||||
-- TODO [notifications]
|
||||
-- ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
|
||||
-- notifierId <- randId
|
||||
-- pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey)
|
||||
ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
|
||||
notifierId <- randId
|
||||
let ntfCreds = NtfCreds {notifierId, notifierKey, rcvNtfDhSecret, ntfServiceId = Nothing}
|
||||
pure (ntfCreds, ServerNtfCreds notifierId rcvPubDhKey)
|
||||
let queueMode = queueReqMode <$> queueReqData
|
||||
qr =
|
||||
QueueRec
|
||||
@@ -1499,8 +1498,7 @@ client
|
||||
senderKey = Nothing,
|
||||
queueMode,
|
||||
queueData,
|
||||
-- TODO [notifications]
|
||||
notifier = Nothing, -- fst <$> ntf,
|
||||
notifier = fst <$> ntf,
|
||||
status = EntityActive,
|
||||
updatedAt,
|
||||
rcvServiceId = clntServiceId
|
||||
@@ -1514,12 +1512,11 @@ client
|
||||
stats <- asks serverStats
|
||||
incStat $ qCreated stats
|
||||
incStat $ qCount stats
|
||||
-- TODO [notifications]
|
||||
-- when (isJust ntf) $ incStat $ ntfCreated stats
|
||||
when (isJust ntf) $ incStat $ ntfCreated stats
|
||||
case subMode of
|
||||
SMOnlyCreate -> pure ()
|
||||
SMSubscribe -> subscribeNewQueue rcvId qr -- no need to check if message is available, it's a new queue
|
||||
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = clntServiceId} -- , serverNtfCreds = snd <$> ntf
|
||||
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serviceId = clntServiceId, serverNtfCreds = snd <$> ntf}
|
||||
(corrId,entId,) <$> tryCreate (3 :: Int)
|
||||
|
||||
-- this check allows to support contact queues created prior to SKEY,
|
||||
@@ -1771,8 +1768,8 @@ client
|
||||
liftIO $ do
|
||||
mapM_ (updateStats stats False ts) deletedMsg_
|
||||
forM_ msg_ $ \msg -> do
|
||||
ts <- getSystemSeconds
|
||||
atomically $ setDelivered sub msg ts
|
||||
ts' <- getSystemSeconds
|
||||
atomically $ setDelivered sub msg ts'
|
||||
pure (corrId, entId, maybe OK (MSG . encryptMsg qr) msg_)
|
||||
_ -> pure $ err NO_MSG
|
||||
where
|
||||
|
||||
@@ -54,6 +54,7 @@ module Simplex.Messaging.Transport
|
||||
blockedEntitySMPVersion,
|
||||
shortLinksSMPVersion,
|
||||
serviceCertsSMPVersion,
|
||||
newNtfCredsSMPVersion,
|
||||
simplexMQVersion,
|
||||
smpBlockSize,
|
||||
TransportConfig (..),
|
||||
@@ -166,6 +167,7 @@ smpBlockSize = 16384
|
||||
-- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
|
||||
-- 15 - short links, with associated data passed in NEW of LSET command (3/30/2025)
|
||||
-- 16 - service certificates (5/31/2025)
|
||||
-- 17 - create notification credentials with NEW (7/12/2025)
|
||||
|
||||
data SMPVersion
|
||||
|
||||
@@ -208,6 +210,9 @@ shortLinksSMPVersion = VersionSMP 15
|
||||
serviceCertsSMPVersion :: VersionSMP
|
||||
serviceCertsSMPVersion = VersionSMP 16
|
||||
|
||||
newNtfCredsSMPVersion :: VersionSMP
|
||||
newNtfCredsSMPVersion = VersionSMP 17
|
||||
|
||||
minClientSMPRelayVersion :: VersionSMP
|
||||
minClientSMPRelayVersion = VersionSMP 6
|
||||
|
||||
@@ -215,13 +220,13 @@ minServerSMPRelayVersion :: VersionSMP
|
||||
minServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentClientSMPRelayVersion :: VersionSMP
|
||||
currentClientSMPRelayVersion = VersionSMP 16
|
||||
currentClientSMPRelayVersion = VersionSMP 17
|
||||
|
||||
legacyServerSMPRelayVersion :: VersionSMP
|
||||
legacyServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentServerSMPRelayVersion :: VersionSMP
|
||||
currentServerSMPRelayVersion = VersionSMP 16
|
||||
currentServerSMPRelayVersion = VersionSMP 17
|
||||
|
||||
-- Max SMP protocol version to be used in e2e encrypted
|
||||
-- connection between client and server, as defined by SMP proxy.
|
||||
@@ -229,7 +234,7 @@ currentServerSMPRelayVersion = VersionSMP 16
|
||||
-- to prevent client version fingerprinting by the
|
||||
-- destination relays when clients upgrade at different times.
|
||||
proxiedSMPRelayVersion :: VersionSMP
|
||||
proxiedSMPRelayVersion = VersionSMP 15
|
||||
proxiedSMPRelayVersion = VersionSMP 16
|
||||
|
||||
-- minimal supported protocol version is 6
|
||||
-- TODO remove code that supports sending commands without batching
|
||||
|
||||
@@ -177,7 +177,7 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
|
||||
-- prepare receiving queue
|
||||
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
|
||||
(rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing)
|
||||
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc NRMInteractive Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) Nothing
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
|
||||
-- get proxy session
|
||||
sess0 <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive relayServ (Just "correct")
|
||||
|
||||
+12
-12
@@ -99,10 +99,10 @@ pattern Resp :: CorrId -> QueueId -> BrokerMsg -> Transmission (Either ErrorType
|
||||
pattern Resp corrId queueId command <- (corrId, queueId, Right command)
|
||||
|
||||
pattern New :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Creator
|
||||
pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)))
|
||||
pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) Nothing)
|
||||
|
||||
pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
|
||||
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId Nothing)
|
||||
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId Nothing Nothing)
|
||||
|
||||
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
|
||||
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
|
||||
@@ -294,7 +294,7 @@ testSndSecureProhibited =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing))))
|
||||
Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing))
|
||||
(rId1, NoEntity) #== "creates queue"
|
||||
|
||||
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
@@ -309,7 +309,7 @@ testCreateUpdateKeys =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "1" NoEntity (Ids rId _sId _srvDh) <- signSendRecv h rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing))))
|
||||
Resp "1" NoEntity (Ids rId _sId _srvDh) <- signSendRecv h rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing))
|
||||
(rPub', rKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
Resp "2" rId1 OK <- signSendRecv h rKey ("2", rId, RKEY [rPub, rPub'])
|
||||
rId1 `shouldBe` rId
|
||||
@@ -1247,9 +1247,9 @@ testInvQueueLinkData =
|
||||
qrd = QRMessaging $ Just (sId, ld)
|
||||
-- sender ID must be derived from corrId
|
||||
Resp "1" NoEntity (ERR (CMD PROHIBITED)) <-
|
||||
signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
|
||||
Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId) Nothing)) <-
|
||||
signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
|
||||
signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId) Nothing Nothing)) <-
|
||||
signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
(sId', sId) #== "should return the same sender ID"
|
||||
corrId' `shouldBe` CorrId corrId
|
||||
-- can't read link data with LGET
|
||||
@@ -1304,9 +1304,9 @@ testContactQueueLinkData =
|
||||
qrd = QRContact $ Just (lnkId, (sId, ld))
|
||||
-- sender ID must be derived from corrId
|
||||
Resp "1" NoEntity (ERR (CMD PROHIBITED)) <-
|
||||
signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
|
||||
Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId') Nothing)) <-
|
||||
signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd)))
|
||||
signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId') Nothing Nothing)) <-
|
||||
signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
(lnkId', lnkId) #== "should return the same link ID"
|
||||
(sId', sId) #== "should return the same sender ID"
|
||||
corrId' `shouldBe` CorrId corrId
|
||||
@@ -1378,8 +1378,8 @@ serverSyntaxTests (ATransport t) = do
|
||||
describe "NEW" $ do
|
||||
it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
|
||||
it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
|
||||
it "no signature" $ ("", "dabc", "", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing)))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
|
||||
it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing)))) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
|
||||
it "no signature" $ ("", "dabc", "", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
|
||||
it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
|
||||
describe "KEY" $ do
|
||||
it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH)
|
||||
it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX)
|
||||
|
||||
Reference in New Issue
Block a user