diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 083991adcf..2a9eebb1a4 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 94fd789100..d69ebcd075 100644 --- a/src/Simplex/Chat.hs +++ b/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, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index f4b3a5f2cd..52febef824 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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 diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 9528359af6..7ae2fc3ca7 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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 diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index b3e9206190..171496d8b8 100644 --- a/tests/ChatTests/Profiles.hs +++ b/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 $