chat: add /zstd

package.yaml

@@ -49,6 +49,7 @@ dependencies:
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
   - zip == 2.0.*
+  - zstd
 
 flags:
   swift:

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

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))),

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)

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
+        }

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