diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 255e56800..4830e6dfe 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index b7850e50d..745acbbac 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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) diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index e31ddfba9..7546c03dd 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 09b76671b..31b4217e3 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 5787db46b..b14faffbf 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 4d5a2f551..1e778deac 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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 diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index b440dfd7f..1069fafdf 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 2b47bf569..0b2eb3b75 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -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 diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 42f81d45b..5f1a59fd0 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -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") diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 70fdf5983..5ff65c9c4 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -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)