Merge remote-tracking branch 'origin/ab/zstd' into ab/zstd

package.yaml

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

simplex-chat.cabal

@@ -216,6 +216,7 @@ library
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*
+    , zstd
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -277,6 +278,7 @@ executable simplex-bot
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*
+    , zstd
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -338,6 +340,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
@@ -401,6 +404,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
@@ -464,6 +468,7 @@ executable simplex-chat
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
     , zip ==2.0.*
+    , zstd
   default-language: Haskell2010
   if flag(swift)
     cpp-options: -DswiftJSON
@@ -530,6 +535,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
@@ -626,6 +632,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

@@ -455,6 +455,14 @@ processChatCommand cmd =
 
 processChatCommand' :: forall m. ChatMonad m => (PQSupport -> VersionRangeChat) -> 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
@@ -6737,7 +6745,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

@@ -216,7 +216,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)
@@ -726,6 +727,12 @@ data ChatResponse
   | CRArchiveImported {archiveErrors :: [ArchiveError]}
   | CRAppSettings {appSettings :: AppSettings}
   | 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
@@ -1403,6 +1410,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,18 +111,21 @@ 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)
+import Data.List (sortBy, sortOn)
 import Data.Maybe (fromMaybe, isJust, mapMaybe)
 import Data.Ord (Down (..), comparing)
 import Data.Text (Text)
@@ -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
@@ -147,8 +150,10 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (PQSupport)
 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
+import Debug.Trace
 
 deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
 deleteContactCIs db user@User {userId} ct@Contact {contactId} = do
@@ -2544,3 +2549,24 @@ getGroupHistoryItems db user@User {userId} GroupInfo {groupId} count = do
             LIMIT ?
           |]
           (userId, groupId, rcvMsgContentTag, sndMsgContentTag, count)
+
+testZstd :: DB.Connection -> IO [ZstdRow]
+testZstd db = do
+  samples <- fromOnly <$$> DB.query_ db "SELECT msg_body FROM messages"
+  let totalSize = sum $ map B.length samples
+      maxDictSize = totalSize `div` 100
+  dict16k <- either fail pure $ Zstd.trainFromSamples (1024 * 16) samples
+  dict100k <- either fail pure $ Zstd.trainFromSamples (1024 * 100) samples
+  dictMax <- either fail pure $ Zstd.trainFromSamples maxDictSize samples
+  traceShowM ('D', Zstd.getDictID dict100k, (totalSize, maxDictSize))
+  pure $ sortOn raw $ map (process dict16k dict100k dictMax) samples
+  where
+    process dict1 dict2 dict3 msg_body =
+      ZstdRow
+        { raw = B.length msg_body,
+          z1 = B.length $ Zstd.compress 1 msg_body,
+          z3 = B.length $ Zstd.compressUsingDict dict1 1 msg_body,
+          z6 = B.length $ Zstd.compressUsingDict dict2 1 msg_body,
+          z9 = B.length $ Zstd.compressUsingDict dict3 1 msg_body,
+          z = B.length $ Zstd.compress Zstd.maxCLevel msg_body
+        }

src/Simplex/Chat/View.hs

@@ -391,6 +391,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
   CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)]
   CRAppSettings as -> ["app settings: " <> plain (LB.unpack $ J.encode as)]
   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