batch introductions

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

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)