From 1295e538ed3f7edea49313f5b40a8566ee7fefee Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Fri, 24 May 2024 19:01:52 +0300 Subject: [PATCH] WIP: remove sync connection replies --- src/Simplex/Chat.hs | 220 +++++++++++++++++++++----------------------- 1 file changed, 106 insertions(+), 114 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e259629d2b..f22a0aded2 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -410,13 +410,8 @@ startChatController mainApp = do subscribeUsers :: Bool -> [User] -> CM' () subscribeUsers onlyNeeded users = do - let (us, us') = partition activeUser users vr <- chatVersionRange' - subscribe vr us - subscribe vr us' - where - subscribe :: VersionRangeChat -> [User] -> CM' () - subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections + forM_ users $ runExceptT . subscribeUserConnections vr onlyNeeded startFilesToReceive :: [User] -> CM' () startFilesToReceive users = do @@ -3333,18 +3328,16 @@ agentSubscriber = do where run action = action `catchChatError'` (toView' . CRChatError Nothing) -type AgentBatchSubscribe = AgentClient -> [ConnId] -> ExceptT AgentErrorType IO (Map ConnId (Either AgentErrorType ())) - -subscribeUserConnections :: VersionRangeChat -> Bool -> AgentBatchSubscribe -> User -> CM () -subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do +subscribeUserConnections :: VersionRangeChat -> Bool -> User -> CM () +subscribeUserConnections vr onlyNeeded user = do -- get user connections - ce <- asks $ subscriptionEvents . config - (conns, cts, ucs, gs, ms, sfts, rfts, pcs) <- + -- ce <- asks $ subscriptionEvents . config + conns <- if onlyNeeded then do (conns, entities) <- withStore' (`getConnectionsToSubscribe` vr) - let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities - pure (conns, cts, ucs, [], ms, sfts, rfts, pcs) + -- let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities + pure conns else do withStore' unsetConnectionToSubscribe (ctConns, cts) <- getContactConns @@ -3353,42 +3346,41 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do (sftConns, sfts) <- getSndFileTransferConns (rftConns, rfts) <- getRcvFileTransferConns (pcConns, pcs) <- getPendingContactConns - let conns = concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns] - pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs) + pure $ concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns] -- subscribe using batched commands - rs <- withAgent $ \a -> agentBatchSubscribe a conns - -- send connection events to view - contactSubsToView rs cts ce - -- TODO possibly, we could either disable these events or replace with less noisy for API - contactLinkSubsToView rs ucs - groupSubsToView rs gs ms ce - sndFileSubsToView rs sfts - rcvFileSubsToView rs rfts - pendingConnSubsToView rs pcs + void $ withAgent (`Agent.subscribeConnections` conns) + -- -- send connection events to view + -- contactSubsToView rs cts ce + -- -- TODO possibly, we could either disable these events or replace with less noisy for API + -- contactLinkSubsToView rs ucs + -- groupSubsToView rs gs ms ce + -- sndFileSubsToView rs sfts + -- rcvFileSubsToView rs rfts + -- pendingConnSubsToView rs pcs where - addEntity (cts, ucs, ms, sfts, rfts, pcs) = \case - RcvDirectMsgConnection c (Just ct) -> let cts' = addConn c ct cts in (cts', ucs, ms, sfts, rfts, pcs) - RcvDirectMsgConnection c Nothing -> let pcs' = addConn c (toPCC c) pcs in (cts, ucs, ms, sfts, rfts, pcs') - RcvGroupMsgConnection c _g m -> let ms' = addConn c m ms in (cts, ucs, ms', sfts, rfts, pcs) - SndFileConnection c sft -> let sfts' = addConn c sft sfts in (cts, ucs, ms, sfts', rfts, pcs) - RcvFileConnection c rft -> let rfts' = addConn c rft rfts in (cts, ucs, ms, sfts, rfts', pcs) - UserContactConnection c uc -> let ucs' = addConn c uc ucs in (cts, ucs', ms, sfts, rfts, pcs) - addConn :: Connection -> a -> Map ConnId a -> Map ConnId a - addConn = M.insert . aConnId - toPCC Connection {connId, agentConnId, connStatus, viaUserContactLink, groupLinkId, customUserProfileId, localAlias, createdAt} = - PendingContactConnection - { pccConnId = connId, - pccAgentConnId = agentConnId, - pccConnStatus = connStatus, - viaContactUri = False, - viaUserContactLink, - groupLinkId, - customUserProfileId, - connReqInv = Nothing, - localAlias, - createdAt, - updatedAt = createdAt - } + -- addEntity (cts, ucs, ms, sfts, rfts, pcs) = \case + -- RcvDirectMsgConnection c (Just ct) -> let cts' = addConn c ct cts in (cts', ucs, ms, sfts, rfts, pcs) + -- RcvDirectMsgConnection c Nothing -> let pcs' = addConn c (toPCC c) pcs in (cts, ucs, ms, sfts, rfts, pcs') + -- RcvGroupMsgConnection c _g m -> let ms' = addConn c m ms in (cts, ucs, ms', sfts, rfts, pcs) + -- SndFileConnection c sft -> let sfts' = addConn c sft sfts in (cts, ucs, ms, sfts', rfts, pcs) + -- RcvFileConnection c rft -> let rfts' = addConn c rft rfts in (cts, ucs, ms, sfts, rfts', pcs) + -- UserContactConnection c uc -> let ucs' = addConn c uc ucs in (cts, ucs', ms, sfts, rfts, pcs) + -- addConn :: Connection -> a -> Map ConnId a -> Map ConnId a + -- addConn = M.insert . aConnId + -- toPCC Connection {connId, agentConnId, connStatus, viaUserContactLink, groupLinkId, customUserProfileId, localAlias, createdAt} = + -- PendingContactConnection + -- { pccConnId = connId, + -- pccAgentConnId = agentConnId, + -- pccConnStatus = connStatus, + -- viaContactUri = False, + -- viaUserContactLink, + -- groupLinkId, + -- customUserProfileId, + -- connReqInv = Nothing, + -- localAlias, + -- createdAt, + -- updatedAt = createdAt + -- } getContactConns :: CM ([ConnId], Map ConnId Contact) getContactConns = do cts <- withStore_ (`getUserContacts` vr) @@ -3419,72 +3411,72 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do pcs <- withStore_ getPendingContactConnections let connIds = map aConnId' pcs pure (connIds, M.fromList $ zip connIds pcs) - contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> Bool -> CM () - 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 = 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 - addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss = - let ns = (agentConnId, netStatus $ resultErr connId rs) - in ns : nss - netStatus :: Maybe ChatError -> NetworkStatus - netStatus = maybe NSConnected $ NSError . errorNetworkStatus - errorNetworkStatus :: ChatError -> String - errorNetworkStatus = \case - ChatErrorAgent (BROKER _ NETWORK) _ -> "network" - ChatErrorAgent (SMP _ SMP.AUTH) _ -> "contact deleted" - e -> show e - -- TODO possibly below could be replaced with less noisy events for API - contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> CM () - contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs - groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> CM () - groupSubsToView rs gs ms ce = do - mapM_ groupSub $ - sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs - toView . CRMemberSubSummary user $ map (uncurry MemberSubStatus) mRs - where - mRs = resultsFor rs ms - groupSub :: Group -> CM () - groupSub (Group g@GroupInfo {membership, groupId = gId} members) = do - when ce $ mapM_ (toView . uncurry (CRMemberSubError user g)) mErrors - toView groupEvent - where - mErrors :: [(GroupMember, ChatError)] - mErrors = - sortOn (\(GroupMember {localDisplayName = n}, _) -> n) - . filterErrors - $ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs - groupEvent :: ChatResponse - groupEvent - | memberStatus membership == GSMemInvited = CRGroupInvitation user g - | all (\GroupMember {activeConn} -> isNothing activeConn) members = - if memberActive membership - then CRGroupEmpty user g - else CRGroupRemoved user g - | otherwise = CRGroupSubscribed user g - sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> CM () - sndFileSubsToView rs sfts = do - let sftRs = resultsFor rs sfts - forM_ sftRs $ \(ft@SndFileTransfer {fileId, fileStatus}, err_) -> do - forM_ err_ $ toView . CRSndFileSubError user ft - void . forkIO $ do - threadDelay 1000000 - when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) . withChatLock "subscribe sendFileChunk" $ - sendFileChunk user ft - rcvFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId RcvFileTransfer -> CM () - rcvFileSubsToView rs = mapM_ (toView . uncurry (CRRcvFileSubError user)) . filterErrors . resultsFor rs - pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> CM () - pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs + -- contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> Bool -> CM () + -- 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 = 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 + -- addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss = + -- let ns = (agentConnId, netStatus $ resultErr connId rs) + -- in ns : nss + -- netStatus :: Maybe ChatError -> NetworkStatus + -- netStatus = maybe NSConnected $ NSError . errorNetworkStatus + -- errorNetworkStatus :: ChatError -> String + -- errorNetworkStatus = \case + -- ChatErrorAgent (BROKER _ NETWORK) _ -> "network" + -- ChatErrorAgent (SMP _ SMP.AUTH) _ -> "contact deleted" + -- e -> show e + -- -- TODO possibly below could be replaced with less noisy events for API + -- contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> CM () + -- contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs + -- groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> CM () + -- groupSubsToView rs gs ms ce = do + -- mapM_ groupSub $ + -- sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs + -- toView . CRMemberSubSummary user $ map (uncurry MemberSubStatus) mRs + -- where + -- mRs = resultsFor rs ms + -- groupSub :: Group -> CM () + -- groupSub (Group g@GroupInfo {membership, groupId = gId} members) = do + -- when ce $ mapM_ (toView . uncurry (CRMemberSubError user g)) mErrors + -- toView groupEvent + -- where + -- mErrors :: [(GroupMember, ChatError)] + -- mErrors = + -- sortOn (\(GroupMember {localDisplayName = n}, _) -> n) + -- . filterErrors + -- $ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs + -- groupEvent :: ChatResponse + -- groupEvent + -- | memberStatus membership == GSMemInvited = CRGroupInvitation user g + -- | all (\GroupMember {activeConn} -> isNothing activeConn) members = + -- if memberActive membership + -- then CRGroupEmpty user g + -- else CRGroupRemoved user g + -- | otherwise = CRGroupSubscribed user g + -- sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> CM () + -- sndFileSubsToView rs sfts = do + -- let sftRs = resultsFor rs sfts + -- forM_ sftRs $ \(ft@SndFileTransfer {fileId, fileStatus}, err_) -> do + -- forM_ err_ $ toView . CRSndFileSubError user ft + -- void . forkIO $ do + -- threadDelay 1000000 + -- when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) . withChatLock "subscribe sendFileChunk" $ + -- sendFileChunk user ft + -- rcvFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId RcvFileTransfer -> CM () + -- rcvFileSubsToView rs = mapM_ (toView . uncurry (CRRcvFileSubError user)) . filterErrors . resultsFor rs + -- pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> CM () + -- pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs withStore_ :: (DB.Connection -> User -> IO [a]) -> CM [a] withStore_ a = withStore' (`a` user) `catchChatError` \e -> toView (CRChatError (Just user) e) $> [] filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)]