From 096498278244793124c7fdfe10bf6328ad1d0683 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 23 May 2024 22:50:23 +0100 Subject: [PATCH 1/2] core: ensure that messages are sent to different members (#4221) * core: ensure that messages are sent to different members * update simplexmq --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 37 +++++++++++++++++++++++-------------- src/Simplex/Chat/Archive.hs | 1 + src/Simplex/Chat/Util.hs | 30 ++++++++++++++++++++++++++++++ tests/ChatTests/Direct.hs | 7 ++++--- 6 files changed, 60 insertions(+), 19 deletions(-) diff --git a/cabal.project b/cabal.project index c95e3c8f0c..62764bb139 100644 --- a/cabal.project +++ b/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: 769e54db76fc33a04085410cdf78ae77ed9717b6 + tag: 6309f92c6860fce39d6675eb92fc460bdc3db01d source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 40cfbdb8e0..74286532bd 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."769e54db76fc33a04085410cdf78ae77ed9717b6" = "01bwy6hnkpp51jzdym8880462003npgzb2lns5946nww2smybrk6"; + "https://github.com/simplex-chat/simplexmq.git"."6309f92c6860fce39d6675eb92fc460bdc3db01d" = "0aiyjcjraispkripv1viry6357nxvydv2sb6k5ali0hr8cnsskg3"; "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"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index d56e731246..55eecd499f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -46,6 +47,7 @@ import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -1681,7 +1683,7 @@ processChatCommand' vr = \case sndMsgs <- lift $ createSndMessages idsEvts let msgReqs_ :: NonEmpty (Either ChatError MsgReq) = L.zipWith (fmap . ctMsgReq) ctConns sndMsgs (errs, ctSndMsgs :: [(Contact, SndMessage)]) <- - lift $ partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_ + partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_ timestamp <- liftIO getCurrentTime lift . void $ withStoreBatch' $ \db -> map (createCI db user timestamp) ctSndMsgs pure CRBroadcastSent {user, msgContent = mc, successes = length ctSndMsgs, failures = length errs, timestamp} @@ -2378,7 +2380,7 @@ processChatCommand' vr = \case Just changedCts -> do let idsEvts = L.map ctSndEvent changedCts msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts - (errs, cts) <- lift $ partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_ + (errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_ unless (null errs) $ toView $ CRChatErrors (Just user) errs let changedCts' = filter (\ChangedProfileContact {ct, ct'} -> directOrUsed ct' && mergedPreferences ct' /= mergedPreferences ct) cts lift $ createContactsSndFeatureItems user' changedCts' @@ -6471,21 +6473,21 @@ deliverMessage conn cmEventTag msgBody msgId = do deliverMessage' :: Connection -> MsgFlags -> MsgBody -> MessageId -> CM (Int64, PQEncryption) deliverMessage' conn msgFlags msgBody msgId = - lift (deliverMessages ((conn, msgFlags, msgBody, msgId) :| [])) >>= \case + deliverMessages ((conn, msgFlags, msgBody, msgId) :| []) >>= \case r :| [] -> liftEither r rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) type MsgReq = (Connection, MsgFlags, MsgBody, MessageId) -deliverMessages :: NonEmpty MsgReq -> CM' (NonEmpty (Either ChatError (Int64, PQEncryption))) +deliverMessages :: NonEmpty MsgReq -> CM (NonEmpty (Either ChatError (Int64, PQEncryption))) deliverMessages msgs = deliverMessagesB $ L.map Right msgs -deliverMessagesB :: NonEmpty (Either ChatError MsgReq) -> CM' (NonEmpty (Either ChatError (Int64, PQEncryption))) +deliverMessagesB :: NonEmpty (Either ChatError MsgReq) -> CM (NonEmpty (Either ChatError (Int64, PQEncryption))) deliverMessagesB msgReqs = do msgReqs' <- liftIO compressBodies - sent <- L.zipWith prepareBatch msgReqs' <$> withAgent' (`sendMessagesB` L.map toAgent msgReqs') - void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) - withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent + sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` L.map toAgent msgReqs') + lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) + lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent where compressBodies = forME msgReqs $ \mr@(conn@Connection {pqSupport, connChatVersion = v}, msgFlags, msgBody, msgId) -> @@ -6544,10 +6546,11 @@ sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId) recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) let msgFlags = MsgFlags {notification = hasNotification $ toCMEventTag chatMsgEvent} - (toSend, pending) = foldr addMember ([], []) recipientMembers + (toSend, pending, _, dups) = foldr addMember ([], [], S.empty, 0 :: Int) recipientMembers -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here msgReqs = map (\(_, conn) -> (conn, msgFlags, msgBody, msgId)) toSend - delivered <- maybe (pure []) (fmap L.toList . lift . deliverMessages) $ L.nonEmpty msgReqs + when (dups /= 0) $ logError $ "sendGroupMessage: " <> tshow dups <> " duplicate members" + delivered <- maybe (pure []) (fmap L.toList . deliverMessages) $ L.nonEmpty msgReqs let errors = lefts delivered unless (null errors) $ toView $ CRChatErrors (Just user) errors stored <- lift . withStoreBatch' $ \db -> map (\m -> createPendingGroupMessage db (groupMemberId' m) msgId Nothing) pending @@ -6560,10 +6563,16 @@ sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do liftM2 (<>) (shuffle adminMs) (shuffle otherMs) where isAdmin GroupMember {memberRole} = memberRole >= GRAdmin - addMember m (toSend, pending) = case memberSendAction chatMsgEvent members m of - Just (MSASend conn) -> ((m, conn) : toSend, pending) - Just MSAPending -> (toSend, m : pending) - Nothing -> (toSend, pending) + addMember m acc@(toSend, pending, !mIds, !dups) = case memberSendAction chatMsgEvent members m of + Just a + | mId `S.member` mIds -> (toSend, pending, mIds, dups + 1) + | otherwise -> case a of + MSASend conn -> ((m, conn) : toSend, pending, mIds', dups) + MSAPending -> (toSend, m : pending, mIds', dups) + Nothing -> acc + where + mId = groupMemberId' m + mIds' = S.insert mId mIds filterSent :: [Either ChatError a] -> [mem] -> (mem -> GroupMember) -> [GroupMember] filterSent rs ms mem = [mem m | (Right _, m) <- zip rs ms] diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index 8550c03438..01897de791 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -26,6 +26,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Database.SQLite3 as SQL import Simplex.Chat.Controller +import Simplex.Chat.Util () import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), closeSQLiteStore, keyString, sqlString, storeKey) import Simplex.Messaging.Util diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs index 2b2bd599ae..3f7d19fd6d 100644 --- a/src/Simplex/Chat/Util.hs +++ b/src/Simplex/Chat/Util.hs @@ -1,10 +1,18 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Simplex.Chat.Util (week, encryptFile, chunkSize, liftIOEither, shuffle) where +import Control.Exception (Exception) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO (..)) +import Control.Monad.Reader +import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as LB import Data.List (sortBy) import Data.Ord (comparing) @@ -13,6 +21,7 @@ import Data.Word (Word16) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF import System.Random (randomRIO) +import qualified UnliftIO.Exception as E import UnliftIO.IO (IOMode (..), withFile) week :: NominalDiffTime @@ -46,3 +55,24 @@ shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) x liftIOEither :: (MonadIO m, MonadError e m) => IO (Either e a) -> m a liftIOEither a = liftIO a >>= liftEither {-# INLINE liftIOEither #-} + +newtype InternalException e = InternalException {unInternalException :: e} + deriving (Eq, Show) + +instance Exception e => Exception (InternalException e) + +instance Exception e => MonadUnliftIO (ExceptT e IO) where + {-# INLINE withRunInIO #-} + withRunInIO :: ((forall a. ExceptT e IO a -> IO a) -> IO b) -> ExceptT e IO b + withRunInIO inner = + ExceptT . fmap (first unInternalException) . E.try $ + withRunInIO $ \run -> + inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) + +instance Exception e => MonadUnliftIO (ExceptT e (ReaderT r IO)) where + {-# INLINE withRunInIO #-} + withRunInIO :: ((forall a. ExceptT e (ReaderT r IO) a -> IO a) -> IO b) -> ExceptT e (ReaderT r IO) b + withRunInIO inner = + withExceptT unInternalException . ExceptT . E.try $ + withRunInIO $ \run -> + inner $ run . (either (E.throwIO . InternalException) pure <=< runExceptT) diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 82eb4def39..1579dedaa7 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -185,9 +185,10 @@ testAddContact = versionTestMatrix2 runTestAddContact bob #$> ("/_read chat @2", id, "ok") alice #$> ("/read user", id, "ok") alice #$> ("/_read user 1", id, "ok") - features = if pqExpected - then chatFeatures - else (0, e2eeInfoNoPQStr) : tail chatFeatures + features = + if pqExpected + then chatFeatures + else (0, e2eeInfoNoPQStr) : tail chatFeatures testDuplicateContactsSeparate :: HasCallStack => FilePath -> IO () testDuplicateContactsSeparate = From b0516b64408b8b41350ef04450a1b15a5f1d8c7a Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 25 May 2024 11:18:49 +0100 Subject: [PATCH 2/2] core: 5.7.4.1 --- cabal.project | 2 +- package.yaml | 2 +- scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 62764bb139..9efbb332ff 100644 --- a/cabal.project +++ b/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: 6309f92c6860fce39d6675eb92fc460bdc3db01d + tag: df35c50b99a1291aac3ff86ed71387bb4f03c984 source-repository-package type: git diff --git a/package.yaml b/package.yaml index fa4d066c6b..606cd16b4e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplex-chat -version: 5.7.4.0 +version: 5.7.4.1 #synopsis: #description: homepage: https://github.com/simplex-chat/simplex-chat#readme diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 74286532bd..7c11ea0e9f 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."6309f92c6860fce39d6675eb92fc460bdc3db01d" = "0aiyjcjraispkripv1viry6357nxvydv2sb6k5ali0hr8cnsskg3"; + "https://github.com/simplex-chat/simplexmq.git"."df35c50b99a1291aac3ff86ed71387bb4f03c984" = "0a3vvay14a0f7ypl94fag23g0z7b1kpq3l36kw6jgb0fjhr84m83"; "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"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 86b2b9668e..681bcc9e57 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplex-chat -version: 5.7.4.0 +version: 5.7.4.1 category: Web, System, Services, Cryptography homepage: https://github.com/simplex-chat/simplex-chat#readme author: simplex.chat