diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 823e2cac14..bb7032a0cf 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -28,6 +28,7 @@ library Simplex.Chat.Migrations.M20220122_v1_1 Simplex.Chat.Migrations.M20220205_chat_item_status Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests + Simplex.Chat.Migrations.M20220224_messages_fks Simplex.Chat.Mobile Simplex.Chat.Options Simplex.Chat.Protocol diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 32c96b0a42..440d331117 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -282,14 +282,14 @@ processChatCommand = \case let userRole = memberRole (membership :: GroupMember) when (userRole < GRAdmin || userRole < mRole) $ throwChatError CEGroupUserRole withChatLock . procCmd $ do - when (mStatus /= GSMemInvited) . void . sendGroupMessage members $ XGrpMemDel mId + when (mStatus /= GSMemInvited) . void . sendGroupMessage gInfo members $ XGrpMemDel mId deleteMemberConnection m withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved pure $ CRUserDeletedMember gInfo m LeaveGroup gName -> withUser $ \user@User {userId} -> do Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName withChatLock . procCmd $ do - void $ sendGroupMessage members XGrpLeave + void $ sendGroupMessage gInfo members XGrpLeave mapM_ deleteMemberConnection members withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft pure $ CRLeftMemberUser gInfo @@ -301,7 +301,7 @@ processChatCommand = \case || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited) unless canDelete $ throwChatError CEGroupUserRole withChatLock . procCmd $ do - when (memberActive membership) . void $ sendGroupMessage members XGrpDel + when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel mapM_ deleteMemberConnection members withStore $ \st -> deleteGroup st user g pure $ CRGroupDeletedUser gInfo @@ -324,7 +324,7 @@ processChatCommand = \case pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci SendGroupFile gName f -> withUser $ \user@User {userId} -> withChatLock $ do (fileSize, chSize) <- checkSndFile f - Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName + Group gInfo@GroupInfo {groupId, membership} members <- withStore $ \st -> getGroupByName st user gName unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved let fileName = takeFileName f ms <- forM (filter memberActive members) $ \m -> do @@ -333,7 +333,7 @@ processChatCommand = \case fileId <- withStore $ \st -> createSndGroupFileTransfer st userId gInfo ms f fileSize chSize -- TODO sendGroupChatItem - same file invitation to all forM_ ms $ \(m, _, fileInv) -> - traverse (`sendDirectMessage` XFile fileInv) $ memberConn m + traverse (\conn -> sendDirectMessage conn (XFile fileInv) (GroupId groupId)) $ memberConn m setActive $ ActiveG gName -- this is a hack as we have multiple direct messages instead of one per group let ciContent = CISndFileInvitation fileId f @@ -579,7 +579,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage INFO connInfo -> saveConnInfo conn connInfo MSG meta msgBody -> do - _ <- saveRcvMSG conn meta msgBody + _ <- saveRcvMSG conn meta msgBody (ConnectionId connId) withAckMessage agentConnId meta $ pure () ackMsgDeliveryEvent conn meta SENT msgId -> @@ -592,7 +592,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage _ -> pure () Just ct@Contact {localDisplayName = c} -> case agentMsg of MSG msgMeta msgBody -> do - (msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody + (msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody (ConnectionId connId) withAckMessage agentConnId msgMeta $ case chatMsgEvent of XMsgNew mc -> newContentMessage ct mc msgId msgMeta @@ -667,7 +667,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage _ -> pure () processGroupMessage :: ACommand 'Agent -> Connection -> GroupInfo -> GroupMember -> m () - processGroupMessage agentMsg conn gInfo@GroupInfo {localDisplayName = gName, membership} m = case agentMsg of + processGroupMessage agentMsg conn gInfo@GroupInfo {groupId, localDisplayName = gName, membership} m = case agentMsg of CONF confId connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case memberCategory m of @@ -715,9 +715,9 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage setActive $ ActiveG gName showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected" intros <- withStore $ \st -> createIntroductions st members m - void . sendGroupMessage members . XGrpMemNew $ memberInfo m + void . sendGroupMessage gInfo members . XGrpMemNew $ memberInfo m forM_ intros $ \intro@GroupMemberIntro {introId} -> do - void . sendDirectMessage conn . XGrpMemIntro . memberInfo $ reMember intro + void $ sendDirectMessage conn (XGrpMemIntro . memberInfo $ reMember intro) (GroupId groupId) withStore $ \st -> updateIntroStatus st introId GMIntroSent _ -> do -- TODO send probe and decide whether to use existing contact connection or the new contact connection @@ -731,7 +731,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage notifyMemberConnected gInfo m when (memberCategory m == GCPreMember) $ probeMatchingContacts ct MSG msgMeta msgBody -> do - (msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody + (msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody (GroupId groupId) withAckMessage agentConnId msgMeta $ case chatMsgEvent of XMsgNew mc -> newGroupContentMessage gInfo m mc msgId msgMeta @@ -1013,7 +1013,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage toView $ CRJoinedGroupMemberConnecting gInfo m newMember xGrpMemIntro :: Connection -> GroupInfo -> GroupMember -> MemberInfo -> m () - xGrpMemIntro conn gInfo m memInfo@(MemberInfo memId _ _) = do + xGrpMemIntro conn gInfo@GroupInfo {groupId} m memInfo@(MemberInfo memId _ _) = do case memberCategory m of GCHostMember -> do members <- withStore $ \st -> getGroupMembers st user gInfo @@ -1024,7 +1024,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage (directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation) newMember <- withStore $ \st -> createIntroReMember st user gInfo m memInfo groupConnId directConnId let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} - void $ sendDirectMessage conn msg + void $ sendDirectMessage conn msg (GroupId groupId) withStore $ \st -> updateGroupMemberStatus st userId newMember GSMemIntroInvited _ -> messageError "x.grp.mem.intro can be only sent by host member" @@ -1037,7 +1037,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage Nothing -> messageError "x.grp.mem.inv error: referenced member does not exists" Just reMember -> do GroupMemberIntro {introId} <- withStore $ \st -> saveIntroInvitation st reMember m introInv - void $ sendXGrpMemInv reMember (XGrpMemFwd (memberInfo m) introInv) introId + void $ sendXGrpMemInv gInfo reMember (XGrpMemFwd (memberInfo m) introInv) introId _ -> messageError "x.grp.mem.inv can be only sent by invitee member" xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () @@ -1214,22 +1214,22 @@ deleteMemberConnection m@GroupMember {activeConn} = do forM_ activeConn $ \conn -> withStore $ \st -> updateConnectionStatus st conn ConnDeleted sendDirectContactMessage :: ChatMonad m => Contact -> ChatMsgEvent -> m MessageId -sendDirectContactMessage ct@Contact {activeConn = conn@Connection {connStatus}} chatMsgEvent = do +sendDirectContactMessage ct@Contact {activeConn = conn@Connection {connId, connStatus}} chatMsgEvent = do if connStatus == ConnReady || connStatus == ConnSndReady - then sendDirectMessage conn chatMsgEvent + then sendDirectMessage conn chatMsgEvent (ConnectionId connId) else throwChatError $ CEContactNotReady ct -sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> m MessageId -sendDirectMessage conn chatMsgEvent = do - (msgId, msgBody) <- createSndMessage chatMsgEvent +sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> ConnOrGroupId -> m MessageId +sendDirectMessage conn chatMsgEvent connOrGroupId = do + (msgId, msgBody) <- createSndMessage chatMsgEvent connOrGroupId deliverMessage conn msgBody msgId pure msgId -createSndMessage :: ChatMonad m => ChatMsgEvent -> m (MessageId, MsgBody) -createSndMessage chatMsgEvent = do +createSndMessage :: ChatMonad m => ChatMsgEvent -> ConnOrGroupId -> m (MessageId, MsgBody) +createSndMessage chatMsgEvent connOrGroupId = do let msgBody = directMessage chatMsgEvent newMsg = NewMessage {direction = MDSnd, cmEventTag = toCMEventTag chatMsgEvent, msgBody} - msgId <- withStore $ \st -> createNewMessage st newMsg + msgId <- withStore $ \st -> createNewMessage st newMsg connOrGroupId pure (msgId, msgBody) directMessage :: ChatMsgEvent -> ByteString @@ -1241,18 +1241,18 @@ deliverMessage conn@Connection {connId} msgBody msgId = do let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId} withStore $ \st -> createSndMsgDelivery st sndMsgDelivery msgId -sendGroupMessage :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> m MessageId -sendGroupMessage members chatMsgEvent = - sendGroupMessage' members chatMsgEvent Nothing $ pure () +sendGroupMessage :: ChatMonad m => GroupInfo -> [GroupMember] -> ChatMsgEvent -> m MessageId +sendGroupMessage GroupInfo {groupId} members chatMsgEvent = + sendGroupMessage' members chatMsgEvent groupId Nothing $ pure () -sendXGrpMemInv :: ChatMonad m => GroupMember -> ChatMsgEvent -> Int64 -> m MessageId -sendXGrpMemInv reMember chatMsgEvent introId = - sendGroupMessage' [reMember] chatMsgEvent (Just introId) $ +sendXGrpMemInv :: ChatMonad m => GroupInfo -> GroupMember -> ChatMsgEvent -> Int64 -> m MessageId +sendXGrpMemInv GroupInfo {groupId} reMember chatMsgEvent introId = + sendGroupMessage' [reMember] chatMsgEvent groupId (Just introId) $ withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded) -sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Maybe Int64 -> m () -> m MessageId -sendGroupMessage' members chatMsgEvent introId_ postDeliver = do - (msgId, msgBody) <- createSndMessage chatMsgEvent +sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Int64 -> Maybe Int64 -> m () -> m MessageId +sendGroupMessage' members chatMsgEvent groupId introId_ postDeliver = do + (msgId, msgBody) <- createSndMessage chatMsgEvent (GroupId groupId) -- TODO collect failed deliveries into a single error forM_ (filter memberCurrent members) $ \m@GroupMember {groupMemberId} -> case memberConn m of @@ -1274,14 +1274,14 @@ sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do Nothing -> throwChatError $ CEGroupMemberIntroNotFound localDisplayName Just introId -> withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded) -saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> m (MessageId, ChatMsgEvent) -saveRcvMSG Connection {connId} agentMsgMeta msgBody = do +saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> ConnOrGroupId -> m (MessageId, ChatMsgEvent) +saveRcvMSG Connection {connId} agentMsgMeta msgBody connOrGroupId = do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody let agentMsgId = fst $ recipient agentMsgMeta cmEventTag = toCMEventTag chatMsgEvent newMsg = NewMessage {direction = MDRcv, cmEventTag, msgBody} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} - msgId <- withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery + msgId <- withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg connOrGroupId rcvMsgDelivery pure (msgId, chatMsgEvent) sendDirectChatItem :: ChatMonad m => UserId -> Contact -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTDirect 'MDSnd) @@ -1291,7 +1291,7 @@ sendDirectChatItem userId ct chatMsgEvent ciContent = do sendGroupChatItem :: ChatMonad m => UserId -> Group -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTGroup 'MDSnd) sendGroupChatItem userId (Group g ms) chatMsgEvent ciContent = do - msgId <- sendGroupMessage ms chatMsgEvent + msgId <- sendGroupMessage g ms chatMsgEvent saveSndChatItem userId (CDGroupSnd g) msgId ciContent saveSndChatItem :: ChatMonad m => UserId -> ChatDirection c 'MDSnd -> MessageId -> CIContent 'MDSnd -> m (ChatItem c 'MDSnd) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index febd4af663..1a136d5efb 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -422,6 +422,8 @@ data PendingGroupMessage = PendingGroupMessage type MessageId = Int64 +data ConnOrGroupId = ConnectionId Int64 | GroupId Int64 + data MsgDirection = MDRcv | MDSnd deriving (Show, Generic) diff --git a/src/Simplex/Chat/Migrations/M20220224_messages_fks.hs b/src/Simplex/Chat/Migrations/M20220224_messages_fks.hs new file mode 100644 index 0000000000..9bb5db57a5 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220224_messages_fks.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20220224_messages_fks where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20220224_messages_fks :: Query +m20220224_messages_fks = + [sql| +ALTER TABLE messages ADD COLUMN connection_id INTEGER DEFAULT NULL REFERENCES connections ON DELETE CASCADE; +ALTER TABLE messages ADD COLUMN group_id INTEGER DEFAULT NULL REFERENCES groups ON DELETE CASCADE; +|] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 1074537b1b..909dbaba97 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -157,6 +157,7 @@ import Simplex.Chat.Migrations.M20220101_initial import Simplex.Chat.Migrations.M20220122_v1_1 import Simplex.Chat.Migrations.M20220205_chat_item_status import Simplex.Chat.Migrations.M20220210_deduplicate_contact_requests +import Simplex.Chat.Migrations.M20220224_messages_fks import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Util (eitherToMaybe) @@ -174,7 +175,8 @@ schemaMigrations = [ ("20220101_initial", m20220101_initial), ("20220122_v1_1", m20220122_v1_1), ("20220205_chat_item_status", m20220205_chat_item_status), - ("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests) + ("20220210_deduplicate_contact_requests", m20220210_deduplicate_contact_requests), + ("20220224_messages_fks", m20220224_messages_fks) ] -- | The list of migrations in ascending order by date @@ -2010,11 +2012,11 @@ getSndFileTransfers_ db userId fileId = Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId} Nothing -> Left $ SESndFileInvalid fileId -createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m MessageId -createNewMessage st newMsg = +createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> ConnOrGroupId -> m MessageId +createNewMessage st newMsg connOrGroupId = liftIO . withTransaction st $ \db -> do currentTs <- getCurrentTime - createNewMessage_ db newMsg currentTs + createNewMessage_ db newMsg connOrGroupId currentTs createSndMsgDelivery :: MonadUnliftIO m => SQLiteStore -> SndMsgDelivery -> MessageId -> m () createSndMsgDelivery st sndMsgDelivery messageId = @@ -2023,11 +2025,11 @@ createSndMsgDelivery st sndMsgDelivery messageId = msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs -createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m MessageId -createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery = +createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> ConnOrGroupId -> RcvMsgDelivery -> m MessageId +createNewMessageAndRcvMsgDelivery st newMsg connOrGroupId rcvMsgDelivery = liftIO . withTransaction st $ \db -> do currentTs <- getCurrentTime - messageId <- createNewMessage_ db newMsg currentTs + messageId <- createNewMessage_ db newMsg connOrGroupId currentTs msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery messageId currentTs createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs pure messageId @@ -2048,17 +2050,21 @@ createRcvMsgDeliveryEvent st connId agentMsgId rcvMsgDeliveryStatus = currentTs <- getCurrentTime createMsgDeliveryEvent_ db msgDeliveryId rcvMsgDeliveryStatus currentTs -createNewMessage_ :: DB.Connection -> NewMessage -> UTCTime -> IO MessageId -createNewMessage_ db NewMessage {direction, cmEventTag, msgBody} createdAt = do +createNewMessage_ :: DB.Connection -> NewMessage -> ConnOrGroupId -> UTCTime -> IO MessageId +createNewMessage_ db NewMessage {direction, cmEventTag, msgBody} connOrGroupId createdAt = do DB.execute db [sql| INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, created_at, updated_at) - VALUES (?,?,?,?,?) + (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id) + VALUES (?,?,?,?,?,?,?) |] - (direction, cmEventTag, msgBody, createdAt, createdAt) + (direction, cmEventTag, msgBody, createdAt, createdAt, connId_, groupId_) insertedRowId db + where + (connId_, groupId_) = case connOrGroupId of + ConnectionId connId -> (Just connId, Nothing) + GroupId groupId -> (Nothing, Just groupId) createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> UTCTime -> IO Int64 createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId createdAt = do