diff --git a/package.yaml b/package.yaml index 1d44ae8a0..b9be69f55 100644 --- a/package.yaml +++ b/package.yaml @@ -49,6 +49,7 @@ dependencies: - unliftio == 0.2.* - unliftio-core == 0.2.* - zip == 2.0.* + - zstd flags: swift: diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 9e2b86319..cae69e3ea 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -211,6 +211,7 @@ library , unliftio ==0.2.* , unliftio-core ==0.2.* , zip ==2.0.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -272,6 +273,7 @@ executable simplex-bot , unliftio ==0.2.* , unliftio-core ==0.2.* , zip ==2.0.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -333,6 +335,7 @@ executable simplex-bot-advanced , unliftio ==0.2.* , unliftio-core ==0.2.* , zip ==2.0.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -396,6 +399,7 @@ executable simplex-broadcast-bot , unliftio ==0.2.* , unliftio-core ==0.2.* , zip ==2.0.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -459,6 +463,7 @@ executable simplex-chat , unliftio-core ==0.2.* , websockets ==0.12.* , zip ==2.0.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -525,6 +530,7 @@ executable simplex-directory-service , unliftio ==0.2.* , unliftio-core ==0.2.* , zip ==2.0.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -621,6 +627,7 @@ test-suite simplex-chat-test , unliftio ==0.2.* , unliftio-core ==0.2.* , zip ==2.0.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 3b0fe7075..a09f3342c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -451,6 +451,14 @@ processChatCommand cmd = chatVersionRange >>= (`processChatCommand'` cmd) processChatCommand' :: forall m. ChatMonad m => VersionRange -> ChatCommand -> m ChatResponse processChatCommand' vr = \case + TestZstd outfile_ -> do + rows <- withStore' testZstd + case outfile_ of + Nothing -> pure $ CRZstdTest rows + Just path -> do + liftIO $ LB.writeFile path $ LB.unlines $ + map (\ZstdRow {raw, z1, z3, z6, z9, z} -> LB.fromStrict . B.unwords $ map bshow [raw, z1, z3, z6, z9, z]) rows + ok_ ShowActiveUser -> withUser' $ pure . CRActiveUser CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do forM_ profile $ \Profile {displayName} -> checkValidName displayName @@ -6496,7 +6504,8 @@ chatVersionRange = do chatCommandP :: Parser ChatCommand chatCommandP = choice - [ "/mute " *> ((`SetShowMessages` MFNone) <$> chatNameP), + [ "/zstd" *> (TestZstd <$> optional (A.space *> filePath)), + "/mute " *> ((`SetShowMessages` MFNone) <$> chatNameP), "/unmute " *> ((`SetShowMessages` MFAll) <$> chatNameP), "/unmute mentions " *> ((`SetShowMessages` MFMentions) <$> chatNameP), "/receipts " *> (SetSendReceipts <$> chatNameP <* " " <*> ((Just <$> onOffP) <|> ("default" $> Nothing))), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 249c66afc..033ae703b 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -215,7 +215,8 @@ data HelpSection = HSMain | HSFiles | HSGroups | HSContacts | HSMyAddress | HSIn deriving (Show) data ChatCommand - = ShowActiveUser + = TestZstd (Maybe FilePath) + | ShowActiveUser | CreateActiveUser NewUser | ListUsers | APISetActiveUser UserId (Maybe UserPwd) @@ -717,6 +718,12 @@ data ChatResponse | CRChatErrors {user_ :: Maybe User, chatErrors :: [ChatError]} | CRArchiveImported {archiveErrors :: [ArchiveError]} | CRTimedAction {action :: String, durationMilliseconds :: Int64} + | CRZstdTest {zstdRows :: [ZstdRow]} + deriving (Show) + +data ZstdRow = ZstdRow + { raw, z1, z3, z6, z9, z :: !Int + } deriving (Show) -- some of these can only be used as command responses @@ -1412,6 +1419,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCSR") ''RemoteCtrlStopReason) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHSR") ''RemoteHostStopReason) +$(JQ.deriveJSON defaultJSON ''ZstdRow) + $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse) $(JQ.deriveFromJSON defaultJSON ''ArchiveConfig) diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index a755353da..f597fe1ca 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -111,15 +111,18 @@ module Simplex.Chat.Store.Messages getGroupSndStatuses, getGroupSndStatusCounts, getGroupHistoryItems, + testZstd, ) where +import qualified Codec.Compression.Zstd as Zstd import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B import Data.Either (fromRight, rights) import Data.Int (Int64) import Data.List (sortBy) @@ -131,7 +134,7 @@ import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime (..), getCurrentTime) import Database.SQLite.Simple (NamedParam (..), Only (..), Query, (:.) (..)) import Database.SQLite.Simple.QQ (sql) -import Simplex.Chat.Controller (ChatListQuery (..), ChatPagination (..), PaginationByTime (..)) +import Simplex.Chat.Controller (ChatListQuery (..), ChatPagination (..), PaginationByTime (..), ZstdRow (..)) import Simplex.Chat.Markdown import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent @@ -146,7 +149,7 @@ import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) -import Simplex.Messaging.Util (eitherToMaybe) +import Simplex.Messaging.Util (eitherToMaybe, (<$$>)) import Simplex.Messaging.Version (VersionRange) import UnliftIO.STM @@ -2543,3 +2546,16 @@ getGroupHistoryItems db user@User {userId} GroupInfo {groupId} count = do LIMIT ? |] (userId, groupId, rcvMsgContentTag, sndMsgContentTag, count) + +testZstd :: DB.Connection -> IO [ZstdRow] +testZstd db = process <$$> DB.query_ db "SELECT msg_body FROM messages" + where + process (Only msg_body) = + ZstdRow + { raw = B.length msg_body, + z1 = B.length $ Zstd.compress 1 msg_body, + z3 = B.length $ Zstd.compress 3 msg_body, + z6 = B.length $ Zstd.compress 6 msg_body, + z9 = B.length $ Zstd.compress 9 msg_body, + z = B.length $ Zstd.compress Zstd.maxCLevel msg_body + } diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index b6bb7807c..aea57ad4b 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -386,6 +386,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRChatErrors u errs -> ttyUser' u $ concatMap (viewChatError logLevel testView) errs CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)] CRTimedAction _ _ -> [] + CRZstdTest {zstdRows} -> map (\ZstdRow {raw, z1, z3, z6, z9, z} -> plain . T.unwords $ map tshow [raw, z1, z3, z6, z9, z]) zstdRows where ttyUser :: User -> [StyledString] -> [StyledString] ttyUser user@User {showNtfs, activeUser} ss