diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index bc6a02715..c05fcf8f6 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -178,7 +178,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations) import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration) -import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, temporaryClientError, unexpectedResponse) +import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), ServerTransmissionBatch, nonBlockingWriteTBQueue, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) @@ -189,7 +189,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) +import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -705,6 +705,8 @@ newConnNoQueues c userId enableNtfs cMode pqSupport = do let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} withStore c $ \db -> createNewConn db g cData cMode +-- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection, +-- and join should retry, the same as 1-time invitation joins. joinConnAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do withInvLock c (strEncode cReqUri) "joinConnAsync" $ do @@ -805,6 +807,7 @@ newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do setConnShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact) setConnShortLink' = undefined +-- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent. getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo) getConnShortLink' c userId = \case CSLInvitation srv linkId linkKey -> do @@ -814,23 +817,24 @@ getConnShortLink' c userId = \case Just sl@InvShortLink {linkKey = lk} | linkKey == lk -> pure sl _ -> do (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - let sl = InvShortLink {server = srv, linkId, linkKey, sndPrivateKey, sndPublicKey} + let sl = InvShortLink {server = srv, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId = Nothing} createInvShortLink db sl pure sl let k = SL.invShortLinkKdf linkKey - secureGetQueueLink c userId invLink >>= decryptData srv linkKey k + ld@(sndId, _) <- secureGetQueueLink c userId invLink + withStore' c $ \db -> setInvShortLinkSndId db invLink sndId + decryptData srv linkKey k ld CSLContact srv _ linkKey -> do let (linkId, k) = SL.contactShortLinkKdf linkKey - getQueueLink c userId srv linkId >>= decryptData srv linkKey k + ld <- getQueueLink c userId srv linkId + decryptData srv linkKey k ld where decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, SMP.QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo) decryptData srv linkKey k (sndId, d) = do - r <- liftEither $ SL.decryptLinkData @c linkKey k d - checkSameQueue $ case fst r of CRInvitationUri crd _ -> crd; CRContactUri crd -> crd + r@(cReq, _) <- liftEither $ SL.decryptLinkData @c linkKey k d + unless ((srv, sndId) `sameQAddress` qAddress (connReqQueue cReq)) $ + throwE $ AGENT $ A_LINK "different address" pure r - where - checkSameQueue ConnReqUriData {crSmpQueues = SMPQueueUri {queueAddress = SMPQueueAddress srv' sndId' _ _} :| _} = - unless (srv == srv' && sndId == sndId') $ throwE $ AGENT $ A_LINK "different address" delInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () delInvShortLink' = undefined @@ -952,52 +956,54 @@ newConnToAccept c connId enableNtfs invId pqSup = do newConnToJoin c userId connId enableNtfs connReq pqSup _ -> throwE $ CMD PROHIBITED "newConnToAccept" --- TODO [short link] joining queue that was already secured with LKEY +-- Short link MUST be passed again to joinConnection so that the same sender key is used. +-- The alternative design would be to create connection ID and SndQueue when short link is read. joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do - srv <- getNextSMPServer c userId [qServer cReqQueue] + srv <- getNextSMPServer c userId [qServer $ connReqQueue cReq] joinConnSrv c userId connId enableNtfs cReq cInfo pqSupport subMode srv - where - cReqQueue :: SMPQueueUri - cReqQueue = case cReq of - CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q - CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q -startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448) +connReqQueue :: ConnectionRequestUri c -> SMPQueueUri +connReqQueue = \case + CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> q + CRContactUri ConnReqUriData {crSmpQueues = q :| _} -> q + +startJoinInvitation :: AgentClient -> UserId -> ConnId -> Maybe SndQueue -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (ConnData, SndQueue, CR.SndE2ERatchetParams 'C.X448, Bool) startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = lift (compatibleInvitationUri cReqUri) >>= \case Just (qInfo, Compatible e2eRcvParams@(CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do -- this case avoids re-generating queue keys and subsequent failure of SKEY that timed out -- e2ePubKey is always present, it's Maybe historically let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) - (sq', e2eSndParams) <- case sq_ of - Just sq@SndQueue {e2ePubKey = Just _k} -> do - e2eSndParams <- - withStore' c (\db -> getSndRatchet db connId v) >>= \case - Right r -> pure $ snd r - Left e -> do - atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) - createRatchet_ pqSupport e2eRcvParams - pure (sq, e2eSndParams) - _ -> do - q <- lift $ fst <$> newSndQueue userId "" qInfo - e2eSndParams <- createRatchet_ pqSupport e2eRcvParams - withStore c $ \db -> runExceptT $ do - sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_ - pure (sq', e2eSndParams) + g <- asks random + maxSupported <- asks $ maxVersion . e2eEncryptVRange . config let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} - pure (cData, sq', e2eSndParams) + case sq_ of + Just sq@SndQueue {e2ePubKey = Just _k} -> do + e2eSndParams <- withStore c $ \db -> + getSndRatchet db connId v >>= \case + Right r -> pure $ Right $ snd r + Left e -> do + nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "no snd ratchet " <> show e)) + runExceptT $ createRatchet_ db g maxSupported pqSupport e2eRcvParams + pure (cData, sq, e2eSndParams, False) + _ -> do + let Compatible SMPQueueInfo {queueAddress = SMPQueueAddress {smpServer, senderId}} = qInfo + sndKeys_ <- withStore' c $ \db -> getInvShortLinkKeys db smpServer senderId + (q, _) <- lift $ newSndQueue userId "" qInfo sndKeys_ + withStore c $ \db -> runExceptT $ do + e2eSndParams <- createRatchet_ db g maxSupported pqSupport e2eRcvParams + sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_ + pure (cData, sq', e2eSndParams, isJust sndKeys_) Nothing -> throwE $ AGENT A_VERSION where - createRatchet_ pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do - g <- asks random + createRatchet_ db g maxSupported pqSupport e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_) = do (pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport) (_, rcDHRs) <- atomically $ C.generateKeyPair g - rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams - maxSupported <- asks $ maxVersion . e2eEncryptVRange . config + rcParams <- liftEitherWith (SEAgentError . cryptoError) $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams let rcVs = CR.RatchetVersions {current = v, maxSupported} rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams - withStore' c $ \db -> createSndRatchet db connId rc e2eSndParams + liftIO $ createSndRatchet db connId rc e2eSndParams pure e2eSndParams connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport)) @@ -1042,8 +1048,9 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod where doJoin :: Maybe SndQueue -> AM SndQueueSecured doJoin sq_ = do - (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup + (cData, sq, e2eSndParams, hasLink) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup secureConfirmQueue c cData sq srv cInfo (Just e2eSndParams) subMode + >>= (when hasLink (delInvSL c connId srv sq) $>) joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, vrsn) -> do @@ -1052,6 +1059,11 @@ joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMo pure False Nothing -> throwE $ AGENT A_VERSION +delInvSL :: AgentClient -> ConnId -> SMPServerWithAuth -> SndQueue -> AM () +delInvSL c connId srv sq = + withStore' c (\db -> deleteInvShortLink db (protoServer srv) (queueId sq)) `catchE` \e -> + liftIO $ nonBlockingWriteTBQueue (subQ c) ("", connId, AEvt SAEConn (ERR $ INTERNAL $ "error deleting short link " <> show e)) + joinConnSrvAsync :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSupport subMode srv = do SomeConn cType conn <- withStore c (`getConn` connId) @@ -1062,8 +1074,9 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo where doJoin :: Maybe SndQueue -> AM SndQueueSecured doJoin sq_ = do - (cData, sq, e2eSndParams) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport + (cData, sq, e2eSndParams, hasLink) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSupport secureConfirmQueueAsync c cData sq srv cInfo (Just e2eSndParams) subMode + >>= (when hasLink (delInvSL c connId srv sq) $>) joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do throwE $ CMD PROHIBITED "joinConnSrvAsync" @@ -2861,7 +2874,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), _v, sessId let (delSqs, keepSqs) = L.partition ((Just dbQueueId ==) . dbReplaceQId) sqs case L.nonEmpty keepSqs of Just sqs' -> do - (sq_@SndQueue {sndPublicKey}, dhPublicKey) <- lift $ newSndQueue userId connId qInfo + (sq_@SndQueue {sndPublicKey}, dhPublicKey) <- lift $ newSndQueue userId connId qInfo Nothing sq2 <- withStore c $ \db -> do liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} @@ -3053,7 +3066,7 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo sq_ (qInfo :| _ enqueueConfirmation c cData sq' ownConnInfo Nothing where upgradeConn = do - (sq, _) <- lift $ newSndQueue userId connId qInfo' + (sq, _) <- lift $ newSndQueue userId connId qInfo' Nothing withStore c $ \db -> upgradeRcvConnToDuplex db connId sq secureConfirmQueueAsync :: AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> SubscriptionMode -> AM SndQueueSecured @@ -3175,11 +3188,11 @@ agentRatchetDecrypt' g db connId rc encAgentMsg = do liftIO $ updateRatchet db connId rc' skippedDiff liftEither $ bimap (SEAgentError . cryptoError) (,CR.rcRcvKEM rc') agentMsgBody_ -newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> AM' (NewSndQueue, C.PublicKeyX25519) -newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) = do +newSndQueue :: UserId -> ConnId -> Compatible SMPQueueInfo -> Maybe (C.AAuthKeyPair) -> AM' (NewSndQueue, C.PublicKeyX25519) +newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, sndSecure, dhPublicKey = rcvE2ePubDhKey})) sndKeys_ = do C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random - (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g + (sndPublicKey, sndPrivateKey) <- maybe (atomically $ C.generateAuthKeyPair a g) pure sndKeys_ (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g let sq = SndQueue @@ -3192,7 +3205,8 @@ newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAdd sndPrivateKey, e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey, e2ePubKey = Just e2ePubKey, - status = New, + -- setting status to Secured prevents SKEY when queue was already secured with LKEY + status = if isJust sndKeys_ then Secured else New, dbQueueId = DBNewQueue, primary = True, dbReplaceQueueId = Nothing, diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index a7640fe0f..e596b3e5d 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1302,7 +1302,9 @@ data ContactConnType = CCTContact | CCTGroup deriving (Show) data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) -- TODO [short link] parser, parsing tests -data AConnectionLink = ACLFull AConnectionRequestUri | ACLShort AConnShortLink +data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m) + +data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m) instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 7375ed41b..a04422780 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -155,7 +155,8 @@ data InvShortLink = InvShortLink linkId :: SMP.LinkId, linkKey :: LinkKey, sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries - sndPublicKey :: SndPublicAuthKey + sndPublicKey :: SndPublicAuthKey, + sndId :: Maybe SMP.SenderId } deriving (Show) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index f19b02af1..9548b296c 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -90,7 +90,10 @@ module Simplex.Messaging.Agent.Store.AgentStore unacceptInvitation, deleteInvitation, getInvShortLink, + getInvShortLinkKeys, + deleteInvShortLink, createInvShortLink, + setInvShortLinkSndId, -- Messages updateRcvIds, createRcvMsg, @@ -768,33 +771,64 @@ getInvShortLink db server linkId = DB.query db [sql| - SELECT link_key, snd_private_key + SELECT link_key, snd_private_key, snd_id FROM inv_short_links WHERE host = ? AND port = ? AND link_id = ? |] (host server, port server, linkId) where - toInvShortLink :: (LinkKey, C.APrivateAuthKey) -> InvShortLink - toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk)) = + toInvShortLink :: (LinkKey, C.APrivateAuthKey, Maybe SenderId) -> InvShortLink + toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk), sndId) = let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk - in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey} + in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey, sndId} + +getInvShortLinkKeys :: DB.Connection -> SMPServer -> SenderId -> IO (Maybe C.AAuthKeyPair) +getInvShortLinkKeys db srv sndId = + maybeFirstRow toSndKeys $ + DB.query + db + [sql| + SELECT snd_private_key + FROM inv_short_links + WHERE host = ? AND port = ? AND snd_id = ? + |] + (host srv, port srv, sndId) + where + toSndKeys :: Only C.APrivateAuthKey -> C.AAuthKeyPair + toSndKeys (Only privKey@(C.APrivateAuthKey a pk)) = (C.APublicAuthKey a $ C.publicKey pk, privKey) + +deleteInvShortLink :: DB.Connection -> SMPServer -> SenderId -> IO () +deleteInvShortLink db srv sndId = + DB.execute db "DELETE FROM inv_short_links WHERE host = ? AND port = ? AND snd_id = ?" (host srv, port srv, sndId) createInvShortLink :: DB.Connection -> InvShortLink -> IO () -createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey} = do +createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey, sndId} = do serverKeyHash_ <- createServer_ db server DB.execute db [sql| INSERT INTO inv_short_links - (host, port, server_key_hash, link_id, link_key, snd_private_key) - VALUES (?,?,?,?,?,?) + (host, port, server_key_hash, link_id, link_key, snd_private_key, snd_id) + VALUES (?,?,?,?,?,?,?) ON CONFLICT (host, port, link_id) DO UPDATE SET server_key_hash = EXCLUDED.server_key_hash, link_key = EXCLUDED.link_key, - snd_private_key = EXCLUDED.snd_private_key + snd_private_key = EXCLUDED.snd_private_key, + snd_id = EXCLUDED.snd_id |] - (host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey) + (host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey, sndId) + +setInvShortLinkSndId :: DB.Connection -> InvShortLink -> SenderId -> IO () +setInvShortLinkSndId db InvShortLink {server, linkId} sndId = + DB.execute + db + [sql| + UPDATE inv_short_links + SET snd_id = ? + WHERE host = ? AND port = ? AND link_id = ? + |] + (sndId, host server, port server, linkId) updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash) updateRcvIds db connId = do diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs index 4948eac82..774ad50d6 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20250322_short_links.hs @@ -25,6 +25,7 @@ CREATE TABLE inv_short_links( link_id BYTEA NOT NULL, link_key BYTEA NOT NULL, snd_private_key BYTEA NOT NULL, + snd_id BYTEA, FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE ); diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs index b79ce24e0..70a15b8cc 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20250322_short_links.hs @@ -23,6 +23,7 @@ CREATE TABLE inv_short_links( link_id BLOB NOT NULL, link_key BLOB NOT NULL, snd_private_key BLOB NOT NULL, + snd_id BLOB, FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE ); diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 89d1d271a..5db250ad0 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -434,6 +434,7 @@ CREATE TABLE inv_short_links( link_id BLOB NOT NULL, link_key BLOB NOT NULL, snd_private_key BLOB NOT NULL, + snd_id BLOB, FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE ); CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id); diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 4aebc107e..5352658b2 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -107,6 +107,7 @@ module Simplex.Messaging.Client TBQueueInfo (..), getTBQueueInfo, getProtocolClientQueuesInfo, + nonBlockingWriteTBQueue, ) where diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index dfe596cf6..6ae012027 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -302,14 +302,14 @@ data SParty :: Party -> Type where SRecipient :: SParty Recipient SSender :: SParty Sender SNotifier :: SParty Notifier - SLinkClient :: SParty LinkClient + SSenderLink :: SParty LinkClient SProxiedClient :: SParty ProxiedClient instance TestEquality SParty where testEquality SRecipient SRecipient = Just Refl testEquality SSender SSender = Just Refl testEquality SNotifier SNotifier = Just Refl - testEquality SLinkClient SLinkClient = Just Refl + testEquality SSenderLink SSenderLink = Just Refl testEquality SProxiedClient SProxiedClient = Just Refl testEquality _ _ = Nothing @@ -323,7 +323,7 @@ instance PartyI Sender where sParty = SSender instance PartyI Notifier where sParty = SNotifier -instance PartyI LinkClient where sParty = SLinkClient +instance PartyI LinkClient where sParty = SSenderLink instance PartyI ProxiedClient where sParty = SProxiedClient @@ -860,8 +860,8 @@ instance ProtocolMsgTag CmdTag where "SKEY" -> Just $ CT SSender SKEY_ "SEND" -> Just $ CT SSender SEND_ "PING" -> Just $ CT SSender PING_ - "LKEY" -> Just $ CT SLinkClient LKEY_ - "LGET" -> Just $ CT SLinkClient LGET_ + "LKEY" -> Just $ CT SSenderLink LKEY_ + "LGET" -> Just $ CT SSenderLink LGET_ "PRXY" -> Just $ CT SProxiedClient PRXY_ "PFWD" -> Just $ CT SProxiedClient PFWD_ "RFWD" -> Just $ CT SSender RFWD_ @@ -1587,8 +1587,8 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP) PING_ -> pure PING RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP) - CT SLinkClient tag -> - Cmd SLinkClient <$> case tag of + CT SSenderLink tag -> + Cmd SSenderLink <$> case tag of LKEY_ -> LKEY <$> _smpP LGET_ -> pure LGET CT SProxiedClient tag -> diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 199f202fd..1aa6b0d64 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1068,8 +1068,8 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd = Cmd SSender SEND {} -> verifyQueue (\q -> if maybe (isNothing tAuth) verify (senderKey $ snd q) then VRVerified (Just q) else VRFailed) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing Cmd SSender RFWD {} -> pure $ VRVerified Nothing - Cmd SLinkClient (LKEY k) -> verifySecure SLinkClient k - Cmd SLinkClient LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SLinkClient + Cmd SSenderLink (LKEY k) -> verifySecure SSenderLink k + Cmd SSenderLink LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SSenderLink -- NSUB will not be accepted without authorization Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier $ snd q)) <$> get SNotifier Cmd SProxiedClient _ -> pure $ VRVerified Nothing @@ -1247,13 +1247,12 @@ client SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody PING -> pure (corrId, NoEntity, PONG) RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock - Cmd SLinkClient command -> Just <$> case command of + Cmd SSenderLink command -> Just <$> case command of LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr LGET -> withQueue $ \q qr -> checkMode QMContact qr $ getQueueLink_ q qr Cmd SNotifier NSUB -> Just <$> subscribeNotifications Cmd SRecipient command -> Just <$> case command of - -- TODO [short links] idempotent NEW NEW nqr@NewQueueReq {auth_} -> ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH)) where @@ -1698,8 +1697,8 @@ client allowed = case cmd' of Cmd SSender SEND {} -> True Cmd SSender (SKEY _) -> True - Cmd SLinkClient (LKEY _) -> True - Cmd SLinkClient LGET -> True + Cmd SSenderLink (LKEY _) -> True + Cmd SSenderLink LGET -> True _ -> False verified = \case VRVerified q -> Right (q, (corrId', entId', cmd')) diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 89464938d..5de63d367 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -84,6 +84,7 @@ data PostgresQueueStore q = PostgresQueueStore queues :: TMap RecipientId q, -- this map only cashes the queues that were attempted to send messages to, senders :: TMap SenderId RecipientId, + links :: TMap LinkId RecipientId, -- this map only cashes the queues that were attempted to be subscribed to, notifiers :: TMap NotifierId RecipientId, notifierLocks :: TMap NotifierId Lock, @@ -99,9 +100,10 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where dbStoreLog <- mapM (openWriteStoreLog True) dbStoreLogPath queues <- TM.emptyIO senders <- TM.emptyIO + links <- TM.emptyIO notifiers <- TM.emptyIO notifierLocks <- TM.emptyIO - pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, notifiers, notifierLocks, deletedTTL} + pure PostgresQueueStore {dbStore, dbStoreLog, queues, senders, links, notifiers, notifierLocks, deletedTTL} where err e = do logError $ "STORE: newQueueStore, error opening PostgreSQL database, " <> tshow e @@ -146,10 +148,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where atomically $ TM.insert rId sq queues atomically $ TM.insert (senderId qr) rId senders forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers + forM_ (queueData qr) $ \(lnkId, _) -> atomically $ TM.insert lnkId rId links withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr pure sq where - PostgresQueueStore {queues, senders, notifiers} = st + PostgresQueueStore {queues, senders, links, notifiers} = st -- Not doing duplicate checks in maps as the probability of duplicates is very low. -- It needs to be reconsidered when IDs are supplied by the users. -- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier] @@ -159,12 +162,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where getQueue_ st mkQ party qId = case party of SRecipient -> getRcvQueue qId SSender -> TM.lookupIO qId senders >>= maybe (mask loadSndQueue) getRcvQueue - -- TODO [short links] use map of link IDs - queue will be added there on creation in case there is data - SLinkClient -> mask loadLinkQueue + SSenderLink -> TM.lookupIO qId links >>= maybe (mask loadLinkQueue) getRcvQueue -- loaded queue is deleted from notifiers map to reduce cache size after queue was subscribed to by ntf server SNotifier -> TM.lookupIO qId notifiers >>= maybe (mask loadNtfQueue) (getRcvQueue >=> (atomically (TM.delete qId notifiers) $>)) where - PostgresQueueStore {queues, senders, notifiers} = st + PostgresQueueStore {queues, senders, links, notifiers} = st getRcvQueue rId = TM.lookupIO rId queues >>= maybe (mask loadRcvQueue) (pure . Right) loadRcvQueue = do (rId, qRec) <- loadQueue " WHERE recipient_id = ?" diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index e3efe9309..dcd7fd5a0 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -102,7 +102,7 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where SRecipient -> TM.lookupIO qId queues SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues) SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues) - SLinkClient -> TM.lookupIO qId links $>>= (`TM.lookupIO` queues) + SSenderLink -> TM.lookupIO qId links $>>= (`TM.lookupIO` queues) where STMQueueStore {queues, senders, notifiers, links} = st diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 869f3ef6f..63e6e3f49 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -309,8 +309,9 @@ functionalAPITests ps = do it "should restore confirmation after client restart" $ testAllowConnectionClientRestart ps describe "Short connection links" $ do - it "create and get 1-time short link" $ testInviationShortLink ps - it "create and get contact short link" $ testContactShortLink ps + it "should connect via 1-time short link" $ testInviationShortLink ps + it "should connect via 1-time short link with async join" $ testInviationShortLinkAsync ps + it "should connect via contact short link" $ testContactShortLink ps describe "Message delivery" $ do describe "update connection agent version on received messages" $ do it "should increase if compatible, shouldn'ps decrease" $ @@ -1082,7 +1083,7 @@ testInviationShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testInviationShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (bId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1095,12 +1096,41 @@ testInviationShortLink ps = runExceptT (getConnShortLink c 1 shortLink) >>= \case Left (SMP _ AUTH) -> pure () r -> liftIO $ expectationFailure ("unexpected result " <> show r) + runRight $ do + aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn + sndSecure <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ sndSecure `shouldBe` True + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnection a bId confId "alice's connInfo" + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId + +testInviationShortLinkAsync :: HasCallStack => (ATransport, AStoreType) -> IO () +testInviationShortLinkAsync ps = + withAgentClients2 $ \a b -> withSmpServer ps $ do + let userData = "some user data" + (bId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe + (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + strDecode (strEncode shortLink) `shouldBe` Right shortLink + connReq' `shouldBe` connReq + userData' `shouldBe` userData + runRight $ do + aId <- A.joinConnectionAsync b 1 "123" True connReq "bob's connInfo" PQSupportOn SMSubscribe + get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnection a bId confId "alice's connInfo" + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO () testContactShortLink ps = withAgentClients3 $ \a b c -> withSmpServer ps $ do let userData = "some user data" - (_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe + (_contactId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq @@ -1113,6 +1143,19 @@ testContactShortLink ps = (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink connReq3 `shouldBe` connReq userData3 `shouldBe` userData + runRight $ do + (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 True invId PQSupportOn + sndSecure' <- acceptContact a bId True invId "alice's connInfo" PQSupportOn SMSubscribe + liftIO $ sndSecure' `shouldBe` True + ("", _, CONF confId _ "alice's connInfo") <- get b + allowConnection b aId confId "bob's connInfo" + get a ##> ("", bId, INFO "bob's connInfo") + get a ##> ("", bId, CON) + get b ##> ("", aId, CON) + exchangeGreetings a bId b aId testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do