mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-13 21:33:41 +00:00
WIP: remove sync connection replies
This commit is contained in:
Alexander Bondarenko
+106
-114
@@ -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)]
|
||||
|
||||
Reference in New Issue
Block a user