core: clean up msg compression

cabal.project

@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: e04705d9c5e6b3d3652f909a5176c375acf29411
+    tag: d1b7b5e5a3a89f9050bcf3af641bf4936167dd94
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."317f2d5552332eb5d26a15ede87887e59408a10b" = "1dc4nv5zcbv4712sjv0ncyswdcx4igwzhgybx1rd9x6a7mwv2kr5";
+  "https://github.com/simplex-chat/simplexmq.git"."d1b7b5e5a3a89f9050bcf3af641bf4936167dd94" = "1bxspgh7yh1y9m24xy9jq19dbbxkjq725rc5rbiswj384275ndyr";
   "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
   "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";

src/Simplex/Chat.hs

@@ -6090,7 +6090,7 @@ batchSndMessagesJSON = batchMessages (maxEncodedMsgLength PQEncOff) . L.toList
 --   compressed <- liftIO $ withCompressCtx maxChatMsgSize $ \cctx -> mapM (compressForBatch cctx) msgs
 --   pure . map toMsgBatch . SMP.batchTransmissions_ (maxEncodedMsgLength PQEncOff) $ L.zip compressed msgs
 --   where
---     compressForBatch cctx SndMessage {msgBody} = bimap (const TELargeMsg) smpEncode <$> compress cctx msgBody
+--     compressForBatch cctx SndMessage {msgBody} = smpEncode <$> compress cctx msgBody
 --     toMsgBatch :: SMP.TransportBatch SndMessage -> Either ChatError MsgBatch
 --     toMsgBatch = \case
 --       SMP.TBTransmissions combined _n sms -> Right $ MsgBatch (markCompressedBatch combined) sms
@@ -6112,9 +6112,7 @@ directMessagePQ pqEnc maxMsgSize chatMsgEvent = do
       | otherwise -> pure encodedBody
     ECMLarge -> throwChatError $ CEException "large message"
   where
-    compressedBatchMsgBody msgBody =
-      liftEitherError (ChatError . CEException . mappend "compressedBatchMsgBody: ") $
-        withCompressCtx (B.length msgBody) (`compressedBatchMsgBody_` msgBody)
+    compressedBatchMsgBody msgBody = liftIO $ withCompressCtx (fromIntegral $ B.length msgBody) (`compressedBatchMsgBody_` msgBody)
 
 deliverMessage :: ChatMonad m => Connection -> CR.PQEncryption -> CMEventTag e -> MsgBody -> MessageId -> m (Int64, CR.PQEncryption)
 deliverMessage conn pqEnc cmEventTag msgBody msgId = do
@@ -6139,11 +6137,10 @@ deliverMessagesB msgReqs = do
   void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent)
   withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent
   where
-    compressBodies = liftIO $ withCompressCtx maxRawMsgLength $ \cctx ->
+    compressBodies = liftIO $ withCompressCtx (fromIntegral maxRawMsgLength) $ \cctx ->
       forM msgReqs $ \case
         mr@(Right (conn, pqEnc, msgFlags, msgBody, msgId))
-          | pqEnc == CR.PQEncOn -> do
-              bimap (ChatError . CEException) (\cBody -> (conn, pqEnc, msgFlags, cBody, msgId)) <$> compressedBatchMsgBody_ cctx msgBody
+          | pqEnc == CR.PQEncOn -> compressedBatchMsgBody_ cctx msgBody >>= \msgBodyC -> pure $ Right (conn, pqEnc, msgFlags, msgBodyC, msgId)
           | otherwise -> pure mr
         skip -> pure skip
     toAgent = \case

src/Simplex/Chat/Protocol.hs

@@ -52,7 +52,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
 import Simplex.Messaging.Protocol (MsgBody)
-import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$$>), (<$?>))
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
 import Simplex.Messaging.Version hiding (version)
 
 -- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
@@ -561,8 +561,8 @@ parseChatMessages s = case B.head s of
       Left e -> [Left e]
       Right compressed -> concatMap (either (pure . Left) parseChatMessages) . L.toList $ decompressBatch maxRawMsgLength compressed
 
-compressedBatchMsgBody_ :: CompressCtx -> MsgBody -> IO (Either String ByteString)
-compressedBatchMsgBody_ ctx msgBody = markCompressedBatch . smpEncode . (L.:| []) <$$> compress ctx msgBody
+compressedBatchMsgBody_ :: CompressCtx -> MsgBody -> IO MsgBody
+compressedBatchMsgBody_ ctx msgBody = markCompressedBatch . smpEncode . (L.:| []) <$> compress ctx msgBody
 
 markCompressedBatch :: ByteString -> ByteString
 markCompressedBatch = B.cons 'X'