diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 6631f1af3a..23540ad9f6 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -38,20 +38,19 @@ import Data.Either (fromRight, partitionEithers, rights) import Data.Fixed (div') import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (find, foldl', isSuffixOf, partition, sortBy, sortOn) +import Data.List (find, foldl', isSuffixOf, partition, sortOn) import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList) 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 Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime) import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds) import Data.Time.Clock.System (SystemTime, systemToUTCTime) -import Data.Word (Word16, Word32) +import Data.Word (Word32) import qualified Database.SQLite.Simple as SQL import Simplex.Chat.Archive import Simplex.Chat.Call @@ -77,7 +76,7 @@ import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Util -import Simplex.Chat.Util (encryptFile) +import Simplex.Chat.Util (encryptFile, shuffle) import Simplex.FileTransfer.Client.Main (maxFileSize) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb) @@ -3574,12 +3573,30 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo profileToSend = profileToSendOnAccept user profileMode void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId) - -- TODO [batch send] batch if invitee version range is compatible with batchSendVRange sendIntroductions members = do intros <- withStore' $ \db -> createIntroductions db members m - shuffledIntros <- liftIO $ shuffleMembers intros $ \GroupMemberIntro {reMember = GroupMember {memberRole}} -> memberRole - forM_ shuffledIntros $ \intro -> - processIntro intro `catchChatError` (toView . CRChatError (Just user)) + shuffledIntros <- liftIO $ shuffleIntros intros + if isCompatibleRange (memberChatVRange' m) batchSendVRange + then do + let events = map (XGrpMemIntro . memberInfo . reMember) shuffledIntros + forM_ (L.nonEmpty events) $ \events' -> + sendBatchedDirectMessages conn events' (GroupId groupId) + else + forM_ shuffledIntros $ \intro -> + processIntro intro `catchChatError` (toView . CRChatError (Just user)) + shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] + shuffleIntros intros = do + let (admins, others) = partition isAdmin intros + (admPics, admNoPics) = partition hasPicture admins + (othPics, othNoPics) = partition hasPicture others + admPics' <- shuffle admPics + admNoPics' <- shuffle admNoPics + othPics' <- shuffle othPics + othNoPics' <- shuffle othNoPics + pure $ admPics' <> admNoPics' <> othPics' <> othNoPics' + where + isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin + hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image processIntro intro@GroupMemberIntro {introId} = do void $ sendDirectMessage conn (XGrpMemIntro $ memberInfo (reMember intro)) (GroupId groupId) withStore' $ \db -> updateIntroStatus db introId GMIntroSent @@ -5621,12 +5638,18 @@ sendGroupMessage' :: forall e m. (MsgEncodingI e, ChatMonad m) => User -> [Group sendGroupMessage' user members chatMsgEvent groupId introId_ postDeliver = do msg <- createSndMessage chatMsgEvent (GroupId groupId) -- TODO collect failed deliveries into a single error - recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) $ \GroupMember {memberRole} -> memberRole + recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) rs <- forM recipientMembers $ \m -> messageMember m msg `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing) let sentToMembers = catMaybes rs pure (msg, sentToMembers) where + shuffleMembers :: [GroupMember] -> IO [GroupMember] + shuffleMembers ms = do + let (adminMs, otherMs) = partition isAdmin ms + liftM2 (<>) (shuffle adminMs) (shuffle otherMs) + where + isAdmin GroupMember {memberRole} = memberRole >= GRAdmin messageMember :: GroupMember -> SndMessage -> m (Maybe GroupMember) messageMember m@GroupMember {groupMemberId} SndMessage {msgId, msgBody} = case memberConn m of Nothing -> pendingOrForwarded @@ -5660,15 +5683,6 @@ sendGroupMessage' user members chatMsgEvent groupId introId_ postDeliver = do XGrpMsgForward {} -> True _ -> False -shuffleMembers :: [a] -> (a -> GroupMemberRole) -> IO [a] -shuffleMembers ms role = do - let (adminMs, otherMs) = partition ((GRAdmin <=) . role) ms - liftM2 (<>) (shuffle adminMs) (shuffle otherMs) - where - random :: IO Word16 - random = randomRIO (0, 65535) - shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) xs - sendPendingGroupMessages :: ChatMonad m => User -> GroupMember -> Connection -> m () sendPendingGroupMessages user GroupMember {groupMemberId, localDisplayName} conn = do pendingMessages <- withStore' $ \db -> getPendingGroupMessages db groupMemberId diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs index 46b5be28b3..896ac723c1 100644 --- a/src/Simplex/Chat/Util.hs +++ b/src/Simplex/Chat/Util.hs @@ -1,12 +1,18 @@ -module Simplex.Chat.Util (week, encryptFile, chunkSize) where +{-# LANGUAGE TupleSections #-} + +module Simplex.Chat.Util (week, encryptFile, chunkSize, shuffle) where import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import qualified Data.ByteString.Lazy as LB +import Data.List (sortBy) +import Data.Ord (comparing) import Data.Time (NominalDiffTime) +import Data.Word (Word16) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF +import System.Random (randomRIO) import UnliftIO.IO (IOMode (..), withFile) week :: NominalDiffTime @@ -30,3 +36,9 @@ encryptFile fromPath toPath cfArgs = do chunkSize :: Num a => a chunkSize = 65536 {-# INLINE chunkSize #-} + +shuffle :: [a] -> IO [a] +shuffle xs = map snd . sortBy (comparing fst) <$> mapM (\x -> (,x) <$> random) xs + where + random :: IO Word16 + random = randomRIO (0, 65535) \ No newline at end of file