Merge branch 'stable' into stable-ios

This commit is contained in:
Evgeny Poberezkin 2024-01-18 20:59:49 +00:00
commit bf25b116d7
No known key found for this signature in database
GPG Key ID: 494BDDD9A28B577D
18 changed files with 64 additions and 75 deletions

View File

@ -9,6 +9,7 @@ on:
tags: tags:
- "v*" - "v*"
- "!*-fdroid" - "!*-fdroid"
- "!*-armv7a"
pull_request: pull_request:
jobs: jobs:

View File

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

View File

@ -1,5 +1,5 @@
name: simplex-chat name: simplex-chat
version: 5.4.3.0 version: 5.4.4.0
#synopsis: #synopsis:
#description: #description:
homepage: https://github.com/simplex-chat/simplex-chat#readme homepage: https://github.com/simplex-chat/simplex-chat#readme

View File

@ -37,12 +37,12 @@ for ((i = 0 ; i < ${#arches[@]}; i++)); do
mkdir -p "$output_dir" 2> /dev/null mkdir -p "$output_dir" 2> /dev/null
curl --location -o libsupport.zip $job_repo/$arch-android:lib:support.x86_64-linux/latest/download/1 && \ curl --tlsv1.2 --location -o libsupport.zip $job_repo/$arch-android:lib:support.x86_64-linux/latest/download/1 && \
unzip -o libsupport.zip && \ unzip -o libsupport.zip && \
mv libsupport.so "$output_dir" && \ mv libsupport.so "$output_dir" && \
rm libsupport.zip rm libsupport.zip
curl --location -o libsimplex.zip "$job_repo"/"$arch"-android:lib:simplex-chat.x86_64-linux/latest/download/1 && \ curl --tlsv1.2 --location -o libsimplex.zip "$job_repo"/"$arch"-android:lib:simplex-chat.x86_64-linux/latest/download/1 && \
unzip -o libsimplex.zip && \ unzip -o libsimplex.zip && \
mv libsimplex.so "$output_dir" && \ mv libsimplex.so "$output_dir" && \
rm libsimplex.zip rm libsimplex.zip

View File

@ -37,7 +37,7 @@ cp *imple*.desktop usr/share/applications/
cp $multiplatform_dir/desktop/src/jvmMain/resources/distribute/*.appdata.xml usr/share/metainfo cp $multiplatform_dir/desktop/src/jvmMain/resources/distribute/*.appdata.xml usr/share/metainfo
if [ ! -f ../appimagetool-x86_64.AppImage ]; then if [ ! -f ../appimagetool-x86_64.AppImage ]; then
wget https://github.com/AppImage/appimagetool/releases/download/continuous/appimagetool-x86_64.AppImage -O ../appimagetool-x86_64.AppImage wget --secure-protocol=TLSv1_3 https://github.com/AppImage/appimagetool/releases/download/continuous/appimagetool-x86_64.AppImage -O ../appimagetool-x86_64.AppImage
chmod +x ../appimagetool-x86_64.AppImage chmod +x ../appimagetool-x86_64.AppImage
fi fi
../appimagetool-x86_64.AppImage . ../appimagetool-x86_64.AppImage .

View File

@ -12,7 +12,7 @@ cd $root_dir
if [ ! -f dist-newstyle/openssl-1.1.1w/libcrypto-1_1-x64.dll ]; then if [ ! -f dist-newstyle/openssl-1.1.1w/libcrypto-1_1-x64.dll ]; then
mkdir dist-newstyle 2>/dev/null || true mkdir dist-newstyle 2>/dev/null || true
cd dist-newstyle cd dist-newstyle
curl https://www.openssl.org/source/openssl-1.1.1w.tar.gz -o openssl.tar.gz curl --tlsv1.2 https://www.openssl.org/source/openssl-1.1.1w.tar.gz -o openssl.tar.gz
$WINDIR\\System32\\tar.exe -xvzf openssl.tar.gz $WINDIR\\System32\\tar.exe -xvzf openssl.tar.gz
cd openssl-1.1.1w cd openssl-1.1.1w
./Configure mingw64 ./Configure mingw64

View File

@ -14,7 +14,7 @@ mkdir $vlc_dir || exit 0
cd /tmp cd /tmp
mkdir tmp 2>/dev/null || true mkdir tmp 2>/dev/null || true
cd tmp cd tmp
curl https://github.com/cmatomic/VLCplayer-AppImage/releases/download/3.0.11.1/VLC_media_player-3.0.11.1-x86_64.AppImage -L -o appimage curl --tlsv1.2 https://github.com/cmatomic/VLCplayer-AppImage/releases/download/3.0.11.1/VLC_media_player-3.0.11.1-x86_64.AppImage -L -o appimage
chmod +x appimage chmod +x appimage
./appimage --appimage-extract ./appimage --appimage-extract
cp -r squashfs-root/usr/lib/* $vlc_dir cp -r squashfs-root/usr/lib/* $vlc_dir
@ -28,7 +28,7 @@ cd /tmp
( (
mkdir tmp mkdir tmp
cd tmp cd tmp
curl http://archive.ubuntu.com/ubuntu/pool/universe/v/vlc/libvlc5_3.0.9.2-1_amd64.deb -o libvlc curl --tlsv1.2 https://archive.ubuntu.com/ubuntu/pool/universe/v/vlc/libvlc5_3.0.9.2-1_amd64.deb -o libvlc
ar p libvlc data.tar.xz > data.tar.xz ar p libvlc data.tar.xz > data.tar.xz
tar -xvf data.tar.xz tar -xvf data.tar.xz
mv usr/lib/x86_64-linux-gnu/libvlc.so{.5,} mv usr/lib/x86_64-linux-gnu/libvlc.so{.5,}
@ -40,7 +40,7 @@ rm -rf tmp
( (
mkdir tmp mkdir tmp
cd tmp cd tmp
curl http://archive.ubuntu.com/ubuntu/pool/universe/v/vlc/libvlccore9_3.0.9.2-1_amd64.deb -o libvlccore curl --tlsv1.2 https://archive.ubuntu.com/ubuntu/pool/universe/v/vlc/libvlccore9_3.0.9.2-1_amd64.deb -o libvlccore
ar p libvlccore data.tar.xz > data.tar.xz ar p libvlccore data.tar.xz > data.tar.xz
tar -xvf data.tar.xz tar -xvf data.tar.xz
cp usr/lib/x86_64-linux-gnu/libvlccore.so* $vlc_dir cp usr/lib/x86_64-linux-gnu/libvlccore.so* $vlc_dir
@ -51,7 +51,7 @@ rm -rf tmp
( (
mkdir tmp mkdir tmp
cd tmp cd tmp
curl http://mirrors.edge.kernel.org/ubuntu/pool/universe/v/vlc/vlc-plugin-base_3.0.9.2-1_amd64.deb -o plugins curl --tlsv1.2 https://mirrors.edge.kernel.org/ubuntu/pool/universe/v/vlc/vlc-plugin-base_3.0.9.2-1_amd64.deb -o plugins
ar p plugins data.tar.xz > data.tar.xz ar p plugins data.tar.xz > data.tar.xz
tar -xvf data.tar.xz tar -xvf data.tar.xz
find usr/lib/x86_64-linux-gnu/vlc/plugins/ -name "lib*.so*" -exec patchelf --set-rpath '$ORIGIN/../../' {} \; find usr/lib/x86_64-linux-gnu/vlc/plugins/ -name "lib*.so*" -exec patchelf --set-rpath '$ORIGIN/../../' {} \;
@ -63,7 +63,7 @@ rm -rf tmp
( (
mkdir tmp mkdir tmp
cd tmp cd tmp
curl http://archive.ubuntu.com/ubuntu/pool/main/libi/libidn/libidn11_1.33-2.2ubuntu2_amd64.deb -o idn curl --tlsv1.2 https://archive.ubuntu.com/ubuntu/pool/main/libi/libidn/libidn11_1.33-2.2ubuntu2_amd64.deb -o idn
ar p idn data.tar.xz > data.tar.xz ar p idn data.tar.xz > data.tar.xz
tar -xvf data.tar.xz tar -xvf data.tar.xz
cp lib/x86_64-linux-gnu/lib* $vlc_dir cp lib/x86_64-linux-gnu/lib* $vlc_dir

View File

@ -23,7 +23,7 @@ mkdir -p $vlc_dir/vlc || exit 0
cd /tmp cd /tmp
mkdir tmp 2>/dev/null || true mkdir tmp 2>/dev/null || true
cd tmp cd tmp
curl https://github.com/simplex-chat/vlc/releases/download/v$vlc_version/vlc-macos-$ARCH.zip -L -o vlc curl --tlsv1.2 https://github.com/simplex-chat/vlc/releases/download/v$vlc_version/vlc-macos-$ARCH.zip -L -o vlc
unzip -oqq vlc unzip -oqq vlc
install_name_tool -add_rpath "@loader_path/VLC.app/Contents/MacOS/lib" vlc-cache-gen install_name_tool -add_rpath "@loader_path/VLC.app/Contents/MacOS/lib" vlc-cache-gen
cd VLC.app/Contents/MacOS/lib cd VLC.app/Contents/MacOS/lib

View File

@ -13,7 +13,7 @@ mkdir -p $vlc_dir/vlc || exit 0
cd /tmp cd /tmp
mkdir tmp 2>/dev/null || true mkdir tmp 2>/dev/null || true
cd tmp cd tmp
curl https://irltoolkit.mm.fcix.net/videolan-ftp/vlc/3.0.18/win64/vlc-3.0.18-win64.zip -L -o vlc curl --tlsv1.2 https://irltoolkit.mm.fcix.net/videolan-ftp/vlc/3.0.18/win64/vlc-3.0.18-win64.zip -L -o vlc
$WINDIR\\System32\\tar.exe -xf vlc $WINDIR\\System32\\tar.exe -xf vlc
cd vlc-* cd vlc-*
# Setting the same date as the date that will be on the file after extraction from JAR to make VLC cache checker happy # Setting the same date as the date that will be on the file after extraction from JAR to make VLC cache checker happy

View File

@ -35,7 +35,7 @@ for ((i = 0 ; i < ${#arches[@]}; i++)); do
output_arch="${output_arches[$i]}" output_arch="${output_arches[$i]}"
output_dir="$HOME/Downloads" output_dir="$HOME/Downloads"
curl --location -o "$output_dir"/pkg-ios-"$arch"-swift-json.zip "$job_repo"/"$arch"-darwin-ios:lib:simplex-chat."$arch"-darwin/latest/download/1 && \ curl --tlsv1.2 --location -o "$output_dir"/pkg-ios-"$arch"-swift-json.zip "$job_repo"/"$arch"-darwin-ios:lib:simplex-chat."$arch"-darwin/latest/download/1 && \
unzip -o "$output_dir"/pkg-ios-"$output_arch"-swift-json.zip -d ~/Downloads/pkg-ios-"$output_arch"-swift-json unzip -o "$output_dir"/pkg-ios-"$output_arch"-swift-json.zip -d ~/Downloads/pkg-ios-"$output_arch"-swift-json
done done
sh "$root_dir"/scripts/ios/prepare-x86_64.sh sh "$root_dir"/scripts/ios/prepare-x86_64.sh

View File

@ -1,5 +1,5 @@
{ {
"https://github.com/simplex-chat/simplexmq.git"."ad8cd1d5154617663065652b45c784ad5a0a584d" = "19sinz1gynab776x8h9va7r6ifm9pmgzljsbc7z5cbkcnjl5sfh3"; "https://github.com/simplex-chat/simplexmq.git"."f6ed4640d407f8879273d104a3e69069806dcb7c" = "072rakv697f85i8ldjl7bj7jc7vfmzphasx2i4ynwgz3kksydfp5";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "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/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";

View File

@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
name: simplex-chat name: simplex-chat
version: 5.4.3.0 version: 5.4.4.0
category: Web, System, Services, Cryptography category: Web, System, Services, Cryptography
homepage: https://github.com/simplex-chat/simplex-chat#readme homepage: https://github.com/simplex-chat/simplex-chat#readme
author: simplex.chat author: simplex.chat

View File

@ -28,7 +28,6 @@ import Data.Bifunctor (bimap, first)
import Data.ByteArray (ScrubbedBytes) import Data.ByteArray (ScrubbedBytes)
import qualified Data.ByteArray as BA import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
@ -5657,8 +5656,7 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
processBatch batch `catchChatError` (toView . CRChatError (Just user)) processBatch batch `catchChatError` (toView . CRChatError (Just user))
where where
processBatch :: MsgBatch -> m () processBatch :: MsgBatch -> m ()
processBatch (MsgBatch builder sndMsgs) = do processBatch (MsgBatch batchBody sndMsgs) = do
let batchBody = LB.toStrict $ toLazyByteString builder
agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) MsgFlags {notification = True} batchBody agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) MsgFlags {notification = True} batchBody
let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId} let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
void . withStoreBatch' $ \db -> map (\SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId) sndMsgs void . withStoreBatch' $ \db -> map (\SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId) sndMsgs
@ -5678,28 +5676,28 @@ directMessage chatMsgEvent = do
chatVRange <- chatVersionRange chatVRange <- chatVersionRange
let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent} let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
case r of case r of
ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody ECMEncoded encodedBody -> pure encodedBody
ECMLarge -> throwChatError $ CEException "large message" ECMLarge -> throwChatError $ CEException "large message"
deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> LazyMsgBody -> MessageId -> m Int64 deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> MessageId -> m Int64
deliverMessage conn cmEventTag msgBody msgId = do deliverMessage conn cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag} let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
deliverMessage' conn msgFlags msgBody msgId deliverMessage' conn msgFlags msgBody msgId
deliverMessage' :: ChatMonad m => Connection -> MsgFlags -> LazyMsgBody -> MessageId -> m Int64 deliverMessage' :: ChatMonad m => Connection -> MsgFlags -> MsgBody -> MessageId -> m Int64
deliverMessage' conn msgFlags msgBody msgId = deliverMessage' conn msgFlags msgBody msgId =
deliverMessages [(conn, msgFlags, msgBody, msgId)] >>= \case deliverMessages [(conn, msgFlags, msgBody, msgId)] >>= \case
[r] -> liftEither r [r] -> liftEither r
rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs)
deliverMessages :: ChatMonad' m => [(Connection, MsgFlags, LazyMsgBody, MessageId)] -> m [Either ChatError Int64] deliverMessages :: ChatMonad' m => [(Connection, MsgFlags, MsgBody, MessageId)] -> m [Either ChatError Int64]
deliverMessages msgReqs = do deliverMessages msgReqs = do
sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessages` aReqs) sent <- zipWith prepareBatch msgReqs <$> withAgent' (`sendMessages` aReqs)
withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent withStoreBatch $ \db -> map (bindRight $ createDelivery db) sent
where where
aReqs = map (\(conn, msgFlags, msgBody, _msgId) -> (aConnId conn, msgFlags, LB.toStrict msgBody)) msgReqs aReqs = map (\(conn, msgFlags, msgBody, _msgId) -> (aConnId conn, msgFlags, msgBody)) msgReqs
prepareBatch req = bimap (`ChatErrorAgent` Nothing) (req,) prepareBatch req = bimap (`ChatErrorAgent` Nothing) (req,)
createDelivery :: DB.Connection -> ((Connection, MsgFlags, LazyMsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64) createDelivery :: DB.Connection -> ((Connection, MsgFlags, MsgBody, MessageId), AgentMsgId) -> IO (Either ChatError Int64)
createDelivery db ((Connection {connId}, _, _, msgId), agentMsgId) = createDelivery db ((Connection {connId}, _, _, msgId), agentMsgId) =
Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId Right <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId

View File

@ -21,7 +21,6 @@ import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.TH as JQ
import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Int (Int64) import Data.Int (Int64)
@ -763,12 +762,10 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
Just Refl -> Right x Just Refl -> Right x
Nothing -> Left "bad chat type" Nothing -> Left "bad chat type"
type LazyMsgBody = L.ByteString
data SndMessage = SndMessage data SndMessage = SndMessage
{ msgId :: MessageId, { msgId :: MessageId,
sharedMsgId :: SharedMsgId, sharedMsgId :: SharedMsgId,
msgBody :: LazyMsgBody msgBody :: MsgBody
} }
deriving (Show) deriving (Show)
@ -790,7 +787,7 @@ data RcvMessage = RcvMessage
data PendingGroupMessage = PendingGroupMessage data PendingGroupMessage = PendingGroupMessage
{ msgId :: MessageId, { msgId :: MessageId,
cmEventTag :: ACMEventTag, cmEventTag :: ACMEventTag,
msgBody :: LazyMsgBody, msgBody :: MsgBody,
introId_ :: Maybe Int64 introId_ :: Maybe Int64
} }

View File

@ -1,40 +1,36 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Messages.Batch module Simplex.Chat.Messages.Batch (
( MsgBatch (..), MsgBatch (..),
batchMessages, batchMessages,
) ) where
where
import Data.ByteString.Builder (Builder, charUtf8, lazyByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Char8 as B
import Data.Int (Int64)
import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..)) import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..))
import Simplex.Chat.Messages import Simplex.Chat.Messages
data MsgBatch = MsgBatch Builder [SndMessage] data MsgBatch = MsgBatch ByteString [SndMessage]
-- | Batches [SndMessage] into batches of ByteString builders in form of JSON arrays. -- | Batches [SndMessage] into batches of ByteStrings in form of JSON arrays.
-- Does not check if the resulting batch is a valid JSON. -- Does not check if the resulting batch is a valid JSON.
-- If a single element is passed, it is returned as is (a JSON string). -- If a single element is passed, it is returned as is (a JSON string).
-- If an element exceeds maxLen, it is returned as ChatError. -- If an element exceeds maxLen, it is returned as ChatError.
batchMessages :: Int64 -> [SndMessage] -> [Either ChatError MsgBatch] batchMessages :: Int -> [SndMessage] -> [Either ChatError MsgBatch]
batchMessages maxLen msgs = batchMessages maxLen = addBatch . foldr addToBatch ([], [], 0, 0)
let (batches, batch, _, n) = foldr addToBatch ([], [], 0, 0) msgs
in if n == 0 then batches else msgBatch batch : batches
where where
msgBatch batch = Right (MsgBatch (encodeMessages batch) batch) msgBatch batch = Right (MsgBatch (encodeMessages batch) batch)
addToBatch :: SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int64, Int) addToBatch :: SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int, Int)
addToBatch msg@SndMessage {msgBody} (batches, batch, len, n) addToBatch msg@SndMessage {msgBody} acc@(batches, batch, len, n)
| batchLen <= maxLen = (batches, msg : batch, len', n + 1) | batchLen <= maxLen = (batches, msg : batch, len', n + 1)
| msgLen <= maxLen = (batches', [msg], msgLen, 1) | msgLen <= maxLen = (addBatch acc, [msg], msgLen, 1)
| otherwise = (errLarge msg : (if n == 0 then batches else batches'), [], 0, 0) | otherwise = (errLarge msg : addBatch acc, [], 0, 0)
where where
msgLen = LB.length msgBody msgLen = B.length msgBody
batches' = msgBatch batch : batches
len' len'
| n == 0 = msgLen | n == 0 = msgLen
| otherwise = msgLen + len + 1 -- 1 accounts for comma | otherwise = msgLen + len + 1 -- 1 accounts for comma
@ -42,11 +38,11 @@ batchMessages maxLen msgs =
| n == 0 = len' | n == 0 = len'
| otherwise = len' + 2 -- 2 accounts for opening and closing brackets | otherwise = len' + 2 -- 2 accounts for opening and closing brackets
errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId) errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId)
addBatch :: ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> [Either ChatError MsgBatch]
encodeMessages :: [SndMessage] -> Builder addBatch (batches, batch, _, n) = if n == 0 then batches else msgBatch batch : batches
encodeMessages = \case encodeMessages :: [SndMessage] -> ByteString
encodeMessages = \case
[] -> mempty [] -> mempty
[msg] -> encodeMsg msg [msg] -> body msg
(msg : msgs) -> charUtf8 '[' <> encodeMsg msg <> mconcat [charUtf8 ',' <> encodeMsg msg' | msg' <- msgs] <> charUtf8 ']' msgs -> B.concat ["[", B.intercalate "," (map body msgs), "]"]
where body SndMessage {msgBody} = msgBody
encodeMsg SndMessage {msgBody} = lazyByteString msgBody

View File

@ -29,9 +29,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w, w2c) import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.String import Data.String
import Data.Text (Text) import Data.Text (Text)
@ -491,20 +489,20 @@ $(JQ.deriveJSON defaultJSON ''QuotedMsg)
-- this limit reserves space for metadata in forwarded messages -- this limit reserves space for metadata in forwarded messages
-- 15780 (limit used for fileChunkSize) - 161 (x.grp.msg.forward overhead) = 15619, round to 15610 -- 15780 (limit used for fileChunkSize) - 161 (x.grp.msg.forward overhead) = 15619, round to 15610
maxChatMsgSize :: Int64 maxChatMsgSize :: Int
maxChatMsgSize = 15610 maxChatMsgSize = 15610
data EncodedChatMessage = ECMEncoded L.ByteString | ECMLarge data EncodedChatMessage = ECMEncoded ByteString | ECMLarge
encodeChatMessage :: MsgEncodingI e => ChatMessage e -> EncodedChatMessage encodeChatMessage :: MsgEncodingI e => ChatMessage e -> EncodedChatMessage
encodeChatMessage msg = do encodeChatMessage msg = do
case chatToAppMessage msg of case chatToAppMessage msg of
AMJson m -> do AMJson m -> do
let body = J.encode m let body = LB.toStrict $ J.encode m
if LB.length body > maxChatMsgSize if B.length body > maxChatMsgSize
then ECMLarge then ECMLarge
else ECMEncoded body else ECMEncoded body
AMBinary m -> ECMEncoded . LB.fromStrict $ strEncode m AMBinary m -> ECMEncoded $ strEncode m
parseChatMessages :: ByteString -> [Either String AChatMessage] parseChatMessages :: ByteString -> [Either String AChatMessage]
parseChatMessages "" = [Left "empty string"] parseChatMessages "" = [Left "empty string"]

View File

@ -7,8 +7,8 @@
module MessageBatching (batchingTests) where module MessageBatching (batchingTests) where
import Crypto.Number.Serialize (os2ip) import Crypto.Number.Serialize (os2ip)
import Data.ByteString.Builder (toLazyByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as B
import Data.Either (partitionEithers) import Data.Either (partitionEithers)
import Data.Int (Int64) import Data.Int (Int64)
import Data.String (IsString (..)) import Data.String (IsString (..))
@ -26,7 +26,7 @@ batchingTests = describe "message batching tests" $ do
it "image x.msg.new and x.msg.file.descr should fit into single batch" testImageFitsSingleBatch it "image x.msg.new and x.msg.file.descr should fit into single batch" testImageFitsSingleBatch
instance IsString SndMessage where instance IsString SndMessage where
fromString s = SndMessage {msgId, sharedMsgId = SharedMsgId "", msgBody = LB.fromStrict s'} fromString s = SndMessage {msgId, sharedMsgId = SharedMsgId "", msgBody = s'}
where where
s' = encodeUtf8 $ T.pack s s' = encodeUtf8 $ T.pack s
msgId = fromInteger $ os2ip s' msgId = fromInteger $ os2ip s'
@ -94,14 +94,14 @@ testImageFitsSingleBatch = do
-- 261_120 bytes (MAX_IMAGE_SIZE in UI), rounded up, example was 743 -- 261_120 bytes (MAX_IMAGE_SIZE in UI), rounded up, example was 743
let descrRoundedSize = 800 let descrRoundedSize = 800
let xMsgNewStr = LB.replicate xMsgNewRoundedSize 1 let xMsgNewStr = B.replicate xMsgNewRoundedSize 1
descrStr = LB.replicate descrRoundedSize 2 descrStr = B.replicate descrRoundedSize 2
msg s = SndMessage {msgId = 0, sharedMsgId = SharedMsgId "", msgBody = s} msg s = SndMessage {msgId = 0, sharedMsgId = SharedMsgId "", msgBody = s}
batched = "[" <> xMsgNewStr <> "," <> descrStr <> "]" batched = "[" <> xMsgNewStr <> "," <> descrStr <> "]"
runBatcherTest' maxChatMsgSize [msg xMsgNewStr, msg descrStr] [] [batched] runBatcherTest' maxChatMsgSize [msg xMsgNewStr, msg descrStr] [] [batched]
runBatcherTest :: Int64 -> [SndMessage] -> [ChatError] -> [LB.ByteString] -> Spec runBatcherTest :: Int -> [SndMessage] -> [ChatError] -> [ByteString] -> Spec
runBatcherTest maxLen msgs expectedErrors expectedBatches = runBatcherTest maxLen msgs expectedErrors expectedBatches =
it it
( (show (map (\SndMessage {msgBody} -> msgBody) msgs) <> ", limit " <> show maxLen <> ": should return ") ( (show (map (\SndMessage {msgBody} -> msgBody) msgs) <> ", limit " <> show maxLen <> ": should return ")
@ -110,10 +110,10 @@ runBatcherTest maxLen msgs expectedErrors expectedBatches =
) )
(runBatcherTest' maxLen msgs expectedErrors expectedBatches) (runBatcherTest' maxLen msgs expectedErrors expectedBatches)
runBatcherTest' :: Int64 -> [SndMessage] -> [ChatError] -> [LB.ByteString] -> IO () runBatcherTest' :: Int -> [SndMessage] -> [ChatError] -> [ByteString] -> IO ()
runBatcherTest' maxLen msgs expectedErrors expectedBatches = do runBatcherTest' maxLen msgs expectedErrors expectedBatches = do
let (errors, batches) = partitionEithers $ batchMessages maxLen msgs let (errors, batches) = partitionEithers $ batchMessages maxLen msgs
batchedStrs = map (\(MsgBatch builder _) -> toLazyByteString builder) batches batchedStrs = map (\(MsgBatch batchBody _) -> batchBody) batches
testErrors errors `shouldBe` testErrors expectedErrors testErrors errors `shouldBe` testErrors expectedErrors
batchedStrs `shouldBe` expectedBatches batchedStrs `shouldBe` expectedBatches
where where

View File

@ -7,7 +7,6 @@ module ProtocolTests where
import qualified Data.Aeson as J import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
@ -74,7 +73,7 @@ s ##== msg = do
let r = encodeChatMessage msg let r = encodeChatMessage msg
case r of case r of
ECMEncoded encodedBody -> ECMEncoded encodedBody ->
J.eitherDecodeStrict' (LB.toStrict encodedBody) J.eitherDecodeStrict' encodedBody
`shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value) `shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value)
ECMLarge -> expectationFailure $ "large message" ECMLarge -> expectationFailure $ "large message"