diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b61f2f90e..2408d41f7 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -32,7 +32,7 @@ import Data.Either (fromRight) import Data.Fixed (div') import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (find, isSuffixOf, sortOn) +import Data.List (find, isSuffixOf, partition, sortOn) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -198,7 +198,7 @@ startChatController currentUser subConns enableExpireCIs = do a1 <- async $ race_ notificationSubscriber agentSubscriber a2 <- if subConns - then Just <$> async (void . runExceptT $ subscribeUserConnections Agent.subscribeConnections currentUser) + then Just <$> async (subscribeUsers users) else pure Nothing atomically . writeTVar s $ Just (a1, a2) startCleanupManager @@ -229,6 +229,15 @@ startChatController currentUser subConns enableExpireCIs = do forM_ ttl $ \t -> expireChatItems u t False threadDelay $ 1800 * 1000000 -- 30 minutes +subscribeUsers :: forall m. (MonadUnliftIO m, MonadReader ChatController m) => [User] -> m () +subscribeUsers users = do + let (us, us') = partition activeUser users + subscribe us + subscribe us' + where + subscribe :: [User] -> m () + subscribe = mapM_ $ runExceptT . subscribeUserConnections Agent.subscribeConnections + restoreCalls :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m () restoreCalls user = do savedCalls <- fromRight [] <$> runExceptT (withStore' $ \db -> getCalls db user) @@ -316,8 +325,9 @@ processChatCommand = \case setAllExpireCIFlags False withAgent (`suspendAgent` t) pure $ CRCmdOk Nothing - ResubscribeAllConnections -> withUser $ \user -> do - subscribeUserConnections Agent.resubscribeConnections user + ResubscribeAllConnections -> do + users <- withStore' getUsers + subscribeUsers users pure $ CRCmdOk Nothing SetFilesFolder filesFolder' -> do createDirectoryIfMissing True filesFolder' @@ -1805,19 +1815,19 @@ subscribeUserConnections agentBatchSubscribe user = do let connIds = map aConnId' pcs pure (connIds, M.fromList $ zip connIds pcs) contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> m () - contactSubsToView rs = toView . CRContactSubSummary . map (uncurry ContactSubStatus) . resultsFor rs + contactSubsToView rs = toView . CRContactSubSummary user . map (uncurry ContactSubStatus) . resultsFor rs contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> m () - contactLinkSubsToView rs = toView . CRUserContactSubSummary . map (uncurry UserContactSubStatus) . resultsFor rs + contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m () groupSubsToView rs gs ms ce = do mapM_ groupSub $ sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs - toView . CRMemberSubSummary $ map (uncurry MemberSubStatus) mRs + toView . CRMemberSubSummary user $ map (uncurry MemberSubStatus) mRs where mRs = resultsFor rs ms groupSub :: Group -> m () groupSub (Group g@GroupInfo {membership, groupId = gId} members) = do - when ce $ mapM_ (toView . uncurry (CRMemberSubError g)) mErrors + when ce $ mapM_ (toView . uncurry (CRMemberSubError user g)) mErrors toView groupEvent where mErrors :: [(GroupMember, ChatError)] @@ -1827,26 +1837,26 @@ subscribeUserConnections agentBatchSubscribe user = do $ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs groupEvent :: ChatResponse groupEvent - | memberStatus membership == GSMemInvited = CRGroupInvitation g + | memberStatus membership == GSMemInvited = CRGroupInvitation user g | all (\GroupMember {activeConn} -> isNothing activeConn) members = if memberActive membership - then CRGroupEmpty g - else CRGroupRemoved g - | otherwise = CRGroupSubscribed g + then CRGroupEmpty user g + else CRGroupRemoved user g + | otherwise = CRGroupSubscribed user g sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> m () sndFileSubsToView rs sfts = do let sftRs = resultsFor rs sfts forM_ sftRs $ \(ft@SndFileTransfer {fileId, fileStatus}, err_) -> do - forM_ err_ $ toView . CRSndFileSubError ft + forM_ err_ $ toView . CRSndFileSubError user ft void . forkIO $ do threadDelay 1000000 l <- asks chatLock when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) . withLock l "subscribe sendFileChunk" $ sendFileChunk user ft rcvFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId RcvFileTransfer -> m () - rcvFileSubsToView rs = mapM_ (toView . uncurry CRRcvFileSubError) . filterErrors . resultsFor rs + rcvFileSubsToView rs = mapM_ (toView . uncurry (CRRcvFileSubError user)) . filterErrors . resultsFor rs pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> m () - pendingConnSubsToView rs = toView . CRPendingSubSummary . map (uncurry PendingSubStatus) . resultsFor rs + pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs withStore_ :: (DB.Connection -> User -> IO [a]) -> m [a] withStore_ a = withStore' (`a` user) `catchError` \e -> toView (CRChatError (Just user) e) >> pure [] filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)] diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 1b2fccdbf..08c5c9bb5 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -395,12 +395,12 @@ data ChatResponse | CRSubscriptionEnd {user :: User, connectionEntity :: ConnectionEntity} | CRContactsDisconnected {user :: User, server :: SMPServer, contactRefs :: [ContactRef]} | CRContactsSubscribed {user :: User, server :: SMPServer, contactRefs :: [ContactRef]} - | CRContactSubError {contact :: Contact, chatError :: ChatError} - | CRContactSubSummary {contactSubscriptions :: [ContactSubStatus]} - | CRUserContactSubSummary {userContactSubscriptions :: [UserContactSubStatus]} + | CRContactSubError {contact :: Contact, chatError :: ChatError} -- TODO delete + | CRContactSubSummary {user :: User, contactSubscriptions :: [ContactSubStatus]} + | CRUserContactSubSummary {user :: User, userContactSubscriptions :: [UserContactSubStatus]} | CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost} | CRHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost} - | CRGroupInvitation {groupInfo :: GroupInfo} + | CRGroupInvitation {user :: User, groupInfo :: GroupInfo} | CRReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole} | CRUserJoinedGroup {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember} | CRJoinedGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} @@ -411,8 +411,8 @@ data ChatResponse | CRDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember} | CRDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRLeftMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} - | CRGroupEmpty {groupInfo :: GroupInfo} - | CRGroupRemoved {groupInfo :: GroupInfo} + | CRGroupEmpty {user :: User, groupInfo :: GroupInfo} + | CRGroupRemoved {user :: User, groupInfo :: GroupInfo} | CRGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember} | CRGroupProfile {user :: User, groupInfo :: GroupInfo} @@ -420,20 +420,20 @@ data ChatResponse | CRGroupLink {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact} | CRGroupLinkDeleted {user :: User, groupInfo :: GroupInfo} | CRAcceptingGroupJoinRequest {user :: User, groupInfo :: GroupInfo, contact :: Contact} - | CRMemberSubError {groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError} - | CRMemberSubSummary {memberSubscriptions :: [MemberSubStatus]} - | CRGroupSubscribed {groupInfo :: GroupInfo} - | CRPendingSubSummary {pendingSubscriptions :: [PendingSubStatus]} - | CRSndFileSubError {sndFileTransfer :: SndFileTransfer, chatError :: ChatError} - | CRRcvFileSubError {rcvFileTransfer :: RcvFileTransfer, chatError :: ChatError} + | CRMemberSubError {user :: User, groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError} + | CRMemberSubSummary {user :: User, memberSubscriptions :: [MemberSubStatus]} + | CRGroupSubscribed {user :: User, groupInfo :: GroupInfo} + | CRPendingSubSummary {user :: User, pendingSubscriptions :: [PendingSubStatus]} + | CRSndFileSubError {user :: User, sndFileTransfer :: SndFileTransfer, chatError :: ChatError} + | CRRcvFileSubError {user :: User, rcvFileTransfer :: RcvFileTransfer, chatError :: ChatError} | CRCallInvitation {user :: User, callInvitation :: RcvCallInvitation} | CRCallOffer {user :: User, contact :: Contact, callType :: CallType, offer :: WebRTCSession, sharedKey :: Maybe C.Key, askConfirmation :: Bool} | CRCallAnswer {user :: User, contact :: Contact, answer :: WebRTCSession} | CRCallExtraInfo {user :: User, contact :: Contact, extraInfo :: WebRTCExtraInfo} | CRCallEnded {user :: User, contact :: Contact} | CRCallInvitations {user :: User, callInvitations :: [RcvCallInvitation]} - | CRUserContactLinkSubscribed - | CRUserContactLinkSubError {chatError :: ChatError} + | CRUserContactLinkSubscribed -- TODO delete + | CRUserContactLinkSubError {chatError :: ChatError} -- TODO delete | CRNtfTokenStatus {status :: NtfTknStatus} | CRNtfToken {token :: DeviceToken, status :: NtfTknStatus, ntfMode :: NotificationsMode} | CRNtfMessages {user :: User, connEntity :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index ebcfd49c9..530f447cf 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -146,7 +146,7 @@ responseToView user_ testView liveItems ts = \case CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft CRSndFileCancelled _ ft -> sendingFile_ "cancelled" ft CRSndFileRcvCancelled u _ ft@SndFileTransfer {recipientDisplayName = c} -> - ttyUser u $ [ttyContact c <> " cancelled receiving " <> sndFile ft] + ttyUser u [ttyContact c <> " cancelled receiving " <> sndFile ft] CRContactConnecting u _ -> ttyUser u [] CRContactConnected u ct userCustomProfile -> ttyUser u $ viewContactConnected ct userCustomProfile testView CRContactAnotherClient u c -> ttyUser u [ttyContact' c <> ": contact is connected to another client"] @@ -154,18 +154,19 @@ responseToView user_ testView liveItems ts = \case CRContactsDisconnected u srv cs -> ttyUser u [plain $ "server disconnected " <> showSMPServer srv <> " (" <> contactList cs <> ")"] CRContactsSubscribed u srv cs -> ttyUser u [plain $ "server connected " <> showSMPServer srv <> " (" <> contactList cs <> ")"] CRContactSubError c e -> [ttyContact' c <> ": contact error " <> sShow e] - CRContactSubSummary summary -> - [sShow (length subscribed) <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | not (null subscribed)] <> viewErrorsSummary errors " contact errors" + CRContactSubSummary u summary -> + ttyUser u $ [sShow (length subscribed) <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | not (null subscribed)] <> viewErrorsSummary errors " contact errors" where (errors, subscribed) = partition (isJust . contactError) summary - CRUserContactSubSummary summary -> - map addressSS addresses - <> ([sShow (length groupLinksSubscribed) <> " group links active" | not (null groupLinksSubscribed)] <> viewErrorsSummary groupLinkErrors " group link errors") + CRUserContactSubSummary u summary -> + ttyUser u $ + map addressSS addresses + <> ([sShow (length groupLinksSubscribed) <> " group links active" | not (null groupLinksSubscribed)] <> viewErrorsSummary groupLinkErrors " group link errors") where (addresses, groupLinks) = partition (\UserContactSubStatus {userContact} -> isNothing . userContactGroupId $ userContact) summary addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError (groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks - CRGroupInvitation g -> [groupInvitation' g] + CRGroupInvitation u g -> ttyUser u [groupInvitation' g] CRReceivedGroupInvitation u g c role -> ttyUser u $ viewReceivedGroupInvitation g c role CRUserJoinedGroup u g _ -> ttyUser u $ viewUserJoinedGroup g CRJoinedGroupMember u g m -> ttyUser u $ viewJoinedGroupMember g m @@ -178,8 +179,8 @@ responseToView user_ testView liveItems ts = \case CRDeletedMemberUser u g by -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g CRDeletedMember u g by m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"] CRLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"] - CRGroupEmpty g -> [ttyFullGroup g <> ": group is empty"] - CRGroupRemoved g -> [ttyFullGroup g <> ": you are no longer a member or group deleted"] + CRGroupEmpty u g -> ttyUser u [ttyFullGroup g <> ": group is empty"] + CRGroupRemoved u g -> ttyUser u [ttyFullGroup g <> ": you are no longer a member or group deleted"] CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"] CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m CRGroupProfile u g -> ttyUser u $ viewGroupProfile g @@ -187,14 +188,14 @@ responseToView user_ testView liveItems ts = \case CRGroupLink u g cReq -> ttyUser u $ groupLink_ "Group link:" g cReq CRGroupLinkDeleted u g -> ttyUser u $ viewGroupLinkDeleted g CRAcceptingGroupJoinRequest _ g c -> [ttyFullContact c <> ": accepting request to join group " <> ttyGroup' g <> "..."] - CRMemberSubError g m e -> [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e] - CRMemberSubSummary summary -> viewErrorsSummary (filter (isJust . memberError) summary) " group member errors" - CRGroupSubscribed g -> viewGroupSubscribed g - CRPendingSubSummary _ -> [] - CRSndFileSubError SndFileTransfer {fileId, fileName} e -> - ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] - CRRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e -> - ["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] + CRMemberSubError u g m e -> ttyUser u [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e] + CRMemberSubSummary u summary -> ttyUser u $ viewErrorsSummary (filter (isJust . memberError) summary) " group member errors" + CRGroupSubscribed u g -> ttyUser u $ viewGroupSubscribed g + CRPendingSubSummary u _ -> ttyUser u [] + CRSndFileSubError u SndFileTransfer {fileId, fileName} e -> + ttyUser u ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] + CRRcvFileSubError u RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e -> + ttyUser u ["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] CRCallInvitation u RcvCallInvitation {contact, callType, sharedKey} -> ttyUser u $ viewCallInvitation contact callType sharedKey CRCallOffer {user = u, contact, callType, offer, sharedKey} -> ttyUser u $ viewCallOffer contact callType offer sharedKey CRCallAnswer {user = u, contact, answer} -> ttyUser u $ viewCallAnswer contact answer diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index dc41be904..a02c9ccbb 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -46,32 +46,35 @@ chatStarted = "{\"resp\":{\"type\":\"chatStarted\"}}" contactSubSummary :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) -contactSubSummary = "{\"resp\":{\"contactSubSummary\":{\"contactSubscriptions\":[]}}}" +contactSubSummary = "{\"resp\":{\"contactSubSummary\":{" <> userJSON <> ",\"contactSubscriptions\":[]}}}" #else -contactSubSummary = "{\"resp\":{\"type\":\"contactSubSummary\",\"contactSubscriptions\":[]}}" +contactSubSummary = "{\"resp\":{\"type\":\"contactSubSummary\"," <> userJSON <> ",\"contactSubscriptions\":[]}}" #endif memberSubSummary :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) -memberSubSummary = "{\"resp\":{\"memberSubSummary\":{\"memberSubscriptions\":[]}}}" +memberSubSummary = "{\"resp\":{\"memberSubSummary\":{" <> userJSON <> ",\"memberSubscriptions\":[]}}}" #else -memberSubSummary = "{\"resp\":{\"type\":\"memberSubSummary\",\"memberSubscriptions\":[]}}" +memberSubSummary = "{\"resp\":{\"type\":\"memberSubSummary\"," <> userJSON <> ",\"memberSubscriptions\":[]}}" #endif userContactSubSummary :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) -userContactSubSummary = "{\"resp\":{\"userContactSubSummary\":{\"userContactSubscriptions\":[]}}}" +userContactSubSummary = "{\"resp\":{\"userContactSubSummary\":{" <> userJSON <> ",\"userContactSubscriptions\":[]}}}" #else -userContactSubSummary = "{\"resp\":{\"type\":\"userContactSubSummary\",\"userContactSubscriptions\":[]}}" +userContactSubSummary = "{\"resp\":{\"type\":\"userContactSubSummary\"," <> userJSON <> ",\"userContactSubscriptions\":[]}}" #endif pendingSubSummary :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) -pendingSubSummary = "{\"resp\":{\"pendingSubSummary\":{\"pendingSubscriptions\":[]}}}" +pendingSubSummary = "{\"resp\":{\"pendingSubSummary\":{" <> userJSON <> ",\"pendingSubscriptions\":[]}}}" #else -pendingSubSummary = "{\"resp\":{\"type\":\"pendingSubSummary\",\"pendingSubscriptions\":[]}}" +pendingSubSummary = "{\"resp\":{\"type\":\"pendingSubSummary\"," <> userJSON <> ",\"pendingSubscriptions\":[]}}" #endif +userJSON :: String +userJSON = "\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":false}" + parsedMarkdown :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) parsedMarkdown = "{\"formattedText\":[{\"format\":{\"bold\":{}},\"text\":\"hello\"}]}"