diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 3130e0227..ae09312dd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -49,6 +49,7 @@ module Simplex.Messaging.Agent deleteUser, connRequestPQSupport, createConnectionAsync, + setConnShortLinkAsync, joinConnectionAsync, allowConnectionAsync, acceptContactAsync, @@ -345,6 +346,11 @@ createConnectionAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId - createConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:. newConnAsync c userId aCorrId enableNtfs {-# INLINE createConnectionAsync #-} +-- | Create or update user's contact connection short link (LSET command) asynchronously, no synchronous response +setConnShortLinkAsync :: ConnectionModeI c => AgentClient -> ACorrId -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AE () +setConnShortLinkAsync c = withAgentEnv c .::. setConnShortLinkAsync' c +{-# INLINE setConnShortLinkAsync #-} + -- | Join SMP agent connection (JOIN command) asynchronously, synchronous response is new connection id joinConnectionAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AE ConnId joinConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:: joinConnAsync c userId aCorrId enableNtfs @@ -886,6 +892,16 @@ checkClientNotices AgentClient {clientNotices, presetServers} (ProtoServerWithAu when (maybe True (ts <) expires_) $ throwError NOTICE {server = safeDecodeUtf8 $ strEncode $ L.head host, preset = isNothing srvKey, expiresAt = roundedToUTCTime <$> expires_} +setConnShortLinkAsync' :: forall c. ConnectionModeI c => AgentClient -> ACorrId -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AM () +setConnShortLinkAsync' c corrId connId cMode userLinkData clientData = + withConnLock c connId "setConnShortLinkAsync" $ do + SomeConn _ conn <- withStore c (`getConn` connId) + srv <- case (conn, cMode, userLinkData) of + (ContactConnection _ RcvQueue {server}, SCMContact, UserContactLinkData {}) -> pure server + (RcvConnection _ RcvQueue {server}, SCMInvitation, UserInvLinkData {}) -> pure server + _ -> throwE $ CMD PROHIBITED "setConnShortLinkAsync: invalid connection or mode" + enqueueCommand c corrId connId (Just srv) $ AClientCommand $ LSET (AUCLD cMode userLinkData) clientData + setConnShortLink' :: AgentClient -> NetworkRequestMode -> ConnId -> SConnectionMode c -> UserConnLinkData c -> Maybe CRClientData -> AM (ConnShortLink c) setConnShortLink' c nm connId cMode userLinkData clientData = withConnLock c connId "setConnShortLink" $ do @@ -1657,6 +1673,10 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do tryCommand . withNextSrv c userId storageSrvs triedHosts [] $ \srv -> do (CCLink cReq _, service) <- newRcvConnSrv c NRMBackground userId connId enableNtfs cMode Nothing Nothing pqEnc subMode srv notify $ INV (ACR cMode cReq) service + LSET (AUCLD cMode userLinkData) clientData -> + withServer' . tryCommand $ do + link <- setConnShortLink' c NRMBackground connId cMode userLinkData clientData + notify $ LINK (ACSL cMode link) JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 05ebc1b27..080ea393a 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -112,6 +112,7 @@ module Simplex.Messaging.Agent.Protocol ServiceScheme, FixedLinkData (..), ConnLinkData (..), + AUserConnLinkData (..), UserConnLinkData (..), UserContactData (..), UserLinkData (..), @@ -382,6 +383,7 @@ type SndQueueSecured = Bool -- | Parameterized type for SMP agent events data AEvent (e :: AEntity) where INV :: AConnectionRequestUri -> Maybe ClientServiceId -> AEvent AEConn + LINK :: AConnShortLink -> AEvent AEConn CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender INFO :: PQSupport -> ConnInfo -> AEvent AEConn @@ -435,6 +437,7 @@ deriving instance Show AEvtTag data ACommand = NEW Bool AConnectionMode InitialKeys SubscriptionMode -- response INV + | LSET AUserConnLinkData (Maybe CRClientData) -- response LINK | JOIN Bool AConnectionRequestUri PQSupport SubscriptionMode ConnInfo | LET ConfirmationId ConnInfo -- ConnInfo is from client | ACK AgentMsgId (Maybe MsgReceiptInfo) @@ -444,6 +447,7 @@ data ACommand data ACommandTag = NEW_ + | LSET_ | JOIN_ | LET_ | ACK_ @@ -453,6 +457,7 @@ data ACommandTag data AEventTag (e :: AEntity) where INV_ :: AEventTag AEConn + LINK_ :: AEventTag AEConn CONF_ :: AEventTag AEConn REQ_ :: AEventTag AEConn INFO_ :: AEventTag AEConn @@ -499,6 +504,7 @@ deriving instance Show (AEventTag e) aCommandTag :: ACommand -> ACommandTag aCommandTag = \case NEW {} -> NEW_ + LSET {} -> LSET_ JOIN {} -> JOIN_ LET {} -> LET_ ACK {} -> ACK_ @@ -508,6 +514,7 @@ aCommandTag = \case aEventTag :: AEvent e -> AEventTag e aEventTag = \case INV {} -> INV_ + LINK _ -> LINK_ CONF {} -> CONF_ REQ {} -> REQ_ INFO {} -> INFO_ @@ -1703,8 +1710,10 @@ data UserContactData = UserContactData relays :: [ConnShortLink 'CMContact], userData :: UserLinkData } + deriving (Eq, Show) newtype UserLinkData = UserLinkData ByteString + deriving (Eq, Show) data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m) @@ -1712,6 +1721,19 @@ data UserConnLinkData c where UserInvLinkData :: UserLinkData -> UserConnLinkData 'CMInvitation UserContactLinkData :: UserContactData -> UserConnLinkData 'CMContact +deriving instance Eq (UserConnLinkData m) + +deriving instance Show (UserConnLinkData m) + +data AUserConnLinkData = forall m. ConnectionModeI m => AUCLD (SConnectionMode m) (UserConnLinkData m) + +instance Eq AUserConnLinkData where + AUCLD m d == AUCLD m' d' = case testEquality m m' of + Just Refl -> d == d' + Nothing -> False + +deriving instance Show AUserConnLinkData + linkUserData :: ConnLinkData c -> UserLinkData linkUserData = \case InvitationLinkData _ d -> d @@ -1738,6 +1760,7 @@ data OwnerAuth = OwnerAuth -- Owner validation should detect and reject loops. authOwnerSig :: C.Signature 'C.Ed25519 } + deriving (Eq, Show) instance Encoding OwnerAuth where smpEncode OwnerAuth {ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig} = @@ -1777,6 +1800,36 @@ instance Encoding AConnLinkData where let cd = UserContactData {direct, owners, relays, userData} pure $ ACLD SCMContact $ ContactLinkData vr cd +instance ConnectionModeI c => Encoding (UserConnLinkData c) where + smpEncode = \case + UserInvLinkData userData -> smpEncode (CMInvitation, userData) + UserContactLinkData UserContactData {direct, owners, relays, userData} -> + B.concat [smpEncode (CMContact, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData] + smpP = (\(AUCLD _ d) -> checkConnMode d) <$?> smpP + {-# INLINE smpP #-} + +instance Encoding AUserConnLinkData where + smpEncode (AUCLD _ d) = smpEncode d + {-# INLINE smpEncode #-} + smpP = + smpP >>= \case + CMInvitation -> do + userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding + pure $ AUCLD SCMInvitation $ UserInvLinkData userData + CMContact -> do + direct <- smpP + owners <- smpListP + relays <- smpListP + userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding + let cd = UserContactData {direct, owners, relays, userData} + pure $ AUCLD SCMContact $ UserContactLinkData cd + +instance StrEncoding AUserConnLinkData where + strEncode = smpEncode + {-# INLINE strEncode #-} + strP = smpP + {-# INLINE strP #-} + instance Encoding UserLinkData where smpEncode (UserLinkData s) = if B.length s <= 254 then smpEncode s else smpEncode ('\255', Large s) {-# INLINE smpEncode #-} @@ -1976,6 +2029,7 @@ instance StrEncoding ACommandTag where strP = A.takeTill (== ' ') >>= \case "NEW" -> pure NEW_ + "LSET" -> pure LSET_ "JOIN" -> pure JOIN_ "LET" -> pure LET_ "ACK" -> pure ACK_ @@ -1984,6 +2038,7 @@ instance StrEncoding ACommandTag where _ -> fail "bad ACommandTag" strEncode = \case NEW_ -> "NEW" + LSET_ -> "LSET" JOIN_ -> "JOIN" LET_ -> "LET" ACK_ -> "ACK" @@ -1995,6 +2050,7 @@ commandP binaryP = strP >>= \case NEW_ -> s (NEW <$> strP_ <*> strP_ <*> pqIKP <*> (strP <|> pure SMP.SMSubscribe)) + LSET_ -> s (LSET <$> strP <*> optional (A.space *> strP)) JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> pqSupP <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP) LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP) ACK_ -> s (ACK <$> A.decimal <*> optional (A.space *> binaryP)) @@ -2012,6 +2068,7 @@ commandP binaryP = serializeCommand :: ACommand -> ByteString serializeCommand = \case NEW ntfs cMode pqIK subMode -> s (NEW_, ntfs, cMode, pqIK, subMode) + LSET uld cd_ -> s (LSET_, uld) <> maybe "" (B.cons ' ' . s) cd_ JOIN ntfs cReq pqSup subMode cInfo -> s (JOIN_, ntfs, cReq, pqSup, subMode, Str $ serializeBinary cInfo) LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo] ACK mId rcptInfo_ -> s (ACK_, mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_ diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index 63c493861..817580723 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -5,7 +5,7 @@ module AgentTests.EqInstances where import Data.Type.Equality -import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..), UserContactData (..), UserLinkData (..)) +import Simplex.Messaging.Agent.Protocol (ConnLinkData (..)) import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client (ProxiedRelay (..)) @@ -32,18 +32,6 @@ deriving instance Show (ConnLinkData c) deriving instance Eq (ConnLinkData c) -deriving instance Show UserContactData - -deriving instance Eq UserContactData - -deriving instance Show UserLinkData - -deriving instance Eq UserLinkData - -deriving instance Show OwnerAuth - -deriving instance Eq OwnerAuth - deriving instance Show ProxiedRelay deriving instance Eq ProxiedRelay diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 1ceb675ab..5647550a9 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -452,6 +452,8 @@ functionalAPITests ps = do describe "Async agent commands" $ do describe "connect using async agent commands" $ testBasicMatrix2 ps testAsyncCommands + it "should add short link data using async agent command" $ + testSetConnShortLinkAsync ps it "should restore and complete async commands on restart" $ testAsyncCommandsRestore ps describe "accept connection using async command" $ @@ -2628,6 +2630,37 @@ testAsyncCommands sqSecured alice bob baseId = where msgId = subtract baseId +testSetConnShortLinkAsync :: (ASrvTransport, AStoreType) -> IO () +testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> + withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do + let userData = UserLinkData "test user data" + userCtData = UserContactData {direct = True, owners = [], relays = [], userData} + newLinkData = UserContactLinkData userCtData + (cId, (CCLink qInfo (Just shortLink), _)) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just newLinkData) Nothing IKPQOn SMSubscribe + -- verify initial link data + (_, ContactLinkData _ userCtData') <- getConnShortLink bob 1 shortLink + liftIO $ userCtData' `shouldBe` userCtData + -- update link data async + let updatedData = UserLinkData "updated user data" + updatedCtData = UserContactData {direct = False, owners = [], relays = [], userData = updatedData} + setConnShortLinkAsync alice "1" cId SCMContact (UserContactLinkData updatedCtData) Nothing + ("1", cId', LINK (ACSL SCMContact shortLink')) <- get alice + liftIO $ cId' `shouldBe` cId + liftIO $ shortLink' `shouldBe` shortLink + -- verify updated link data + (_, ContactLinkData _ updatedCtData') <- getConnShortLink bob 1 shortLink' + liftIO $ updatedCtData' `shouldBe` updatedCtData + -- complete connection via contact address + (aliceId, _) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe + ("", _, REQ invId _ "bob's connInfo") <- get alice + bobId <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn + (_, Nothing) <- acceptContact alice 1 bobId True invId "alice's connInfo" PQSupportOn SMSubscribe + ("", _, CONF confId _ "alice's connInfo") <- get bob + allowConnection bob aliceId confId "bob's connInfo" + get alice ##> ("", bobId, INFO "bob's connInfo") + get alice ##> ("", bobId, CON) + get bob ##> ("", aliceId, CON) + testAsyncCommandsRestore :: (ASrvTransport, AStoreType) -> IO () testAsyncCommandsRestore ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB