IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master-ghc8107' into master-android

Browse Source
This commit is contained in:
Evgeny Poberezkin 2023-10-11 21:28:43 +01:00
commit c435cbdc7b
19 changed files with 450 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
simplex-chat.cabal
View File

@ -116,6 +116,7 @@ library
Simplex.Chat.Migrations.M20230926_contact_status Simplex.Chat.Migrations.M20230926_contact_status
Simplex.Chat.Migrations.M20231002_conn_initiated Simplex.Chat.Migrations.M20231002_conn_initiated
Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash
Simplex.Chat.Migrations.M20231010_member_settings
Simplex.Chat.Mobile Simplex.Chat.Mobile
Simplex.Chat.Mobile.File Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared Simplex.Chat.Mobile.Shared

132
src/Simplex/Chat.hs
View File

@ -794,7 +794,7 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of
CTDirect -> do CTDirect -> do
(ct, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId (ct, CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False (CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
@ -806,7 +806,7 @@ processChatCommand = \case
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do CTGroup -> do
Group gInfo ms <- withStore $ \db -> getGroup db user chatId Group gInfo ms <- withStore $ \db -> getGroup db user chatId
ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime (CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
@ -818,7 +818,7 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId
ci@(CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user gId itemId CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
case (chatDir, itemSharedMsgId) of case (chatDir, itemSharedMsgId) of
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete
@ -1170,7 +1170,7 @@ processChatCommand = \case
ct <- getContact db user chatId ct <- getContact db user chatId
liftIO $ updateContactSettings db user chatId chatSettings liftIO $ updateContactSettings db user chatId chatSettings
pure ct pure ct
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (enableNtfs chatSettings) withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (chatHasNtfs chatSettings)
ok user ok user
CTGroup -> do CTGroup -> do
ms <- withStore $ \db -> do ms <- withStore $ \db -> do
@ -1178,9 +1178,17 @@ processChatCommand = \case
liftIO $ updateGroupSettings db user chatId chatSettings liftIO $ updateGroupSettings db user chatId chatSettings
pure ms pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId -> forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId $ enableNtfs chatSettings) `catchChatError` (toView . CRChatError (Just user)) withAgent (\a -> toggleConnectionNtfs a connId $ chatHasNtfs chatSettings) `catchChatError` (toView . CRChatError (Just user))
ok user ok user
_ -> pure $ chatCmdError (Just user) "not supported" _ -> pure $ chatCmdError (Just user) "not supported"
APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do
m <- withStore $ \db -> do
liftIO $ updateGroupMemberSettings db user gId gMemberId settings
getGroupMember db user gId gMemberId
when (memberActive m) $ forM_ (memberConnId m) $ \connId -> do
let ntfOn = showMessages $ memberSettings m
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user))
ok user
APIContactInfo contactId -> withUser $ \user@User {userId} -> do APIContactInfo contactId -> withUser $ \user@User {userId} -> do
-- [incognito] print user's incognito profile for this contact -- [incognito] print user's incognito profile for this contact
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId
@ -1275,6 +1283,11 @@ processChatCommand = \case
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn}) SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn})
SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_}) SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_})
SetShowMemberMessages gName mName showMessages -> withUser $ \user -> do
(gId, mId) <- getGroupAndMemberId user gName mName
m <- withStore $ \db -> getGroupMember db user gId mId
let settings = (memberSettings m) {showMessages}
processChatCommand $ APISetMemberSettings gId mId settings
ContactInfo cName -> withContactName cName APIContactInfo ContactInfo cName -> withContactName cName APIContactInfo
ShowGroupInfo gName -> withUser $ \user -> do ShowGroupInfo gName -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName groupId <- withStore $ \db -> getGroupIdByName db user gName
@ -2065,7 +2078,7 @@ processChatCommand = \case
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g) when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
delGroupChatItem :: User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> m ChatResponse delGroupChatItem :: MsgDirectionI d => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> m ChatResponse
delGroupChatItem user gInfo ci msgId byGroupMember = do delGroupChatItem user gInfo ci msgId byGroupMember = do
deletedTs <- liftIO getCurrentTime deletedTs <- liftIO getCurrentTime
if groupFeatureAllowed SGFFullDelete gInfo if groupFeatureAllowed SGFFullDelete gInfo
@ -2805,10 +2818,10 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
waitChatStarted waitChatStarted
case cType of case cType of
CTDirect -> do CTDirect -> do
(ct, ci) <- withStoreCtx (Just "deleteTimedItem, getContact ...") $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId (ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
deleteDirectCI user ct ci True True >>= toView deleteDirectCI user ct ci True True >>= toView
CTGroup -> do CTGroup -> do
(gInfo, ci) <- withStoreCtx (Just "deleteTimedItem, getGroupInfo ...") $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId (gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
deletedTs <- liftIO getCurrentTime deletedTs <- liftIO getCurrentTime
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType" _ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
@ -3327,7 +3340,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
updateGroupMemberStatus db userId membership GSMemConnected updateGroupMemberStatus db userId membership GSMemConnected
-- possible improvement: check for each pending message, requires keeping track of connection state -- possible improvement: check for each pending message, requires keeping track of connection state
unless (connDisabled conn) $ sendPendingGroupMessages user m conn unless (connDisabled conn) $ sendPendingGroupMessages user m conn
withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ enableNtfs chatSettings withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings
case memberCategory m of case memberCategory m of
GCHostMember -> do GCHostMember -> do
toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected}
@ -3923,7 +3936,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct) deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct)
where where
deleteRcvChatItem = do deleteRcvChatItem = do
ci@(CChatItem msgDir _) <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId CChatItem msgDir ci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
case msgDir of case msgDir of
SMDRcv -> SMDRcv ->
if featureAllowed SCFFullDelete forContact ct if featureAllowed SCFFullDelete forContact ct
@ -4004,21 +4017,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
createItem timed_ live createItem timed_ live
| groupFeatureAllowed SGFFullDelete gInfo = do | groupFeatureAllowed SGFFullDelete gInfo = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo (CChatItem SMDRcv ci) moderator moderatedAt ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
toView $ CRNewChatItem user ci' toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci'
| otherwise = do | otherwise = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False
cr <- markGroupCIDeleted user gInfo (CChatItem SMDRcv ci) createdByMsgId False (Just moderator) moderatedAt toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt
toView cr
createItem timed_ live = do createItem timed_ live = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
autoAcceptFile file_ when (showMessages $ memberSettings m) $ autoAcceptFile file_
newChatItem ciContent ciFile_ timed_ live = do newChatItem ciContent ciFile_ timed_ live = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_ reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
groupMsgToView gInfo m ci {reactions} msgMeta groupMsgToView gInfo m ci' {reactions} msgMeta
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m () groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ = groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
@ -4030,7 +4043,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
ci' <- withStore' $ \db -> do ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc createChatItemVersion db (chatItemId' ci) brokerTs mc
updateGroupChatItem db user groupId ci content live Nothing ci' <- updateGroupChatItem db user groupId ci content live Nothing
blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci'
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
where where
MsgMeta {broker = (_, brokerTs)} = msgMeta MsgMeta {broker = (_, brokerTs)} = msgMeta
@ -4059,7 +4073,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do
let msgMemberId = fromMaybe memberId sndMemberId_ let msgMemberId = fromMaybe memberId sndMemberId_
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case
Right ci@(CChatItem _ ChatItem {chatDir}) -> case chatDir of Right (CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of
CIGroupRcv mem CIGroupRcv mem
| sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView | sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView
| otherwise -> deleteMsg mem ci | otherwise -> deleteMsg mem ci
@ -4069,7 +4083,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| senderRole < GRAdmin -> messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e | senderRole < GRAdmin -> messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
| otherwise -> withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs | otherwise -> withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
where where
deleteMsg :: GroupMember -> CChatItem 'CTGroup -> m () deleteMsg :: MsgDirectionI d => GroupMember -> ChatItem 'CTGroup d -> m ()
deleteMsg mem ci = case sndMemberId_ of deleteMsg mem ci = case sndMemberId_ of
Just sndMemberId Just sndMemberId
| sameMemberId sndMemberId mem -> checkRole mem $ delete ci (Just m) >>= toView | sameMemberId sndMemberId mem -> checkRole mem $ delete ci (Just m) >>= toView
@ -4079,6 +4093,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
| senderRole < GRAdmin || senderRole < memberRole = | senderRole < GRAdmin || senderRole < memberRole =
messageError "x.msg.del: message of another member with insufficient member permissions" messageError "x.msg.del: message of another member with insufficient member permissions"
| otherwise = a | otherwise = a
delete :: MsgDirectionI d => ChatItem 'CTGroup d -> Maybe GroupMember -> m ChatResponse
delete ci byGroupMember delete ci byGroupMember
| groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCI user gInfo ci False False byGroupMember brokerTs | groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCI user gInfo ci False False byGroupMember brokerTs
| otherwise = markGroupCIDeleted user gInfo ci msgId False byGroupMember brokerTs | otherwise = markGroupCIDeleted user gInfo ci msgId False byGroupMember brokerTs
@ -4104,7 +4119,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
groupMsgToView gInfo m ci msgMeta ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
groupMsgToView gInfo m ci' msgMeta
blockedMember :: Monad m' => GroupMember -> ChatItem c d -> m' (ChatItem c d) -> m' (ChatItem c d)
blockedMember m ci blockedCI
| showMessages (memberSettings m) = pure ci
| otherwise = blockedCI
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode) receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode)
receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of
@ -4623,7 +4644,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m () xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro gInfo@GroupInfo {chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
case memberCategory m of case memberCategory m of
GCHostMember -> do GCHostMember -> do
members <- withStore' $ \db -> getGroupMembers db user gInfo members <- withStore' $ \db -> getGroupMembers db user gInfo
@ -4643,7 +4664,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId subMode void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId subMode
_ -> messageError "x.grp.mem.intro can be only sent by host member" _ -> messageError "x.grp.mem.intro can be only sent by host member"
where where
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation subMode createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m () sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m ()
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
@ -4666,7 +4687,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> messageError "x.grp.mem.inv can be only sent by invitee member" _ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m () xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
checkHostRole m memRole checkHostRole m memRole
members <- withStore' $ \db -> getGroupMembers db user gInfo members <- withStore' $ \db -> getGroupMembers db user gInfo
toMember <- case find (sameMemberId memId) members of toMember <- case find (sameMemberId memId) members of
@ -4681,8 +4702,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- [incognito] send membership incognito profile, create direct connection as incognito -- [incognito] send membership incognito profile, create direct connection as incognito
dm <- directMessage $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership) dm <- directMessage $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability -- [async agent commands] no continuation needed, but commands should be asynchronous for stability
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm subMode groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr dm subMode
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId subMode withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId subMode
@ -5206,20 +5227,22 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs cur
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs currentTs currentTs meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs currentTs currentTs
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file} pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> Bool -> m ChatResponse deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse
deleteDirectCI user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do deleteDirectCI user ct ci@ChatItem {file} byUser timed = do
deleteCIFile user file deleteCIFile user file
withStoreCtx' (Just "deleteDirectCI, deleteDirectChatItem") $ \db -> deleteDirectChatItem db user ct ci withStoreCtx' (Just "deleteDirectCI, deleteDirectChatItem") $ \db -> deleteDirectChatItem db user ct ci
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser timed pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDirection (DirectChat ct) ci) Nothing byUser timed
deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse deleteGroupCI :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed byGroupMember_ deletedTs = do deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedTs = do
deleteCIFile user file deleteCIFile user file
toCi <- withStoreCtx' (Just "deleteGroupCI, deleteGroupChatItem ...") $ \db -> toCi <- withStoreCtx' (Just "deleteGroupCI, deleteGroupChatItem ...") $ \db ->
case byGroupMember_ of case byGroupMember_ of
Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing
Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed pure $ CRChatItemDeleted user (gItem ci) (gItem <$> toCi) byUser timed
where
gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m () deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
deleteCIFile user file_ = deleteCIFile user file_ =
@ -5227,25 +5250,21 @@ deleteCIFile user file_ =
fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
deleteAgentConnectionsAsync user fileAgentConnIds deleteAgentConnectionsAsync user fileAgentConnIds
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse markDirectCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> MessageId -> Bool -> UTCTime -> m ChatResponse
markDirectCIDeleted user ct@Contact {contactId} ci@(CChatItem _ ChatItem {file}) msgId byUser deletedTs = do markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do
cancelCIFile user file cancelCIFile user file
toCi <- withStore $ \db -> do ci' <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId deletedTs
liftIO $ markDirectChatItemDeleted db user ct ci msgId deletedTs pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem ci') byUser False
getDirectChatItem db user contactId (cchatItemId ci)
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem toCi) byUser False
where where
ctItem (CChatItem msgDir ci') = AChatItem SCTDirect msgDir (DirectChat ct) ci' ctItem = AChatItem SCTDirect msgDirection (DirectChat ct)
markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse markGroupCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
markGroupCIDeleted user gInfo@GroupInfo {groupId} ci@(CChatItem _ ChatItem {file}) msgId byUser byGroupMember_ deletedTs = do markGroupCIDeleted user gInfo ci@ChatItem {file} msgId byUser byGroupMember_ deletedTs = do
cancelCIFile user file cancelCIFile user file
toCi <- withStore $ \db -> do ci' <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
liftIO $ markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem ci') byUser False
getGroupChatItem db user groupId (cchatItemId ci)
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem toCi) byUser False
where where
gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci' gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m () cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
cancelCIFile user file_ = cancelCIFile user file_ =
@ -5431,21 +5450,6 @@ getCreateActiveUser st testView = do
getWithPrompt :: String -> IO String getWithPrompt :: String -> IO String
getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
userNtf :: User -> Bool
userNtf User {showNtfs, activeUser} = showNtfs || activeUser
chatNtf :: User -> ChatInfo c -> Bool
chatNtf user = \case
DirectChat ct -> contactNtf user ct
GroupChat g -> groupNtf user g
_ -> False
contactNtf :: User -> Contact -> Bool
contactNtf user Contact {chatSettings} = userNtf user && enableNtfs chatSettings
groupNtf :: User -> GroupInfo -> Bool
groupNtf user GroupInfo {chatSettings} = userNtf user && enableNtfs chatSettings
withUser' :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse withUser' :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse
withUser' action = withUser' action =
asks currentUser asks currentUser
@ -5483,9 +5487,12 @@ withAgent action =
chatCommandP :: Parser ChatCommand chatCommandP :: Parser ChatCommand
chatCommandP = chatCommandP =
choice choice
[ "/mute " *> ((`SetShowMessages` False) <$> chatNameP), [ "/mute " *> ((`SetShowMessages` MFNone) <$> chatNameP),
"/unmute " *> ((`SetShowMessages` True) <$> chatNameP), "/unmute " *> ((`SetShowMessages` MFAll) <$> chatNameP),
"/unmute mentions " *> ((`SetShowMessages` MFMentions) <$> chatNameP),
"/receipts " *> (SetSendReceipts <$> chatNameP <* " " <*> ((Just <$> onOffP) <|> ("default" $> Nothing))), "/receipts " *> (SetSendReceipts <$> chatNameP <* " " <*> ((Just <$> onOffP) <|> ("default" $> Nothing))),
"/block #" *> (SetShowMemberMessages <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure False),
"/unblock #" *> (SetShowMemberMessages <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure True),
"/_create user " *> (CreateActiveUser <$> jsonP), "/_create user " *> (CreateActiveUser <$> jsonP),
"/create user " *> (CreateActiveUser <$> newUserP), "/create user " *> (CreateActiveUser <$> newUserP),
"/users" $> ListUsers, "/users" $> ListUsers,
@ -5589,6 +5596,7 @@ chatCommandP =
("/network" <|> "/net") $> APIGetNetworkConfig, ("/network" <|> "/net") $> APIGetNetworkConfig,
"/reconnect" $> ReconnectAllServers, "/reconnect" $> ReconnectAllServers,
"/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP), "/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP),
"/_member settings #" *> (APISetMemberSettings <$> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP),
"/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal), "/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal),
"/_info #" *> (APIGroupInfo <$> A.decimal), "/_info #" *> (APIGroupInfo <$> A.decimal),
"/_info @" *> (APIContactInfo <$> A.decimal), "/_info @" *> (APIContactInfo <$> A.decimal),

4
src/Simplex/Chat/Controller.hs
View File

@ -288,6 +288,7 @@ data ChatCommand
| APIGetNetworkConfig | APIGetNetworkConfig
| ReconnectAllServers | ReconnectAllServers
| APISetChatSettings ChatRef ChatSettings | APISetChatSettings ChatRef ChatSettings
| APISetMemberSettings GroupId GroupMemberId GroupMemberSettings
| APIContactInfo ContactId | APIContactInfo ContactId
| APIGroupInfo GroupId | APIGroupInfo GroupId
| APIGroupMemberInfo GroupId GroupMemberId | APIGroupMemberInfo GroupId GroupMemberId
@ -303,8 +304,9 @@ data ChatCommand
| APIVerifyGroupMember GroupId GroupMemberId (Maybe Text) | APIVerifyGroupMember GroupId GroupMemberId (Maybe Text)
| APIEnableContact ContactId | APIEnableContact ContactId
| APIEnableGroupMember GroupId GroupMemberId | APIEnableGroupMember GroupId GroupMemberId
| SetShowMessages ChatName Bool | SetShowMessages ChatName MsgFilter
| SetSendReceipts ChatName (Maybe Bool) | SetSendReceipts ChatName (Maybe Bool)
| SetShowMemberMessages GroupName ContactName Bool
| ContactInfo ContactName | ContactInfo ContactName
| ShowGroupInfo GroupName | ShowGroupInfo GroupName
| GroupMemberInfo GroupName ContactName | GroupMemberInfo GroupName ContactName

37
src/Simplex/Chat/Messages.hs
View File

@ -147,6 +147,19 @@ instance MsgDirectionI d => ToJSON (ChatItem c d) where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
isMention :: ChatItem c d -> Bool
isMention ChatItem {chatDir, quotedItem} = case chatDir of
CIDirectRcv -> userItem quotedItem
CIGroupRcv _ -> userItem quotedItem
_ -> False
where
userItem = \case
Nothing -> False
Just CIQuote {chatDir = cd} -> case cd of
CIQDirectSnd -> True
CIQGroupSnd -> True
_ -> False
data CIDirection (c :: ChatType) (d :: MsgDirection) where data CIDirection (c :: ChatType) (d :: MsgDirection) where
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
@ -217,26 +230,6 @@ ciReactionAllowed :: ChatItem c d -> Bool
ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False
ciReactionAllowed ChatItem {content} = isJust $ ciMsgContent content ciReactionAllowed ChatItem {content} = isJust $ ciMsgContent content
data CIDeletedState = CIDeletedState
{ markedDeleted :: Bool,
deletedByMember :: Maybe GroupMember
}
deriving (Show, Eq)
chatItemDeletedState :: ChatItem c d -> Maybe CIDeletedState
chatItemDeletedState ChatItem {meta = CIMeta {itemDeleted}, content} =
ciDeletedToDeletedState <$> itemDeleted
where
ciDeletedToDeletedState cid =
case content of
CISndModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid}
CIRcvModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid}
_ -> CIDeletedState {markedDeleted = True, deletedByMember = byMember cid}
byMember :: CIDeleted c -> Maybe GroupMember
byMember = \case
CIModerated _ m -> Just m
CIDeleted _ -> Nothing
data ChatDirection (c :: ChatType) (d :: MsgDirection) where data ChatDirection (c :: ChatType) (d :: MsgDirection) where
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
@ -926,6 +919,7 @@ checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of
data CIDeleted (c :: ChatType) where data CIDeleted (c :: ChatType) where
CIDeleted :: Maybe UTCTime -> CIDeleted c CIDeleted :: Maybe UTCTime -> CIDeleted c
CIBlocked :: Maybe UTCTime -> CIDeleted c
CIModerated :: Maybe UTCTime -> GroupMember -> CIDeleted 'CTGroup CIModerated :: Maybe UTCTime -> GroupMember -> CIDeleted 'CTGroup
deriving instance Show (CIDeleted c) deriving instance Show (CIDeleted c)
@ -936,6 +930,7 @@ instance ToJSON (CIDeleted d) where
data JSONCIDeleted data JSONCIDeleted
= JCIDDeleted {deletedTs :: Maybe UTCTime} = JCIDDeleted {deletedTs :: Maybe UTCTime}
| JCIBlocked {deletedTs :: Maybe UTCTime}
| JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember} | JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember}
deriving (Show, Generic) deriving (Show, Generic)
@ -946,11 +941,13 @@ instance ToJSON JSONCIDeleted where
jsonCIDeleted :: CIDeleted d -> JSONCIDeleted jsonCIDeleted :: CIDeleted d -> JSONCIDeleted
jsonCIDeleted = \case jsonCIDeleted = \case
CIDeleted ts -> JCIDDeleted ts CIDeleted ts -> JCIDDeleted ts
CIBlocked ts -> JCIBlocked ts
CIModerated ts m -> JCIDModerated ts m CIModerated ts m -> JCIDModerated ts m
itemDeletedTs :: CIDeleted d -> Maybe UTCTime itemDeletedTs :: CIDeleted d -> Maybe UTCTime
itemDeletedTs = \case itemDeletedTs = \case
CIDeleted ts -> ts CIDeleted ts -> ts
CIBlocked ts -> ts
CIModerated ts _ -> ts CIModerated ts _ -> ts
data ChatItemInfo = ChatItemInfo data ChatItemInfo = ChatItemInfo

14
src/Simplex/Chat/Messages/CIContent.hs
View File

@ -19,12 +19,8 @@ import Data.Int (Int64)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Type.Equality import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32) import Data.Word (Word32)
import Database.SQLite.Simple (ResultError (..), SQLData (..)) import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.FromField (Field, FromField (..), returnError)
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.ToField (ToField (..)) import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
@ -50,14 +46,6 @@ instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgD
instance ToField MsgDirection where toField = toField . msgDirectionInt instance ToField MsgDirection where toField = toField . msgDirectionInt
fromIntField_ :: Typeable a => (Int64 -> Maybe a) -> Field -> Ok a
fromIntField_ fromInt = \case
f@(Field (SQLInteger i) _) ->
case fromInt i of
Just x -> Ok x
_ -> returnError ConversionFailed f ("invalid integer: " <> show i)
f -> returnError ConversionFailed f "expecting SQLInteger column type"
data SMsgDirection (d :: MsgDirection) where data SMsgDirection (d :: MsgDirection) where
SMDRcv :: SMsgDirection 'MDRcv SMDRcv :: SMsgDirection 'MDRcv
SMDSnd :: SMsgDirection 'MDSnd SMDSnd :: SMsgDirection 'MDSnd

18
src/Simplex/Chat/Migrations/M20231010_member_settings.hs Normal file
View File

@ -0,0 +1,18 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20231010_member_settings where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20231010_member_settings :: Query
m20231010_member_settings =
[sql|
ALTER TABLE group_members ADD COLUMN show_messages INTEGER NOT NULL DEFAULT 1;
|]
down_m20231010_member_settings :: Query
down_m20231010_member_settings =
[sql|
ALTER TABLE group_members DROP COLUMN show_messages;
|]

1
src/Simplex/Chat/Migrations/chat_schema.sql
View File

@ -145,6 +145,7 @@ CREATE TABLE group_members(
created_at TEXT CHECK(created_at NOT NULL), created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL), updated_at TEXT CHECK(updated_at NOT NULL),
member_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL, member_profile_id INTEGER REFERENCES contact_profiles ON DELETE SET NULL,
show_messages INTEGER NOT NULL DEFAULT 1,
FOREIGN KEY(user_id, local_display_name) FOREIGN KEY(user_id, local_display_name)
REFERENCES display_names(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name)
ON DELETE CASCADE ON DELETE CASCADE

5
src/Simplex/Chat/Protocol.hs
View File

@ -376,6 +376,11 @@ mcExtMsgContent = \case
MCQuote _ c -> c MCQuote _ c -> c
MCForward c -> c MCForward c -> c
isQuote :: MsgContainer -> Bool
isQuote = \case
MCQuote {} -> True
_ -> False
data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent} data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent}
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)

8
src/Simplex/Chat/Store/Connections.hs
View File

@ -76,10 +76,10 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0
|] |]
(userId, contactId) (userId, contactId)
toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, ContactStatus) :. (Maybe Bool, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)] -> Either StoreError Contact toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)] -> Either StoreError Contact
toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)] = toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)] =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent} in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent}
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
@ -94,11 +94,11 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupInfo {membership} -- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}} -- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- from GroupMember -- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences
FROM group_members m FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)

51
src/Simplex/Chat/Store/Groups.hs
View File

@ -89,6 +89,7 @@ module Simplex.Chat.Store.Groups
associateContactWithMemberRecord, associateContactWithMemberRecord,
deleteOldProbes, deleteOldProbes,
updateGroupSettings, updateGroupSettings,
updateGroupMemberSettings,
getXGrpMemIntroContDirect, getXGrpMemIntroContDirect,
getXGrpMemIntroContGroup, getXGrpMemIntroContGroup,
getHostConnId, getHostConnId,
@ -126,30 +127,31 @@ import Simplex.Messaging.Util (eitherToMaybe, ($>>=), (<$$>))
import Simplex.Messaging.Version import Simplex.Messaging.Version
import UnliftIO.STM import UnliftIO.STM
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe MsgFilter, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime) :. GroupMemberRow
type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) type GroupMemberRow = ((Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool) :. (Maybe Int64, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences))
type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (Maybe Int64, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences))
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) = toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
let membership = toGroupMember userContactId userMemberRow let membership = toGroupMember userContactId userMemberRow
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences fullGroupPreferences = mergeGroupPreferences groupPreferences
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs} in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs}
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) =
let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} let memberProfile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
memberSettings = GroupMemberSettings {showMessages}
invitedBy = toInvitedBy userContactId invitedById invitedBy = toInvitedBy userContactId invitedById
activeConn = Nothing activeConn = Nothing
in GroupMember {..} in GroupMember {..}
toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember
toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) = toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just memberId, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages) :. (invitedById, Just localDisplayName, memberContactId, Just memberContactProfileId, Just profileId, Just displayName, Just fullName, image, contactLink, Just localAlias, contactPreferences)) =
Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences)) Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, showMessages) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences))
toMaybeGroupMember _ _ = Nothing toMaybeGroupMember _ _ = Nothing
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO () createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO ()
@ -245,11 +247,11 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupInfo {membership} -- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}} -- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- from GroupMember -- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
@ -295,7 +297,7 @@ createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do
insertedRowId db insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12 memberId <- liftIO $ encodedRandomBytes gVar 12
membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs membership <- createContactMemberInv_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing currentTs
let chatSettings = ChatSettings {enableNtfs = True, sendRcpts = Nothing, favorite = False} let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs} pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}
-- | creates a new group record for the group the current user was invited to, or returns an existing one -- | creates a new group record for the group the current user was invited to, or returns an existing one
@ -340,7 +342,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
insertedRowId db insertedRowId db
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs
membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs membership <- createContactMemberInv_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs
let chatSettings = ChatSettings {enableNtfs = True, sendRcpts = Nothing, favorite = False} let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId) pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId)
getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
@ -364,6 +366,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
memberRole, memberRole,
memberCategory, memberCategory,
memberStatus, memberStatus,
memberSettings = defaultMemberSettings,
invitedBy, invitedBy,
localDisplayName, localDisplayName,
memberProfile, memberProfile,
@ -488,7 +491,7 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
db db
[sql| [sql|
SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.show_messages,
mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences
FROM groups g FROM groups g
JOIN group_profiles gp USING (group_profile_id) JOIN group_profiles gp USING (group_profile_id)
@ -553,7 +556,7 @@ groupMemberQuery :: Query
groupMemberQuery = groupMemberQuery =
[sql| [sql|
SELECT SELECT
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
@ -660,6 +663,7 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
memberRole, memberRole,
memberCategory = GCInviteeMember, memberCategory = GCInviteeMember,
memberStatus = GSMemInvited, memberStatus = GSMemInvited,
memberSettings = defaultMemberSettings,
invitedBy = IBUser, invitedBy = IBUser,
localDisplayName, localDisplayName,
memberProfile = profile, memberProfile = profile,
@ -810,7 +814,8 @@ createNewMember_
|] |]
(groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt) (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt)
groupMemberId <- insertedRowId db groupMemberId <- insertedRowId db
pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn} let memberSettings = defaultMemberSettings
pure GroupMember {groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, memberSettings, invitedBy, localDisplayName, memberProfile = toLocalProfile memberContactProfileId memberProfile "", memberContactId, memberContactProfileId, activeConn}
checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId) checkGroupMemberHasItems :: DB.Connection -> User -> GroupMember -> IO (Maybe ChatItemId)
checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} = checkGroupMemberHasItems db User {userId} GroupMember {groupMemberId, groupId} =
@ -1008,11 +1013,11 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupInfo {membership} -- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}} -- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- via GroupMember -- via GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.show_messages,
m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
@ -1101,7 +1106,7 @@ getGroupInfo db User {userId, userContactId} groupId =
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupMember - membership -- GroupMember - membership
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences
FROM groups g FROM groups g
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
@ -1497,6 +1502,18 @@ updateGroupSettings :: DB.Connection -> User -> Int64 -> ChatSettings -> IO ()
updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs, sendRcpts, favorite} = updateGroupSettings db User {userId} groupId ChatSettings {enableNtfs, sendRcpts, favorite} =
DB.execute db "UPDATE groups SET enable_ntfs = ?, send_rcpts = ?, favorite = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, sendRcpts, favorite, userId, groupId) DB.execute db "UPDATE groups SET enable_ntfs = ?, send_rcpts = ?, favorite = ? WHERE user_id = ? AND group_id = ?" (enableNtfs, sendRcpts, favorite, userId, groupId)
updateGroupMemberSettings :: DB.Connection -> User -> GroupId -> GroupMemberId -> GroupMemberSettings -> IO ()
updateGroupMemberSettings db User {userId} gId gMemberId GroupMemberSettings {showMessages} = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE group_members
SET show_messages = ?, updated_at = ?
WHERE user_id = ? AND group_id = ? AND group_member_id = ?
|]
(showMessages, currentTs, userId, gId, gMemberId)
getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont)) getXGrpMemIntroContDirect :: DB.Connection -> User -> Contact -> IO (Maybe (Int64, XGrpMemIntroCont))
getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do getXGrpMemIntroContDirect db User {userId} Contact {contactId} = do
fmap join . maybeFirstRow toCont $ fmap join . maybeFirstRow toCont $

96
src/Simplex/Chat/Store/Messages.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
@ -48,6 +49,7 @@ module Simplex.Chat.Store.Messages
deleteGroupChatItem, deleteGroupChatItem,
updateGroupChatItemModerated, updateGroupChatItemModerated,
markGroupChatItemDeleted, markGroupChatItemDeleted,
markGroupChatItemBlocked,
updateDirectChatItemsRead, updateDirectChatItemsRead,
getDirectUnreadTimedItems, getDirectUnreadTimedItems,
setDirectChatItemDeleteAt, setDirectChatItemDeleteAt,
@ -434,7 +436,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
SELECT i.chat_item_id, SELECT i.chat_item_id,
-- GroupMember -- GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, m.member_status, m.show_messages, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences
FROM group_members m FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id)
@ -544,7 +546,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts, g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, g.created_at, g.updated_at, g.chat_ts,
-- GroupMember - membership -- GroupMember - membership
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, mu.member_status, mu.show_messages, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- ChatStats -- ChatStats
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat, COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat,
@ -554,17 +556,17 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- Maybe GroupMember - sender -- Maybe GroupMember - sender
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, m.member_status, m.show_messages, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
-- quoted ChatItem -- quoted ChatItem
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
-- quoted GroupMember -- quoted GroupMember
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, rm.member_status, rm.show_messages, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences,
-- deleted by GroupMember -- deleted by GroupMember
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, dbm.member_status, dbm.show_messages, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
FROM groups g FROM groups g
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
@ -958,9 +960,9 @@ type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath,
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool)
type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Bool, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Int, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow
type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId) :. (Maybe Bool, Maybe UTCTime, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe AMsgDirection, Maybe Text, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId) :. (Maybe Int, Maybe UTCTime, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow
type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool)
@ -1003,7 +1005,9 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
badItem = Left $ SEBadChatItem itemId badItem = Left $ SEBadChatItem itemId
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
ciMeta content status = ciMeta content status =
let itemDeleted' = if itemDeleted then Just (CIDeleted @'CTDirect deletedTs) else Nothing let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
_ -> Just (CIDeleted @'CTDirect deletedTs)
itemEdited' = fromMaybe False itemEdited itemEdited' = fromMaybe False itemEdited
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
ciTimed :: Maybe CITimed ciTimed :: Maybe CITimed
@ -1059,10 +1063,10 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
badItem = Left $ SEBadChatItem itemId badItem = Left $ SEBadChatItem itemId
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d
ciMeta content status = ciMeta content status =
let itemDeleted' = let itemDeleted' = case itemDeleted of
if itemDeleted DBCINotDeleted -> Nothing
then Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) DBCIBlocked -> Just (CIBlocked @'CTGroup deletedTs)
else Nothing _ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = fromMaybe False itemEdited itemEdited' = fromMaybe False itemEdited
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
ciTimed :: Maybe CITimed ciTimed :: Maybe CITimed
@ -1221,8 +1225,8 @@ createChatItemVersion db itemId itemVersionTs msgContent =
|] |]
(itemId, toMCText msgContent, itemVersionTs) (itemId, toMCText msgContent, itemVersionTs)
deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () deleteDirectChatItem :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> IO ()
deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do deleteDirectChatItem db User {userId} Contact {contactId} ci = do
let itemId = chatItemId' ci let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId deleteChatItemVersions_ db itemId
@ -1253,8 +1257,8 @@ deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO ()
deleteChatItemVersions_ db itemId = deleteChatItemVersions_ db itemId =
DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId)
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> UTCTime -> IO () markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> MessageId -> UTCTime -> IO (ChatItem 'CTDirect d)
markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci) msgId deletedTs = do markDirectChatItemDeleted db User {userId} Contact {contactId} ci@ChatItem {meta} msgId deletedTs = do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci let itemId = chatItemId' ci
insertChatItemMessage_ db itemId msgId currentTs insertChatItemMessage_ db itemId msgId currentTs
@ -1262,10 +1266,11 @@ markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci)
db db
[sql| [sql|
UPDATE chat_items UPDATE chat_items
SET item_deleted = 1, item_deleted_ts = ?, updated_at = ? SET item_deleted = ?, item_deleted_ts = ?, updated_at = ?
WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|] |]
(deletedTs, currentTs, userId, contactId, itemId) (DBCIDeleted, deletedTs, currentTs, userId, contactId, itemId)
pure ci {meta = meta {itemDeleted = Just $ CIDeleted $ Just deletedTs}}
getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect) getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do
@ -1376,8 +1381,8 @@ updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ =
((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) ((content, itemText, itemStatus, itemDeleted', itemDeletedTs', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId))
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO () deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do
let itemId = chatItemId' ci let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId deleteChatItemVersions_ db itemId
@ -1390,10 +1395,10 @@ deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do
|] |]
(userId, groupId, itemId) (userId, groupId, itemId)
updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> UTCTime -> IO AChatItem updateGroupChatItemModerated :: forall d. MsgDirectionI d => DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} deletedTs = do updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMember {groupMemberId} deletedTs = do
currentTs <- getCurrentTime currentTs <- getCurrentTime
let toContent = msgDirToModeratedContent_ msgDir let toContent = msgDirToModeratedContent_ $ msgDirection @d
toText = ciModeratedText toText = ciModeratedText
itemId = chatItemId' ci itemId = chatItemId' ci
deleteChatItemMessages_ db itemId deleteChatItemMessages_ db itemId
@ -1407,24 +1412,47 @@ updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatIt
WHERE user_id = ? AND group_id = ? AND chat_item_id = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|] |]
(deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) (deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId)
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m), editable = False}, formattedText = Nothing}) pure $ ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just currentTs) m), editable = False}, formattedText = Nothing}
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> UTCTime -> IO () pattern DBCINotDeleted :: Int
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} (CChatItem _ ci) msgId byGroupMember_ deletedTs = do pattern DBCINotDeleted = 0
pattern DBCIDeleted :: Int
pattern DBCIDeleted = 1
pattern DBCIBlocked :: Int
pattern DBCIBlocked = 2
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} msgId byGroupMember_ deletedTs = do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci let itemId = chatItemId' ci
deletedByGroupMemberId = case byGroupMember_ of (deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of
Just GroupMember {groupMemberId} -> Just groupMemberId Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m)
_ -> Nothing _ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs))
insertChatItemMessage_ db itemId msgId currentTs insertChatItemMessage_ db itemId msgId currentTs
DB.execute DB.execute
db db
[sql| [sql|
UPDATE chat_items UPDATE chat_items
SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ? SET item_deleted = ?, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|] |]
(deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId) (DBCIDeleted, deletedTs, deletedByGroupMemberId, currentTs, userId, groupId, itemId)
pure ci {meta = meta {itemDeleted}}
markGroupChatItemBlocked :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup 'MDRcv -> IO (ChatItem 'CTGroup 'MDRcv)
markGroupChatItemBlocked db User {userId} GroupInfo {groupId} ci@ChatItem {meta} = do
deletedTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE chat_items
SET item_deleted = ?, item_deleted_ts = ?, updated_at = ?
WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|]
(DBCIBlocked, deletedTs, deletedTs, userId, groupId, chatItemId' ci)
pure ci {meta = meta {itemDeleted = Just $ CIBlocked $ Just deletedTs}}
getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do
@ -1482,17 +1510,17 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol,
-- GroupMember -- GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category,
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, m.member_status, m.show_messages, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
-- quoted ChatItem -- quoted ChatItem
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
-- quoted GroupMember -- quoted GroupMember
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, rm.member_status, rm.show_messages, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences, rp.display_name, rp.full_name, rp.image, rp.contact_link, rp.local_alias, rp.preferences,
-- deleted by GroupMember -- deleted by GroupMember
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, dbm.member_status, dbm.show_messages, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
FROM chat_items i FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id LEFT JOIN files f ON f.chat_item_id = i.chat_item_id

4
src/Simplex/Chat/Store/Migrations.hs
View File

@ -84,6 +84,7 @@ import Simplex.Chat.Migrations.M20230914_member_probes
import Simplex.Chat.Migrations.M20230926_contact_status import Simplex.Chat.Migrations.M20230926_contact_status
import Simplex.Chat.Migrations.M20231002_conn_initiated import Simplex.Chat.Migrations.M20231002_conn_initiated
import Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash import Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash
import Simplex.Chat.Migrations.M20231010_member_settings
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations :: [(String, Query, Maybe Query)]
@ -167,7 +168,8 @@ schemaMigrations =
("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes), ("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes),
("20230926_contact_status", m20230926_contact_status, Just down_m20230926_contact_status), ("20230926_contact_status", m20230926_contact_status, Just down_m20230926_contact_status),
("20231002_conn_initiated", m20231002_conn_initiated, Just down_m20231002_conn_initiated), ("20231002_conn_initiated", m20231002_conn_initiated, Just down_m20231002_conn_initiated),
("20231009_via_group_link_uri_hash", m20231009_via_group_link_uri_hash, Just down_m20231009_via_group_link_uri_hash) ("20231009_via_group_link_uri_hash", m20231009_via_group_link_uri_hash, Just down_m20231009_via_group_link_uri_hash),
("20231010_member_settings", m20231010_member_settings, Just down_m20231010_member_settings)
] ]
-- | The list of migrations in ascending order by date -- | The list of migrations in ascending order by date

6
src/Simplex/Chat/Store/Shared.hs
View File

@ -240,20 +240,20 @@ deleteUnusedIncognitoProfileById_ db User {userId} profileId =
|] |]
[":user_id" := userId, ":profile_id" := profileId] [":user_id" := userId, ":profile_id" := profileId]
type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe Bool, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool) type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)
toContact :: User -> ContactRow :. ConnectionRow -> Contact toContact :: User -> ContactRow :. ConnectionRow -> Contact
toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) = toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
activeConn = toConnection connRow activeConn = toConnection connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent} in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent}
toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact
toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) = toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
in case toMaybeConnection connRow of in case toMaybeConnection connRow of
Just activeConn -> Just activeConn ->
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn

36
src/Simplex/Chat/Terminal/Output.hs
View File

@ -18,7 +18,7 @@ import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone) import Data.Time.LocalTime (getCurrentTimeZone)
import Simplex.Chat (processChatCommand, chatNtf, contactNtf, groupNtf, userNtf) import Simplex.Chat (processChatCommand)
import Simplex.Chat.Controller import Simplex.Chat.Controller
import Simplex.Chat.Markdown import Simplex.Chat.Markdown
import Simplex.Chat.Messages import Simplex.Chat.Messages
@ -27,7 +27,7 @@ import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText) import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Styled import Simplex.Chat.Styled
import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications) import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications)
import Simplex.Chat.Types (Contact, GroupInfo (..), User (..), UserContactRequest (..)) import Simplex.Chat.Types
import Simplex.Chat.View import Simplex.Chat.View
import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
@ -139,8 +139,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
forever $ do forever $ do
(_, r) <- atomically $ readTBQueue outputQ (_, r) <- atomically $ readTBQueue outputQ
case r of case r of
CRNewChatItem _ ci -> markChatItemRead ci CRNewChatItem u ci -> markChatItemRead u ci
CRChatItemUpdated _ ci -> markChatItemRead ci CRChatItemUpdated u ci -> markChatItemRead u ci
_ -> pure () _ -> pure ()
let printResp = case logFilePath of let printResp = case logFilePath of
Just path -> if logResponseToFile r then logResponse path else printToTerminal ct Just path -> if logResponseToFile r then logResponse path else printToTerminal ct
@ -149,10 +149,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
responseString cc liveItems r >>= printResp responseString cc liveItems r >>= printResp
responseNotification ct cc r responseNotification ct cc r
where where
markChatItemRead (AChatItem _ _ chat item@ChatItem {chatDir, meta = CIMeta {itemStatus}}) = markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (muted chat chatDir, itemStatus) of case (chatDirNtf u chat chatDir (isMention ci), itemStatus) of
(False, CISRcvNew) -> do (True, CISRcvNew) -> do
let itemId = chatItemId' item let itemId = chatItemId' ci
chatRef = chatInfoToRef chat chatRef = chatInfoToRef chat
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
_ -> pure () _ -> pure ()
@ -160,8 +160,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO () responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
responseNotification t@ChatTerminal {sendNotification} cc = \case responseNotification t@ChatTerminal {sendNotification} cc = \case
CRNewChatItem u (AChatItem _ SMDRcv cInfo ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) -> CRNewChatItem u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) ->
when (chatNtf u cInfo) $ do when (chatDirNtf u cInfo chatDir $ isMention ci) $ do
whenCurrUser cc u $ setActiveChat t cInfo whenCurrUser cc u $ setActiveChat t cInfo
case (cInfo, chatDir) of case (cInfo, chatDir) of
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text) (DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
@ -169,26 +169,26 @@ responseNotification t@ChatTerminal {sendNotification} cc = \case
_ -> pure () _ -> pure ()
where where
text = msgText mc formattedText text = msgText mc formattedText
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ChatItem {content = CIRcvMsgContent _}) -> CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent _}) ->
whenCurrUser cc u $ when (chatNtf u cInfo) $ setActiveChat t cInfo whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isMention ci) $ setActiveChat t cInfo
CRContactConnected u ct _ -> when (contactNtf u ct) $ do CRContactConnected u ct _ -> when (contactNtf u ct False) $ do
whenCurrUser cc u $ setActiveContact t ct whenCurrUser cc u $ setActiveContact t ct
sendNtf (viewContactName ct <> "> ", "connected") sendNtf (viewContactName ct <> "> ", "connected")
CRContactAnotherClient u ct -> do CRContactAnotherClient u ct -> do
whenCurrUser cc u $ unsetActiveContact t ct whenCurrUser cc u $ unsetActiveContact t ct
when (contactNtf u ct) $ sendNtf (viewContactName ct <> "> ", "connected to another client") when (contactNtf u ct False) $ sendNtf (viewContactName ct <> "> ", "connected to another client")
CRContactsDisconnected srv _ -> serverNtf srv "disconnected" CRContactsDisconnected srv _ -> serverNtf srv "disconnected"
CRContactsSubscribed srv _ -> serverNtf srv "connected" CRContactsSubscribed srv _ -> serverNtf srv "connected"
CRReceivedGroupInvitation u g ct _ _ -> CRReceivedGroupInvitation u g ct _ _ ->
when (contactNtf u ct) $ when (contactNtf u ct False) $
sendNtf ("#" <> viewGroupName g <> " " <> viewContactName ct <> "> ", "invited you to join the group") sendNtf ("#" <> viewGroupName g <> " " <> viewContactName ct <> "> ", "invited you to join the group")
CRUserJoinedGroup u g _ -> when (groupNtf u g) $ do CRUserJoinedGroup u g _ -> when (groupNtf u g False) $ do
whenCurrUser cc u $ setActiveGroup t g whenCurrUser cc u $ setActiveGroup t g
sendNtf ("#" <> viewGroupName g, "you are connected to group") sendNtf ("#" <> viewGroupName g, "you are connected to group")
CRJoinedGroupMember u g m -> CRJoinedGroupMember u g m ->
when (groupNtf u g) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected") when (groupNtf u g False) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
CRConnectedToGroupMember u g m _ -> CRConnectedToGroupMember u g m _ ->
when (groupNtf u g) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected") when (groupNtf u g False) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
CRReceivedContactRequest u UserContactRequest {localDisplayName = n} -> CRReceivedContactRequest u UserContactRequest {localDisplayName = n} ->
when (userNtf u) $ sendNtf (viewName n <> ">", "wants to connect to you") when (userNtf u) $ sendNtf (viewName n <> ">", "wants to connect to you")
_ -> pure () _ -> pure ()

62
src/Simplex/Chat/Types.hs
View File

@ -35,7 +35,11 @@ import Data.Maybe (isJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Database.SQLite.Simple.FromField (FromField (..)) import Data.Typeable (Typeable)
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (returnError, FromField(..))
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.ToField (ToField (..)) import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Preferences
@ -44,7 +48,7 @@ import Simplex.FileTransfer.Description (FileDigest)
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON, enumJSON)
import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI)
import Simplex.Messaging.Util ((<$?>)) import Simplex.Messaging.Util ((<$?>))
import Simplex.Messaging.Version import Simplex.Messaging.Version
@ -383,7 +387,7 @@ contactAndGroupIds = \case
-- TODO when more settings are added we should create another type to allow partial setting updates (with all Maybe properties) -- TODO when more settings are added we should create another type to allow partial setting updates (with all Maybe properties)
data ChatSettings = ChatSettings data ChatSettings = ChatSettings
{ enableNtfs :: Bool, { enableNtfs :: MsgFilter,
sendRcpts :: Maybe Bool, sendRcpts :: Maybe Bool,
favorite :: Bool favorite :: Bool
} }
@ -394,13 +398,48 @@ instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOpt
defaultChatSettings :: ChatSettings defaultChatSettings :: ChatSettings
defaultChatSettings = defaultChatSettings =
ChatSettings ChatSettings
{ enableNtfs = True, { enableNtfs = MFAll,
sendRcpts = Nothing, sendRcpts = Nothing,
favorite = False favorite = False
} }
pattern DisableNtfs :: ChatSettings chatHasNtfs :: ChatSettings -> Bool
pattern DisableNtfs <- ChatSettings {enableNtfs = False} chatHasNtfs ChatSettings {enableNtfs} = enableNtfs /= MFNone
data MsgFilter = MFNone | MFAll | MFMentions
deriving (Eq, Show, Generic)
instance FromJSON MsgFilter where
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MF"
instance ToJSON MsgFilter where
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MF"
toJSON = J.genericToJSON . enumJSON $ dropPrefix "MF"
instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP
instance ToField MsgFilter where toField = toField . msgFilterInt
msgFilterInt :: MsgFilter -> Int
msgFilterInt = \case
MFNone -> 0
MFAll -> 1
MFMentions -> 2
msgFilterIntP :: Int64 -> Maybe MsgFilter
msgFilterIntP = \case
0 -> Just MFNone
1 -> Just MFAll
2 -> Just MFMentions
_ -> Just MFAll
fromIntField_ :: Typeable a => (Int64 -> Maybe a) -> Field -> Ok a
fromIntField_ fromInt = \case
f@(Field (SQLInteger i) _) ->
case fromInt i of
Just x -> Ok x
_ -> returnError ConversionFailed f ("invalid integer: " <> show i)
f -> returnError ConversionFailed f "expecting SQLInteger column type"
featureAllowed :: SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool featureAllowed :: SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
featureAllowed feature forWhom Contact {mergedPreferences} = featureAllowed feature forWhom Contact {mergedPreferences} =
@ -628,6 +667,7 @@ data GroupMember = GroupMember
memberRole :: GroupMemberRole, memberRole :: GroupMemberRole,
memberCategory :: GroupMemberCategory, memberCategory :: GroupMemberCategory,
memberStatus :: GroupMemberStatus, memberStatus :: GroupMemberStatus,
memberSettings :: GroupMemberSettings,
invitedBy :: InvitedBy, invitedBy :: InvitedBy,
localDisplayName :: ContactName, localDisplayName :: ContactName,
-- for membership, memberProfile can be either user's profile or incognito profile, based on memberIncognito test. -- for membership, memberProfile can be either user's profile or incognito profile, based on memberIncognito test.
@ -762,6 +802,16 @@ instance ToJSON GroupMemberRole where
toJSON = strToJSON toJSON = strToJSON
toEncoding = strToJEncoding toEncoding = strToJEncoding
data GroupMemberSettings = GroupMemberSettings
{ showMessages :: Bool
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON GroupMemberSettings where toEncoding = J.genericToEncoding J.defaultOptions
defaultMemberSettings :: GroupMemberSettings
defaultMemberSettings = GroupMemberSettings {showMessages = True}
newtype Probe = Probe {unProbe :: ByteString} newtype Probe = Probe {unProbe :: ByteString}
deriving (Eq, Show) deriving (Eq, Show)

121
src/Simplex/Chat/View.hs
View File

@ -101,15 +101,15 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code] CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code]
CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewChatItem chat item False ts tz <> viewItemReactions item CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item
CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId] CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
CRChatItemStatusUpdated u ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts CRChatItemStatusUpdated u ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewItemUpdate chat item liveItems ts tz CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz
CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci
CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView
CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction chat reaction $ viewItemReaction showReactions chat reaction added ts tz CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u chat reaction $ viewItemReaction showReactions chat reaction added ts tz
CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"] CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"]
CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t
CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr
@ -348,24 +348,56 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)] viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
contactList :: [ContactRef] -> String contactList :: [ContactRef] -> String
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
unmuted :: ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString] unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted chat ChatItem {chatDir} = unmuted' chat chatDir unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isMention ci
unmutedReaction :: ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString] unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
unmutedReaction chat CIReaction {chatDir} = unmuted' chat chatDir unmutedReaction u chat CIReaction {chatDir} = unmuted' u chat chatDir False
unmuted' :: ChatInfo c -> CIDirection c d -> [StyledString] -> [StyledString] unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString]
unmuted' chat chatDir s unmuted' u chat chatDir mention s
| muted chat chatDir = [] | chatDirNtf u chat chatDir mention = s
| otherwise = s | otherwise = []
userNtf :: User -> Bool
userNtf User {showNtfs, activeUser} = showNtfs || activeUser
chatNtf :: User -> ChatInfo c -> Bool -> Bool
chatNtf user cInfo mention = case cInfo of
DirectChat ct -> contactNtf user ct mention
GroupChat g -> groupNtf user g mention
_ -> False
chatDirNtf :: User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
chatDirNtf user cInfo chatDir mention = case (cInfo, chatDir) of
(DirectChat ct, CIDirectRcv) -> contactNtf user ct mention
(GroupChat g, CIGroupRcv m) -> groupNtf user g mention && showMessages (memberSettings m)
_ -> True
contactNtf :: User -> Contact -> Bool -> Bool
contactNtf user Contact {chatSettings} mention =
userNtf user && showMessageNtf chatSettings mention
groupNtf :: User -> GroupInfo -> Bool -> Bool
groupNtf user GroupInfo {chatSettings} mention =
userNtf user && showMessageNtf chatSettings mention
showMessageNtf :: ChatSettings -> Bool -> Bool
showMessageNtf ChatSettings {enableNtfs} mention =
enableNtfs == MFAll || (mention && enableNtfs == MFMentions)
chatItemDeletedText :: ChatItem c d -> Maybe GroupMember -> Maybe Text chatItemDeletedText :: ChatItem c d -> Maybe GroupMember -> Maybe Text
chatItemDeletedText ci membership_ = deletedStateToText <$> chatItemDeletedState ci chatItemDeletedText ChatItem {meta = CIMeta {itemDeleted}, content} membership_ =
deletedText <$> itemDeleted
where where
deletedStateToText = \CIDeletedState {markedDeleted, deletedByMember} -> deletedText = \case
if markedDeleted CIModerated _ m -> markedDeleted content <> byMember m
then "marked deleted" <> byMember deletedByMember CIDeleted _ -> markedDeleted content
else "deleted" <> byMember deletedByMember CIBlocked _ -> "blocked"
byMember m_ = case (m_, membership_) of markedDeleted = \case
(Just GroupMember {groupMemberId = mId, localDisplayName = n}, Just GroupMember {groupMemberId = membershipId}) -> CISndModerated -> "deleted"
CIRcvModerated -> "deleted"
_ -> "marked deleted"
byMember GroupMember {groupMemberId = mId, localDisplayName = n} = case membership_ of
Just GroupMember {groupMemberId = membershipId} ->
" by " <> if mId == membershipId then "you" else n " by " <> if mId == membershipId then "you" else n
_ -> "" _ -> ""
@ -384,12 +416,6 @@ viewUsersList = mapMaybe userInfo . sortOn ldn
<> ["muted" | not showNtfs] <> ["muted" | not showNtfs]
<> [plain ("unread: " <> show count) | count /= 0] <> [plain ("unread: " <> show count) | count /= 0]
muted :: ChatInfo c -> CIDirection c d -> Bool
muted chat chatDir = case (chat, chatDir) of
(DirectChat Contact {chatSettings = DisableNtfs}, CIDirectRcv) -> True
(GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _) -> True
_ -> False
viewGroupSubscribed :: GroupInfo -> [StyledString] viewGroupSubscribed :: GroupInfo -> [StyledString]
viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"] viewGroupSubscribed g = [membershipIncognito g <> ttyFullGroup g <> ": connected to server(s)"]
@ -689,7 +715,7 @@ viewContactsList =
in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn in map (\ct -> ctIncognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
where where
muted' Contact {chatSettings, localDisplayName = ldn} muted' Contact {chatSettings, localDisplayName = ldn}
| enableNtfs chatSettings = "" | chatHasNtfs chatSettings = ""
| otherwise = " (muted, you can " <> highlight ("/unmute @" <> ldn) <> ")" | otherwise = " (muted, you can " <> highlight ("/unmute @" <> ldn) <> ")"
alias Contact {profile = LocalProfile {localAlias}} alias Contact {profile = LocalProfile {localAlias}}
| localAlias == "" = "" | localAlias == "" = ""
@ -822,21 +848,25 @@ viewGroupMembers :: Group -> [StyledString]
viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members
where where
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
groupMember m = memIncognito m <> ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m groupMember m = memIncognito m <> ttyFullMember m <> ": " <> plain (intercalate ", " $ [role m] <> category m <> status m <> muted m)
role m = plain . strEncode $ memberRole (m :: GroupMember) role :: GroupMember -> String
role m = B.unpack . strEncode $ memberRole (m :: GroupMember)
category m = case memberCategory m of category m = case memberCategory m of
GCUserMember -> "you, " GCUserMember -> ["you"]
GCInviteeMember -> "invited, " GCInviteeMember -> ["invited"]
GCHostMember -> "host, " GCHostMember -> ["host"]
_ -> "" _ -> []
status m = case memberStatus m of status m = case memberStatus m of
GSMemRemoved -> "removed" GSMemRemoved -> ["removed"]
GSMemLeft -> "left" GSMemLeft -> ["left"]
GSMemInvited -> "not yet joined" GSMemInvited -> ["not yet joined"]
GSMemConnected -> "connected" GSMemConnected -> ["connected"]
GSMemComplete -> "connected" GSMemComplete -> ["connected"]
GSMemCreator -> "created group" GSMemCreator -> ["created group"]
_ -> "" _ -> []
muted m
| showMessages (memberSettings m) = []
| otherwise = ["blocked"]
viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString] viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString]
viewContactConnected ct userIncognitoProfile testView = viewContactConnected ct userIncognitoProfile testView =
@ -857,8 +887,9 @@ viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString]
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"] viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
viewGroupsList gs = map groupSS $ sortOn ldn_ gs viewGroupsList gs = map groupSS $ sortOn ldn_ gs
where where
ldn_ :: GroupInfo -> Text
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) . fst ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName) . fst
groupSS (g@GroupInfo {membership, chatSettings}, GroupSummary {currentMembers}) = groupSS (g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}}, GroupSummary {currentMembers}) =
case memberStatus membership of case memberStatus membership of
GSMemInvited -> groupInvitation' g GSMemInvited -> groupInvitation' g
s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s
@ -867,9 +898,13 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs
GSMemRemoved -> delete "you are removed" GSMemRemoved -> delete "you are removed"
GSMemLeft -> delete "you left" GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted" GSMemGroupDeleted -> delete "group deleted"
_ _ -> " (" <> memberCount <>
| enableNtfs chatSettings -> " (" <> memberCount <> ")" case enableNtfs of
| otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")" MFAll -> ")"
MFNone -> ", muted, " <> unmute
MFMentions -> ", mentions only, " <> unmute
where
unmute = "you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")" delete reason = " (" <> reason <> ", delete local copy: " <> highlight ("/d #" <> viewGroupName g) <> ")"
memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s" memberCount = sShow currentMembers <> " member" <> if currentMembers == 1 then "" else "s"

2
tests/ChatClient.hs
View File

@ -207,6 +207,8 @@ withTestChatOpts tmp = withTestChatCfgOpts tmp testCfg
withTestChatCfgOpts :: HasCallStack => FilePath -> ChatConfig -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a withTestChatCfgOpts :: HasCallStack => FilePath -> ChatConfig -> ChatOpts -> String -> (HasCallStack => TestCC -> IO a) -> IO a
withTestChatCfgOpts tmp cfg opts dbPrefix = bracket (startTestChat tmp cfg opts dbPrefix) (\cc -> cc <// 100000 >> stopTestChat cc) withTestChatCfgOpts tmp cfg opts dbPrefix = bracket (startTestChat tmp cfg opts dbPrefix) (\cc -> cc <// 100000 >> stopTestChat cc)
-- enable output for specific chat controller, use like this:
-- withNewTestChat tmp "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do ...
withTestOutput :: HasCallStack => TestCC -> (HasCallStack => TestCC -> IO a) -> IO a withTestOutput :: HasCallStack => TestCC -> (HasCallStack => TestCC -> IO a) -> IO a
withTestOutput cc runTest = runTest cc {printOutput = True} withTestOutput cc runTest = runTest cc {printOutput = True}

71
tests/ChatTests/Direct.hs
View File

@ -70,7 +70,7 @@ chatDirectTests = do
it "should not subscribe in NSE and subscribe in the app" testSubscribeAppNSE it "should not subscribe in NSE and subscribe in the app" testSubscribeAppNSE
describe "mute/unmute messages" $ do describe "mute/unmute messages" $ do
it "mute/unmute contact" testMuteContact it "mute/unmute contact" testMuteContact
it "mute/unmute group" testMuteGroup it "mute/unmute group and member" testMuteGroup
describe "multiple users" $ do describe "multiple users" $ do
it "create second user" testCreateSecondUser it "create second user" testCreateSecondUser
it "multiple users subscribe and receive messages after restart" testUsersSubscribeAfterRestart it "multiple users subscribe and receive messages after restart" testUsersSubscribeAfterRestart
@ -1196,14 +1196,79 @@ testMuteGroup =
concurrently_ concurrently_
(bob </) (bob </)
(cath <# "#team alice> hi") (cath <# "#team alice> hi")
bob #> "#team hello"
concurrently_
(alice <# "#team bob> hello")
(cath <# "#team bob> hello")
cath `send` "> #team (hello) hello too!"
cath <# "#team > bob hello"
cath <## " hello too!"
concurrently_
(bob </)
( do alice <# "#team cath> > bob hello"
alice <## " hello too!"
)
bob ##> "/unmute mentions #team"
bob <## "ok"
alice `send` "> #team @bob (hello) hey bob!"
alice <# "#team > bob hello"
alice <## " hey bob!"
concurrently_
( do bob <# "#team alice> > bob hello"
bob <## " hey bob!"
)
( do cath <# "#team alice> > bob hello"
cath <## " hey bob!"
)
alice `send` "> #team @cath (hello) hey cath!"
alice <# "#team > cath hello too!"
alice <## " hey cath!"
concurrently_
(bob </)
( do cath <# "#team alice> > cath hello too!"
cath <## " hey cath!"
)
bob ##> "/gs" bob ##> "/gs"
bob <## "#team (3 members, muted, you can /unmute #team)" bob <## "#team (3 members, mentions only, you can /unmute #team)"
bob ##> "/unmute #team" bob ##> "/unmute #team"
bob <## "ok" bob <## "ok"
alice #> "#team hi again" alice #> "#team hi again"
concurrently_ concurrently_
(bob <# "#team alice> hi again") (bob <# "#team alice> hi again")
(cath <# "#team alice> hi again") (cath <# "#team alice> hi again")
bob ##> "/block #team alice"
bob <## "ok"
bob ##> "/ms team"
bob <## "bob (Bob): admin, you, connected"
bob <## "alice (Alice): owner, host, connected, blocked"
bob <## "cath (Catherine): admin, connected"
alice #> "#team test 1"
concurrently_
(bob </)
(cath <# "#team alice> test 1")
cath #> "#team test 2"
concurrently_
(bob <# "#team cath> test 2")
(alice <# "#team cath> test 2")
bob ##> "/tail #team 3"
bob <# "#team alice> hi again"
bob <# "#team alice> test 1 [blocked]"
bob <# "#team cath> test 2"
threadDelay 1000000
bob ##> "/unblock #team alice"
bob <## "ok"
bob ##> "/ms team"
bob <## "bob (Bob): admin, you, connected"
bob <## "alice (Alice): owner, host, connected"
bob <## "cath (Catherine): admin, connected"
alice #> "#team test 3"
concurrently_
(bob <# "#team alice> test 3")
(cath <# "#team alice> test 3")
cath #> "#team test 4"
concurrently_
(bob <# "#team cath> test 4")
(alice <# "#team cath> test 4")
bob ##> "/gs" bob ##> "/gs"
bob <## "#team (3 members)" bob <## "#team (3 members)"
@ -1937,7 +2002,7 @@ testUserPrivacy =
-- shows hidden user when active -- shows hidden user when active
alice ##> "/users" alice ##> "/users"
alice <## "alice (Alice)" alice <## "alice (Alice)"
alice <## "alisa (active, hidden, muted)" alice <## "alisa (active, hidden, muted, unread: 1)"
-- hidden message is saved -- hidden message is saved
alice ##> "/tail" alice ##> "/tail"
alice <##? chatHistory alice <##? chatHistory

11
tests/ChatTests/Groups.hs
View File

@ -1538,7 +1538,6 @@ testGroupDelayedModerationFullDelete tmp = do
testGroupAsync :: HasCallStack => FilePath -> IO () testGroupAsync :: HasCallStack => FilePath -> IO ()
testGroupAsync tmp = do testGroupAsync tmp = do
print (0 :: Integer)
withNewTestChat tmp "alice" aliceProfile $ \alice -> do withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \bob -> do
connectUsers alice bob connectUsers alice bob
@ -3252,9 +3251,9 @@ testMemberContactProhibitedRepeatInv =
testMemberContactInvitedConnectionReplaced :: HasCallStack => FilePath -> IO () testMemberContactInvitedConnectionReplaced :: HasCallStack => FilePath -> IO ()
testMemberContactInvitedConnectionReplaced tmp = do testMemberContactInvitedConnectionReplaced tmp = do
withNewTestChat tmp "alice" aliceProfile $ \alice -> do withNewTestChat tmp "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do withNewTestChat tmp "bob" bobProfile $ \b -> withTestOutput b $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do withNewTestChat tmp "cath" cathProfile $ \c -> withTestOutput c $ \cath -> do
createGroup3 "team" alice bob cath createGroup3 "team" alice bob cath
alice ##> "/d bob" alice ##> "/d bob"
@ -3277,7 +3276,9 @@ testMemberContactInvitedConnectionReplaced tmp = do
(alice <## "bob (Bob): contact is connected") (alice <## "bob (Bob): contact is connected")
(bob <## "alice (Alice): contact is connected") (bob <## "alice (Alice): contact is connected")
bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "received invitation to join group team as admin"), (0, "contact deleted"), (0, "hi"), (0, "security code changed")] <> chatFeatures) bob ##> "/_get chat @2 count=100"
items <- chat <$> getTermLine bob
items `shouldContain` [(0, "received invitation to join group team as admin"), (0, "contact deleted"), (0, "hi"), (0, "security code changed")]
withTestChat tmp "bob" $ \bob -> do withTestChat tmp "bob" $ \bob -> do
subscriptions bob 1 subscriptions bob 1