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

2026-08-28 11:34:36 +00:00 · 2026-01-07 15:12:52 +00:00
parent c4b687ba64
commit 07604a146f
4 changed files with 118 additions and 20 deletions
@@ -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
@@ -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,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} =
@@ -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_