From 9b67aa537a06d5bd26071e832c2f4557a7009e56 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 6 Feb 2022 08:21:40 +0000 Subject: [PATCH] each command takes lock if it needs it (#273) --- src/Simplex/Chat.hs | 47 ++++++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 22 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 3e4fde6f2..65c260a09 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -112,9 +112,9 @@ execChatCommand :: (MonadUnliftIO m, MonadReader ChatController m) => ByteString execChatCommand s = case parseAll chatCommandP $ B.dropWhileEnd isSpace s of Left e -> pure . CRChatError . ChatError $ CECommandError e Right cmd -> do - ChatController {chatLock = l, smpAgent = a, currentUser} <- ask + ChatController {currentUser} <- ask user <- readTVarIO currentUser - withAgentLock a . withLock l $ either CRChatCmdError id <$> runExceptT (processChatCommand user cmd) + either CRChatCmdError id <$> runExceptT (processChatCommand user cmd) toView :: ChatMonad m => ChatResponse -> m () toView event = do @@ -129,7 +129,7 @@ processChatCommand user@User {userId, profile} = \case CTGroup -> CRApiChat . AChat SCTGroup <$> withStore (\st -> getGroupChat st user cId pagination) CTContactRequest -> pure $ CRChatError ChatErrorNotImplemented APIGetChatItems _count -> pure $ CRChatError ChatErrorNotImplemented - APISendMessage cType chatId mc -> case cType of + APISendMessage cType chatId mc -> withChatLock $ case cType of CTDirect -> do ct@Contact {localDisplayName = c} <- withStore $ \st -> getContact st userId chatId ci <- sendDirectChatItem userId ct (XMsgNew mc) (CISndMsgContent mc) @@ -148,7 +148,7 @@ processChatCommand user@User {userId, profile} = \case withStore (\st -> getContactGroupNames st userId ct) >>= \case [] -> do conns <- withStore $ \st -> getContactConnections st userId ct - procCmd $ do + withChatLock . procCmd $ do withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () withStore $ \st -> deleteContact st userId ct @@ -160,11 +160,11 @@ processChatCommand user@User {userId, profile} = \case APIAcceptContact connReqId -> do UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p} <- withStore $ \st -> getContactRequest st userId connReqId - procCmd $ do + withChatLock . procCmd $ do connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profile acceptedContact <- withStore $ \st -> createAcceptedContact st userId connId cName profileId p pure $ CRAcceptingContactRequest acceptedContact - APIRejectContact connReqId -> do + APIRejectContact connReqId -> withChatLock $ do cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- withStore $ \st -> getContactRequest st userId connReqId @@ -173,29 +173,29 @@ processChatCommand user@User {userId, profile} = \case pure $ CRContactRequestRejected cReq ChatHelp section -> pure $ CRChatHelp section Welcome -> pure $ CRWelcome user - AddContact -> procCmd $ do + AddContact -> withChatLock . procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMInvitation) withStore $ \st -> createDirectConnection st userId connId pure $ CRInvitation cReq - Connect (Just (ACR SCMInvitation cReq)) -> procCmd $ do + Connect (Just (ACR SCMInvitation cReq)) -> withChatLock . procCmd $ do connect cReq $ XInfo profile pure CRSentConfirmation - Connect (Just (ACR SCMContact cReq)) -> procCmd $ do + Connect (Just (ACR SCMContact cReq)) -> withChatLock . procCmd $ do connect cReq $ XContact profile Nothing pure CRSentInvitation Connect Nothing -> throwChatError CEInvalidConnReq - ConnectAdmin -> procCmd $ do + ConnectAdmin -> withChatLock . procCmd $ do connect adminContactReq $ XContact profile Nothing pure CRSentInvitation DeleteContact cName -> do contactId <- withStore $ \st -> getContactIdByName st userId cName processChatCommand user $ APIDeleteChat CTDirect contactId ListContacts -> CRContactsList <$> withStore (`getUserContacts` user) - CreateMyAddress -> procCmd $ do + CreateMyAddress -> withChatLock . procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMContact) withStore $ \st -> createUserContactLink st userId connId cReq pure $ CRUserContactLinkCreated cReq - DeleteMyAddress -> do + DeleteMyAddress -> withChatLock $ do conns <- withStore $ \st -> getUserContactLinkConnections st userId procCmd $ do withAgent $ \a -> forM_ conns $ \conn -> @@ -216,7 +216,7 @@ processChatCommand user@User {userId, profile} = \case NewGroup gProfile -> do gVar <- asks idsDrg CRGroupCreated <$> withStore (\st -> createNewGroup st gVar user gProfile) - AddMember gName cName memRole -> do + AddMember gName cName memRole -> withChatLock $ do -- TODO for large groups: no need to load all members to determine if contact is a member (group, contact) <- withStore $ \st -> (,) <$> getGroupByName st user gName <*> getContactByName st userId cName let Group gInfo@GroupInfo {groupId, groupProfile, membership} members = group @@ -243,7 +243,7 @@ processChatCommand user@User {userId, profile} = \case | otherwise -> throwChatError $ CEGroupDuplicateMember cName JoinGroup gName -> do ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g} <- withStore $ \st -> getGroupInvitation st user gName - procCmd $ do + withChatLock . procCmd $ do agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (membership g :: GroupMember) withStore $ \st -> do createMemberConnection st userId fromMember agentConnId @@ -258,14 +258,14 @@ processChatCommand user@User {userId, profile} = \case Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do let userRole = memberRole (membership :: GroupMember) when (userRole < GRAdmin || userRole < mRole) $ throwChatError CEGroupUserRole - procCmd $ do + withChatLock . procCmd $ do when (mStatus /= GSMemInvited) . void . sendGroupMessage members $ XGrpMemDel mId deleteMemberConnection m withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved pure $ CRUserDeletedMember gInfo m LeaveGroup gName -> do Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName - procCmd $ do + withChatLock . procCmd $ do void $ sendGroupMessage members XGrpLeave mapM_ deleteMemberConnection members withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft @@ -277,7 +277,7 @@ processChatCommand user@User {userId, profile} = \case memberRole (membership :: GroupMember) == GROwner || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited) unless canDelete $ throwChatError CEGroupUserRole - procCmd $ do + withChatLock . procCmd $ do when (memberActive membership) . void $ sendGroupMessage members XGrpDel mapM_ deleteMemberConnection members withStore $ \st -> deleteGroup st user g @@ -288,7 +288,7 @@ processChatCommand user@User {userId, profile} = \case groupId <- withStore $ \st -> getGroupIdByName st user gName let mc = MCText $ safeDecodeUtf8 msg processChatCommand user $ APISendMessage CTGroup groupId mc - SendFile cName f -> do + SendFile cName f -> withChatLock $ do (fileSize, chSize) <- checkSndFile f contact <- withStore $ \st -> getContactByName st userId cName (agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) @@ -299,7 +299,7 @@ processChatCommand user@User {userId, profile} = \case withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci setActive $ ActiveC cName pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci - SendGroupFile gName f -> do + SendGroupFile gName f -> withChatLock $ do (fileSize, chSize) <- checkSndFile f Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved @@ -322,7 +322,7 @@ processChatCommand user@User {userId, profile} = \case ReceiveFile fileId filePath_ -> do ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId unless (fileStatus == RFSNew) . throwChatError $ CEFileAlreadyReceiving fileName - procCmd $ do + withChatLock . procCmd $ do tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XFileAcpt fileName) >>= \case Right agentConnId -> do filePath <- getRcvFilePath fileId filePath_ fileName @@ -333,7 +333,7 @@ processChatCommand user@User {userId, profile} = \case Left e -> throwError e CancelFile fileId -> do ft' <- withStore (\st -> getFileTransfer st userId fileId) - procCmd $ case ft' of + withChatLock . procCmd $ case ft' of FTSnd fts -> do forM_ fts $ \ft -> cancelSndFileTransfer ft pure $ CRSndGroupFileCancelled fts @@ -350,12 +350,15 @@ processChatCommand user@User {userId, profile} = \case let user' = (user :: User) {localDisplayName = displayName, profile = p} asks currentUser >>= atomically . (`writeTVar` user') contacts <- withStore (`getUserContacts` user) - procCmd $ do + withChatLock . procCmd $ do forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p pure $ CRUserProfileUpdated profile p QuitChat -> liftIO exitSuccess ShowVersion -> pure CRVersionInfo where + withChatLock action = do + ChatController {chatLock = l, smpAgent = a} <- ask + withAgentLock a . withLock l $ action -- below code would make command responses asynchronous where they can be slow -- in View.hs `r'` should be defined as `id` in this case -- procCmd :: m ChatResponse -> m ChatResponse