agent: async command to set connection short link (setConnShortLinkAsync) (#1680)

Author: spaced4ndy

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 auData@(AUCLD cMode userLinkData) clientData ->
+          withServer' . tryCommand $ do
+            link <- setConnShortLink' c NRMBackground connId cMode userLinkData clientData
+            notify $ LINK (ACSL cMode link) auData
         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

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 -> AUserConnLinkData -> 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,15 +1710,30 @@ 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)
 
 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} =
@@ -1756,8 +1779,7 @@ instance ConnectionModeI c => Encoding (FixedLinkData c) where
 instance ConnectionModeI c => Encoding (ConnLinkData c) where
   smpEncode = \case
     InvitationLinkData vr userData -> smpEncode (CMInvitation, vr, userData)
-    ContactLinkData vr UserContactData {direct, owners, relays, userData} ->
-      B.concat [smpEncode (CMContact, vr, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData]
+    ContactLinkData vr cd -> smpEncode (CMContact, vr, cd)
   smpP = (\(ACLD _ d) -> checkConnMode d) <$?> smpP
   {-# INLINE smpP #-}
 
@@ -1770,13 +1792,43 @@ instance Encoding AConnLinkData where
         (vr, userData) <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
         pure $ ACLD SCMInvitation $ InvitationLinkData vr userData
       CMContact -> do
-        (vr, 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}
+        (vr, cd) <- smpP
         pure $ ACLD SCMContact $ ContactLinkData vr cd
 
+instance ConnectionModeI c => Encoding (UserConnLinkData c) where
+  smpEncode = \case
+    UserInvLinkData userData -> smpEncode (CMInvitation, userData)
+    UserContactLinkData cd -> smpEncode (CMContact, cd)
+  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 ->
+        AUCLD SCMContact . UserContactLinkData <$> smpP
+
+instance StrEncoding AUserConnLinkData where
+  strEncode = smpEncode
+  {-# INLINE strEncode #-}
+  strP = smpP
+  {-# INLINE strP #-}
+
+instance Encoding UserContactData where
+  smpEncode UserContactData {direct, owners, relays, userData} =
+    B.concat [smpEncode direct, smpEncodeList owners, smpEncodeList relays, smpEncode userData]
+  smpP = do
+    direct <- smpP
+    owners <- smpListP
+    relays <- smpListP
+    userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
+    pure UserContactData {direct, owners, relays, userData}
+
 instance Encoding UserLinkData where
   smpEncode (UserLinkData s) = if B.length s <= 254 then smpEncode s else smpEncode ('\255', Large s)
   {-# INLINE smpEncode #-}
@@ -1976,6 +2028,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 +2037,7 @@ instance StrEncoding ACommandTag where
       _ -> fail "bad ACommandTag"
   strEncode = \case
     NEW_ -> "NEW"
+    LSET_ -> "LSET"
     JOIN_ -> "JOIN"
     LET_ -> "LET"
     ACK_ -> "ACK"
@@ -1995,6 +2049,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 +2067,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_

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

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,38 @@ 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') (AUCLD SCMContact (UserContactLinkData updatedCtData'))) <- get alice
+    liftIO $ cId' `shouldBe` cId
+    liftIO $ shortLink' `shouldBe` shortLink
+    liftIO $ updatedCtData' `shouldBe` updatedCtData
+    -- 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