Merge branch 'master' into master-ghc8107

src/Simplex/Chat.hs

@@ -35,19 +35,20 @@ import Data.Either (fromRight, rights)
 import Data.Fixed (div')
 import Data.Functor (($>))
 import Data.Int (Int64)
-import Data.List (find, foldl', isSuffixOf, partition, sortOn)
+import Data.List (find, foldl', isSuffixOf, partition, sortBy, sortOn)
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
 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 (Word32)
+import Data.Word (Word16, Word32)
 import qualified Database.SQLite.Simple as SQL
 import Simplex.Chat.Archive
 import Simplex.Chat.Call
@@ -100,6 +101,7 @@ import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (defaultSocksProxy)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
+import Simplex.RemoteControl.Invitation (RCSignedInvitation (..), RCInvitation (..))
 import System.Exit (ExitCode, exitFailure, exitSuccess)
 import System.FilePath (takeFileName, (</>))
 import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout)
@@ -147,7 +149,8 @@ defaultChatConfig =
       cleanupManagerStepDelay = 3 * 1000000, -- 3 seconds
       ciExpirationInterval = 30 * 60 * 1000000, -- 30 minutes
       coreApi = False,
-      highlyAvailable = False
+      highlyAvailable = False,
+      deviceNameForRemote = ""
     }
 
 _defaultSMPServers :: NonEmpty SMPServerWithAuth
@@ -191,7 +194,7 @@ createChatDatabase filePrefix key confirmMigrations = runExceptT $ do
   pure ChatDatabase {chatStore, agentStore}
 
 newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> IO ChatController
-newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} = do
+newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir, deviceNameForRemote} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, deviceName, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} = do
   let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
       config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable}
       firstTime = dbNew chatStore
@@ -209,7 +212,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
   sndFiles <- newTVarIO M.empty
   rcvFiles <- newTVarIO M.empty
   currentCalls <- atomically TM.empty
-  localDeviceName <- newTVarIO "" -- TODO set in config
+  localDeviceName <- newTVarIO $ fromMaybe deviceNameForRemote deviceName
   multicastSubscribers <- newTMVarIO 0
   remoteSessionSeq <- newTVarIO 0
   remoteHostSessions <- atomically TM.empty
@@ -1958,8 +1961,8 @@ processChatCommand = \case
   ListRemoteHosts -> withUser_ $ CRRemoteHostList <$> listRemoteHosts
   SwitchRemoteHost rh_ -> withUser_ $ CRCurrentRemoteHost <$> switchRemoteHost rh_
   StartRemoteHost rh_ -> withUser_ $ do
-    (remoteHost_, inv) <- startRemoteHost rh_
-    pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv}
+    (remoteHost_, inv@RCSignedInvitation {invitation = RCInvitation {port}}) <- startRemoteHost rh_
+    pure CRRemoteHostStarted {remoteHost_, invitation = decodeLatin1 $ strEncode inv, ctrlPort = show port}
   StopRemoteHost rh_ -> withUser_ $ closeRemoteHost rh_ >> ok_
   DeleteRemoteHost rh -> withUser_ $ deleteRemoteHost rh >> ok_
   StoreRemoteFile rh encrypted_ localPath -> withUser_ $ CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath
@@ -2845,17 +2848,17 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
       let connIds = map aConnId' pcs
       pure (connIds, M.fromList $ zip connIds pcs)
     contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> Bool -> m ()
-    contactSubsToView rs cts ce = ifM (asks $ coreApi . config) notifyAPI notifyCLI
+    contactSubsToView rs cts ce = do
+      chatModifyVar connNetworkStatuses $ M.union (M.fromList statuses)
+      ifM (asks $ coreApi . config) (notifyAPI statuses) notifyCLI
       where
         notifyCLI = do
           let cRs = resultsFor rs cts
               cErrors = sortOn (\(Contact {localDisplayName = n}, _) -> n) $ filterErrors cRs
           toView . CRContactSubSummary user $ map (uncurry ContactSubStatus) cRs
           when ce $ mapM_ (toView . uncurry (CRContactSubError user)) cErrors
-        notifyAPI = do
-          let statuses = M.foldrWithKey' addStatus [] cts
-          chatModifyVar connNetworkStatuses $ M.union (M.fromList statuses)
-          toView $ CRNetworkStatuses (Just user) $ map (uncurry ConnNetworkStatus) statuses
+        notifyAPI = toView . CRNetworkStatuses (Just user) . map (uncurry ConnNetworkStatus)
+        statuses = M.foldrWithKey' addStatus [] cts 
           where
             addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)]
             addStatus _ Contact {activeConn = Nothing} nss = nss
@@ -3076,12 +3079,12 @@ processAgentMessageNoConn = \case
   where
     hostEvent :: ChatResponse -> m ()
     hostEvent = whenM (asks $ hostEvents . config) . toView
-    serverEvent srv conns nsStatus event = ifM (asks $ coreApi . config) notifyAPI notifyCLI
+    serverEvent srv conns nsStatus event = do
+      chatModifyVar connNetworkStatuses $ \m -> foldl' (\m' cId -> M.insert cId nsStatus m') m connIds
+      ifM (asks $ coreApi . config) (notifyAPI connIds) notifyCLI
       where
-        notifyAPI = do
-          let connIds = map AgentConnId conns
-          chatModifyVar connNetworkStatuses $ \m -> foldl' (\m' cId -> M.insert cId nsStatus m') m connIds
-          toView $ CRNetworkStatus nsStatus connIds
+        connIds = map AgentConnId conns
+        notifyAPI = toView . CRNetworkStatus nsStatus
         notifyCLI = do
           cs <- withStore' (`getConnectionsContacts` conns)
           toView $ event srv cs
@@ -3544,7 +3547,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
             members <- withStore' $ \db -> getGroupMembers db user gInfo
             intros <- withStore' $ \db -> createIntroductions db members m
             void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
-            forM_ intros $ \intro ->
+            shuffledIntros <- liftIO $ shuffleMembers intros $ \GroupMemberIntro {reMember = GroupMember {memberRole}} -> memberRole
+            forM_ shuffledIntros $ \intro ->
               processIntro intro `catchChatError` (toView . CRChatError (Just user))
             where
               sendXGrpLinkMem = do
@@ -5517,7 +5521,8 @@ 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
-  rs <- forM (filter memberCurrent members) $ \m ->
+  recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) $ \GroupMember {memberRole} -> memberRole
+  rs <- forM recipientMembers $ \m ->
     messageMember m msg `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
   let sentToMembers = catMaybes rs
   pure (msg, sentToMembers)
@@ -5555,6 +5560,15 @@ 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