core: compress link data (#5995)

simplex-chat.cabal

@@ -284,6 +284,7 @@ library
     , unliftio-core ==0.2.*
     , uuid ==1.3.*
     , zip ==2.0.*
+    , zstd ==0.1.3.*
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON

src/Simplex/Chat.hs

@@ -109,7 +109,8 @@ defaultChatConfig =
       coreApi = False,
       highlyAvailable = False,
       deviceNameForRemote = "",
-      chatHooks = defaultChatHooks
+      chatHooks = defaultChatHooks,
+      largeLinkData = True
     }
 
 logCfg :: LogConfig
@@ -125,7 +126,7 @@ newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Boo
 newChatController
   ChatDatabase {chatStore, agentStore}
   user
-  cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
+  cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations, largeLinkData}
   ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
   backgroundMode = do
     let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
@@ -173,7 +174,7 @@ newChatController
     tempDirectory <- newTVarIO optTempDirectory
     assetsDirectory <- newTVarIO Nothing
     contactMergeEnabled <- newTVarIO True
-    useLargeLinkData <- newTVarIO True
+    useLargeLinkData <- newTVarIO largeLinkData
     pure
       ChatController
         { firstTime,

src/Simplex/Chat/Controller.hs

@@ -158,7 +158,8 @@ data ChatConfig = ChatConfig
     coreApi :: Bool,
     highlyAvailable :: Bool,
     deviceNameForRemote :: Text,
-    chatHooks :: ChatHooks
+    chatHooks :: ChatHooks,
+    largeLinkData :: Bool
   }
 
 data RandomAgentServers = RandomAgentServers

src/Simplex/Chat/Library/Commands.hs

@@ -17,6 +17,7 @@
 
 module Simplex.Chat.Library.Commands where
 
+import qualified Codec.Compression.Zstd as Z1
 import Control.Applicative (optional, (<|>))
 import Control.Concurrent.STM (retry)
 import Control.Logger.Simple
@@ -94,6 +95,7 @@ import Simplex.Messaging.Agent.Store.Shared (upMigration)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Interface (getCurrentMigrations)
 import Simplex.Messaging.Client (NetworkConfig (..), SMPWebPortServers (..), SocksMode (SMAlways), textToHostMode)
+import Simplex.Messaging.Compression (compressionLevel)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -3293,7 +3295,7 @@ processChatCommand' vr = \case
             pure (ACCL SCMInvitation (CCLink cReq (Just l')), plan)
           Nothing -> do
             (cReq, cData) <- getShortLinkConnReq user l'
-            let contactSLinkData_ = J.decodeStrict $ linkUserData' cData
+            contactSLinkData_ <- liftIO $ decodeShortLinkData cData
             invitationReqAndPlan cReq (Just l') contactSLinkData_
       where
         invitationReqAndPlan cReq sLnk_ contactSLinkData_ = do
@@ -3315,7 +3317,7 @@ processChatCommand' vr = \case
                 withFastStore' (\db -> getContactWithoutConnViaShortAddress db vr user l') >>= \case
                   Just ct' -> pure (cl, CPContactAddress (CAPContactViaAddress ct'))
                   Nothing -> do
-                    let contactSLinkData_ = J.decodeStrict $ linkUserData' cData
+                    contactSLinkData_ <- liftIO $ decodeShortLinkData cData
                     plan <- contactRequestPlan user cReq contactSLinkData_
                     pure (cl, plan)
           CCTGroup ->
@@ -3323,7 +3325,7 @@ processChatCommand' vr = \case
               Just (cReq, g) -> pure (ACCL SCMContact $ CCLink cReq (Just l'), CPGroupLink (GLPOwnLink g))
               Nothing -> do
                 (cReq, cData) <- getShortLinkConnReq user l'
-                let groupSLinkData_ = J.decodeStrict $ linkUserData' cData
+                groupSLinkData_ <- liftIO $ decodeShortLinkData cData
                 plan <- groupJoinRequestPlan user cReq groupSLinkData_
                 pure (ACCL SCMContact $ CCLink cReq (Just l'), plan)
           CCTChannel -> throwCmdError "channel links are not supported in this version"
@@ -3435,20 +3437,40 @@ processChatCommand' vr = \case
     restoreShortLink' l = (`restoreShortLink` l) <$> asks (shortLinkPresetServers . config)
     contactShortLinkData :: Profile -> Maybe Text -> CM UserLinkData
     contactShortLinkData p msg = do
-      largeLinkData <- chatReadVar useLargeLinkData
+      large <- chatReadVar useLargeLinkData
       let contactData
-            | largeLinkData = ContactShortLinkData p msg
+            | large = ContactShortLinkData p msg
             | otherwise = ContactShortLinkData p {fullName = "", image = Nothing, contactLink = Nothing} Nothing
-      -- TODO [short links] compress
-      pure $ UserLinkData $ LB.toStrict $ J.encode contactData
+      pure $ encodeShortLinkData large contactData
     groupShortLinkData :: GroupProfile -> CM UserLinkData
     groupShortLinkData gp = do
-      largeLinkData <- chatReadVar useLargeLinkData
+      large <- chatReadVar useLargeLinkData
       let gp'
-            | largeLinkData = gp
+            | large = gp
             | otherwise = gp {fullName = "", description = Nothing, image = Nothing, memberAdmission = Nothing}
-      -- TODO [short links] compress
-      pure $ UserLinkData $ LB.toStrict $ J.encode $ GroupShortLinkData gp'
+      pure $ encodeShortLinkData large $ GroupShortLinkData gp'
+    encodeShortLinkData :: J.ToJSON a => Bool -> a -> UserLinkData
+    encodeShortLinkData large d =
+      let s = LB.toStrict $ J.encode d
+          -- 10kb size limit for compression to be used is based on 13784 limit for link data
+          -- and the space reserved for the other fields in ConnLinkData encoding (most of these fields are currently unused).
+          s'
+            | B.length s > (if large then 10240 else 254) = B.cons 'X' $ Z1.compress compressionLevel s
+            | otherwise = s
+       in UserLinkData s'
+    decodeShortLinkData :: J.FromJSON a => ConnLinkData c -> IO (Maybe a)
+    decodeShortLinkData cData
+      | B.null s = pure Nothing
+      | B.head s == 'X' = case Z1.decompress $ B.drop 1 s of
+          Z1.Error e -> Nothing <$ logError ("Error decompressing link data: " <> tshow e)
+          Z1.Skip -> pure Nothing
+          Z1.Decompress s' -> decode s'
+      | otherwise = decode s
+      where
+        decode s' = case J.eitherDecodeStrict s' of
+          Right d -> pure $ Just d
+          Left e -> Nothing <$ logError ("Error decoding link data: " <> tshow e)
+        s = linkUserData' cData
     updatePCCShortLinkData :: PendingContactConnection -> Profile -> CM (Maybe ShortLinkInvitation)
     updatePCCShortLinkData conn@PendingContactConnection {connLinkInv} profile =
       forM (connShortLink =<< connLinkInv) $ \_ -> do

tests/ChatTests/Profiles.hs

@@ -112,6 +112,7 @@ chatProfileTests = do
   describe "short links with attached data" $ do
     it "prepare contact using invitation short link data and connect" testShortLinkInvitationPrepareContact
     it "prepare contact with image in profile" testShortLinkInvitationImage
+    it "prepare contact with a long name in profile" testShortLinkInvitationLongName
     it "prepare contact using address short link data and connect" testShortLinkAddressPrepareContact
     it "prepare group using group short link data and connect" testShortLinkPrepareGroup
     it "prepare group using group short link data and connect, host rejects" testShortLinkPrepareGroupReject
@@ -2923,6 +2924,28 @@ testShortLinkInvitationImage = testChat2 aliceProfile bobProfile $ \alice bob ->
     (bob <## "alice (Alice): contact is connected")
   bob <##> alice
 
+testShortLinkInvitationLongName :: HasCallStack => TestParams -> IO ()
+testShortLinkInvitationLongName = testChatCfg2 testCfg {largeLinkData = False} aliceProfile bobProfile {displayName = T.pack longName, fullName = ""} $ \alice bob -> do
+  bob ##> "/_connect 1"
+  (shortLink, fullLink) <- getInvitations bob
+  alice ##> ("/_connect plan 1 " <> shortLink)
+  alice <## "invitation link: ok to connect"
+  contactSLinkData <- getTermLine alice
+  alice ##> ("/_prepare contact 1 " <> fullLink <> " " <> shortLink <> " " <> contactSLinkData)
+  alice <## (longName <> ": contact is prepared")
+  alice ##> "/_connect contact @2 text hello"
+  alice
+    <### [ ConsoleString (longName <> ": connection started"),
+           WithTime ("@" <> longName <> " hello")
+         ]
+  bob <# "alice> hello"
+  concurrently_
+    (alice <## (longName <> ": contact is connected"))
+    (bob <## "alice (Alice): contact is connected")
+  bob <##> alice
+  where
+    longName = "012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789"
+
 testShortLinkAddressPrepareContact :: HasCallStack => TestParams -> IO ()
 testShortLinkAddressPrepareContact =
   testChat2 aliceProfile bobProfile $