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

Merge branch 'master' into master-ghc8107

Browse Source
This commit is contained in:
Evgeny Poberezkin 2023-10-11 21:27:21 +01:00
commit effc281271
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.M20231002_conn_initiated
Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash
Simplex.Chat.Migrations.M20231010_member_settings
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared

132
src/Simplex/Chat.hs
View File

@ -794,7 +794,7 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of
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
(CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
@ -806,7 +806,7 @@ processChatCommand = \case
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do
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
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
@ -818,7 +818,7 @@ processChatCommand = \case
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
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
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete
@ -1170,7 +1170,7 @@ processChatCommand = \case
ct <- getContact db user chatId
liftIO $ updateContactSettings db user chatId chatSettings
pure ct
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (enableNtfs chatSettings)
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (chatHasNtfs chatSettings)
ok user
CTGroup -> do
ms <- withStore $ \db -> do
@ -1178,9 +1178,17 @@ processChatCommand = \case
liftIO $ updateGroupSettings db user chatId chatSettings
pure ms
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
_ -> 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
-- [incognito] print user's incognito profile for this contact
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId
@ -1275,6 +1283,11 @@ processChatCommand = \case
_ -> throwChatError CEGroupMemberNotActive
SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn})
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
ShowGroupInfo gName -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName
@ -2065,7 +2078,7 @@ processChatCommand = \case
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
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
deletedTs <- liftIO getCurrentTime
if groupFeatureAllowed SGFFullDelete gInfo
@ -2805,10 +2818,10 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
waitChatStarted
case cType of
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
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
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
_ -> 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
-- possible improvement: check for each pending message, requires keeping track of connection state
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
GCHostMember -> do
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)
where
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
SMDRcv ->
if featureAllowed SCFFullDelete forContact ct
@ -4004,21 +4017,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
createItem timed_ live
| groupFeatureAllowed SGFFullDelete gInfo = do
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
toView $ CRNewChatItem user ci'
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci'
| otherwise = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
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 cr
toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt
createItem timed_ live = do
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
autoAcceptFile file_
when (showMessages $ memberSettings m) $ autoAcceptFile file_
newChatItem ciContent ciFile_ timed_ live = do
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_
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 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' <- withStore' $ \db -> do
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')
where
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
let msgMemberId = fromMaybe memberId sndMemberId_
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
| sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView
| 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
| otherwise -> withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
where
deleteMsg :: GroupMember -> CChatItem 'CTGroup -> m ()
deleteMsg :: MsgDirectionI d => GroupMember -> ChatItem 'CTGroup d -> m ()
deleteMsg mem ci = case sndMemberId_ of
Just sndMemberId
| 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 =
messageError "x.msg.del: message of another member with insufficient member permissions"
| otherwise = a
delete :: MsgDirectionI d => ChatItem 'CTGroup d -> Maybe GroupMember -> m ChatResponse
delete ci byGroupMember
| groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCI user gInfo ci False 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
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
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 {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
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
GCHostMember -> do
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
_ -> messageError "x.grp.mem.intro can be only sent by host member"
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 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"
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
members <- withStore' $ \db -> getGroupMembers db user gInfo
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
dm <- directMessage $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode
groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr dm subMode
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
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
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 user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do
deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse
deleteDirectCI user ct ci@ChatItem {file} byUser timed = do
deleteCIFile user file
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 user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed byGroupMember_ deletedTs = do
deleteGroupCI :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedTs = do
deleteCIFile user file
toCi <- withStoreCtx' (Just "deleteGroupCI, deleteGroupChatItem ...") $ \db ->
case byGroupMember_ of
Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing
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 user file_ =
@ -5227,25 +5250,21 @@ deleteCIFile user file_ =
fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
deleteAgentConnectionsAsync user fileAgentConnIds
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse
markDirectCIDeleted user ct@Contact {contactId} ci@(CChatItem _ ChatItem {file}) msgId byUser deletedTs = do
markDirectCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> MessageId -> Bool -> UTCTime -> m ChatResponse
markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do
cancelCIFile user file
toCi <- withStore $ \db -> do
liftIO $ markDirectChatItemDeleted db user ct ci msgId deletedTs
getDirectChatItem db user contactId (cchatItemId ci)
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem toCi) byUser False
ci' <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId deletedTs
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem ci') byUser False
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 user gInfo@GroupInfo {groupId} ci@(CChatItem _ ChatItem {file}) msgId byUser byGroupMember_ deletedTs = do
markGroupCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
markGroupCIDeleted user gInfo ci@ChatItem {file} msgId byUser byGroupMember_ deletedTs = do
cancelCIFile user file
toCi <- withStore $ \db -> do
liftIO $ markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
getGroupChatItem db user groupId (cchatItemId ci)
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem toCi) byUser False
ci' <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem ci') byUser False
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 user file_ =
@ -5431,21 +5450,6 @@ getCreateActiveUser st testView = do
getWithPrompt :: String -> IO String
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' action =
asks currentUser
@ -5483,9 +5487,12 @@ withAgent action =
chatCommandP :: Parser ChatCommand
chatCommandP =
choice
[ "/mute " *> ((`SetShowMessages` False) <$> chatNameP),
"/unmute " *> ((`SetShowMessages` True) <$> chatNameP),
[ "/mute " *> ((`SetShowMessages` MFNone) <$> chatNameP),
"/unmute " *> ((`SetShowMessages` MFAll) <$> chatNameP),
"/unmute mentions " *> ((`SetShowMessages` MFMentions) <$> chatNameP),
"/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 <$> newUserP),
"/users" $> ListUsers,
@ -5589,6 +5596,7 @@ chatCommandP =
("/network" <|> "/net") $> APIGetNetworkConfig,
"/reconnect" $> ReconnectAllServers,
"/_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 #" *> (APIGroupInfo <$> A.decimal),
"/_info @" *> (APIContactInfo <$> A.decimal),

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

@ -288,6 +288,7 @@ data ChatCommand
| APIGetNetworkConfig
| ReconnectAllServers
| APISetChatSettings ChatRef ChatSettings
| APISetMemberSettings GroupId GroupMemberId GroupMemberSettings
| APIContactInfo ContactId
| APIGroupInfo GroupId
| APIGroupMemberInfo GroupId GroupMemberId
@ -303,8 +304,9 @@ data ChatCommand
| APIVerifyGroupMember GroupId GroupMemberId (Maybe Text)
| APIEnableContact ContactId
| APIEnableGroupMember GroupId GroupMemberId
| SetShowMessages ChatName Bool
| SetShowMessages ChatName MsgFilter
| SetSendReceipts ChatName (Maybe Bool)
| SetShowMemberMessages GroupName ContactName Bool
| ContactInfo ContactName
| ShowGroupInfo GroupName
| 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}
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
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
@ -217,26 +230,6 @@ ciReactionAllowed :: ChatItem c d -> Bool
ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False
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
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
@ -926,6 +919,7 @@ checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of
data CIDeleted (c :: ChatType) where
CIDeleted :: Maybe UTCTime -> CIDeleted c
CIBlocked :: Maybe UTCTime -> CIDeleted c
CIModerated :: Maybe UTCTime -> GroupMember -> CIDeleted 'CTGroup
deriving instance Show (CIDeleted c)
@ -936,6 +930,7 @@ instance ToJSON (CIDeleted d) where
data JSONCIDeleted
= JCIDDeleted {deletedTs :: Maybe UTCTime}
| JCIBlocked {deletedTs :: Maybe UTCTime}
| JCIDModerated {deletedTs :: Maybe UTCTime, byGroupMember :: GroupMember}
deriving (Show, Generic)
@ -946,11 +941,13 @@ instance ToJSON JSONCIDeleted where
jsonCIDeleted :: CIDeleted d -> JSONCIDeleted
jsonCIDeleted = \case
CIDeleted ts -> JCIDDeleted ts
CIBlocked ts -> JCIBlocked ts
CIModerated ts m -> JCIDModerated ts m
itemDeletedTs :: CIDeleted d -> Maybe UTCTime
itemDeletedTs = \case
CIDeleted ts -> ts
CIBlocked ts -> ts
CIModerated ts _ -> ts
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.Encoding (decodeLatin1, encodeUtf8)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (Field, FromField (..), returnError)
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Chat.Protocol
@ -50,14 +46,6 @@ instance FromField AMsgDirection where fromField = fromIntField_ $ fmap fromMsgD
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
SMDRcv :: SMsgDirection 'MDRcv
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),
updated_at TEXT CHECK(updated_at NOT 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)
REFERENCES display_names(user_id, local_display_name)
ON DELETE CASCADE

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

@ -376,6 +376,11 @@ mcExtMsgContent = \case
MCQuote _ 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}
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
|]
(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)] =
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
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"
@ -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,
-- GroupInfo {membership}
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}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- 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
FROM group_members m
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,
deleteOldProbes,
updateGroupSettings,
updateGroupMemberSettings,
getXGrpMemIntroContDirect,
getXGrpMemIntroContGroup,
getHostConnId,
@ -126,30 +127,31 @@ import Simplex.Messaging.Util (eitherToMaybe, ($>>=), (<$$>))
import Simplex.Messaging.Version
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 userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. 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
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs}
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}
memberSettings = GroupMemberSettings {showMessages}
invitedBy = toInvitedBy userContactId invitedById
activeConn = Nothing
in 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)) =
Just $ toGroupMember userContactId ((groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, 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, showMessages) :. (invitedById, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, contactPreferences))
toMaybeGroupMember _ _ = Nothing
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,
-- GroupInfo {membership}
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}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- 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,
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,
@ -295,7 +297,7 @@ createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do
insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12
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}
-- | 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
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
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)
getHostMemberId_ :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO GroupMemberId
@ -364,6 +366,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
memberRole,
memberCategory,
memberStatus,
memberSettings = defaultMemberSettings,
invitedBy,
localDisplayName,
memberProfile,
@ -488,7 +491,7 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
db
[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,
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
FROM groups g
JOIN group_profiles gp USING (group_profile_id)
@ -553,7 +556,7 @@ groupMemberQuery :: Query
groupMemberQuery =
[sql|
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,
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,
@ -660,6 +663,7 @@ createNewContactMember db gVar User {userId, userContactId} groupId Contact {con
memberRole,
memberCategory = GCInviteeMember,
memberStatus = GSMemInvited,
memberSettings = defaultMemberSettings,
invitedBy = IBUser,
localDisplayName,
memberProfile = profile,
@ -810,7 +814,8 @@ createNewMember_
|]
(groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memberContactId, memberContactProfileId, createdAt, createdAt)
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 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,
-- GroupInfo {membership}
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}}
pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences,
-- 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,
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,
@ -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,
-- GroupMember - membership
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
FROM groups g
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} =
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 User {userId} Contact {contactId} = do
fmap join . maybeFirstRow toCont $

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

@ -4,6 +4,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@ -48,6 +49,7 @@ module Simplex.Chat.Store.Messages
deleteGroupChatItem,
updateGroupChatItemModerated,
markGroupChatItemDeleted,
markGroupChatItemBlocked,
updateDirectChatItemsRead,
getDirectUnreadTimedItems,
setDirectChatItemDeleteAt,
@ -434,7 +436,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
SELECT i.chat_item_id,
-- GroupMember
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
FROM group_members m
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,
-- GroupMember - membership
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,
-- ChatStats
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,
-- Maybe GroupMember - sender
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,
-- quoted ChatItem
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
-- quoted GroupMember
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,
-- deleted by GroupMember
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
FROM groups g
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 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)
@ -1003,7 +1005,9 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
badItem = Left $ SEBadChatItem itemId
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
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
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
ciTimed :: Maybe CITimed
@ -1059,10 +1063,10 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
badItem = Left $ SEBadChatItem itemId
ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTGroup d
ciMeta content status =
let itemDeleted' =
if itemDeleted
then Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
else Nothing
let itemDeleted' = case itemDeleted of
DBCINotDeleted -> Nothing
DBCIBlocked -> Just (CIBlocked @'CTGroup deletedTs)
_ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_)
itemEdited' = fromMaybe False itemEdited
in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs createdAt updatedAt
ciTimed :: Maybe CITimed
@ -1221,8 +1225,8 @@ createChatItemVersion db itemId itemVersionTs msgContent =
|]
(itemId, toMCText msgContent, itemVersionTs)
deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO ()
deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do
deleteDirectChatItem :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> IO ()
deleteDirectChatItem db User {userId} Contact {contactId} ci = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
@ -1253,8 +1257,8 @@ deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO ()
deleteChatItemVersions_ db 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 User {userId} Contact {contactId} (CChatItem _ ci) msgId deletedTs = do
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> MessageId -> UTCTime -> IO (ChatItem 'CTDirect d)
markDirectChatItemDeleted db User {userId} Contact {contactId} ci@ChatItem {meta} msgId deletedTs = do
currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci
insertChatItemMessage_ db itemId msgId currentTs
@ -1262,10 +1266,11 @@ markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci)
db
[sql|
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 = ?
|]
(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 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))
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO ()
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupChatItem db User {userId} g@GroupInfo {groupId} ci = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
@ -1390,10 +1395,10 @@ deleteGroupChatItem db User {userId} g@GroupInfo {groupId} (CChatItem _ ci) = do
|]
(userId, groupId, itemId)
updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> UTCTime -> IO AChatItem
updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} deletedTs = do
updateGroupChatItemModerated :: forall d. MsgDirectionI d => DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d)
updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMember {groupMemberId} deletedTs = do
currentTs <- getCurrentTime
let toContent = msgDirToModeratedContent_ msgDir
let toContent = msgDirToModeratedContent_ $ msgDirection @d
toText = ciModeratedText
itemId = chatItemId' ci
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 = ?
|]
(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 ()
markGroupChatItemDeleted db User {userId} GroupInfo {groupId} (CChatItem _ ci) msgId byGroupMember_ deletedTs = do
pattern DBCINotDeleted :: Int
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
let itemId = chatItemId' ci
deletedByGroupMemberId = case byGroupMember_ of
Just GroupMember {groupMemberId} -> Just groupMemberId
_ -> Nothing
(deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m)
_ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs))
insertChatItemMessage_ db itemId msgId currentTs
DB.execute
db
[sql|
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 = ?
|]
(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 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,
-- GroupMember
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,
-- quoted ChatItem
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
-- quoted GroupMember
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,
-- deleted by GroupMember
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
FROM chat_items i
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.M20231002_conn_initiated
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 (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@ -167,7 +168,8 @@ schemaMigrations =
("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes),
("20230926_contact_status", m20230926_contact_status, Just down_m20230926_contact_status),
("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

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

@ -240,20 +240,20 @@ deleteUnusedIncognitoProfileById_ db User {userId} 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 (((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}
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
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 (((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}
chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_, sendRcpts, favorite}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
in case toMaybeConnection connRow of
Just 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 Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Simplex.Chat (processChatCommand, chatNtf, contactNtf, groupNtf, userNtf)
import Simplex.Chat (processChatCommand)
import Simplex.Chat.Controller
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
@ -27,7 +27,7 @@ import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Styled
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.Messaging.Agent.Protocol
import Simplex.Messaging.Encoding.String
@ -139,8 +139,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
forever $ do
(_, r) <- atomically $ readTBQueue outputQ
case r of
CRNewChatItem _ ci -> markChatItemRead ci
CRChatItemUpdated _ ci -> markChatItemRead ci
CRNewChatItem u ci -> markChatItemRead u ci
CRChatItemUpdated u ci -> markChatItemRead u ci
_ -> pure ()
let printResp = case logFilePath of
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
responseNotification ct cc r
where
markChatItemRead (AChatItem _ _ chat item@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (muted chat chatDir, itemStatus) of
(False, CISRcvNew) -> do
let itemId = chatItemId' item
markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (chatDirNtf u chat chatDir (isMention ci), itemStatus) of
(True, CISRcvNew) -> do
let itemId = chatItemId' ci
chatRef = chatInfoToRef chat
void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc
_ -> pure ()
@ -160,8 +160,8 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
responseNotification t@ChatTerminal {sendNotification} cc = \case
CRNewChatItem u (AChatItem _ SMDRcv cInfo ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) ->
when (chatNtf u cInfo) $ do
CRNewChatItem u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) ->
when (chatDirNtf u cInfo chatDir $ isMention ci) $ do
whenCurrUser cc u $ setActiveChat t cInfo
case (cInfo, chatDir) of
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
@ -169,26 +169,26 @@ responseNotification t@ChatTerminal {sendNotification} cc = \case
_ -> pure ()
where
text = msgText mc formattedText
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ChatItem {content = CIRcvMsgContent _}) ->
whenCurrUser cc u $ when (chatNtf u cInfo) $ setActiveChat t cInfo
CRContactConnected u ct _ -> when (contactNtf u ct) $ do
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ci@ChatItem {chatDir, content = CIRcvMsgContent _}) ->
whenCurrUser cc u $ when (chatDirNtf u cInfo chatDir $ isMention ci) $ setActiveChat t cInfo
CRContactConnected u ct _ -> when (contactNtf u ct False) $ do
whenCurrUser cc u $ setActiveContact t ct
sendNtf (viewContactName ct <> "> ", "connected")
CRContactAnotherClient u ct -> do
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"
CRContactsSubscribed srv _ -> serverNtf srv "connected"
CRReceivedGroupInvitation u g ct _ _ ->
when (contactNtf u ct) $
when (contactNtf u ct False) $
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
sendNtf ("#" <> viewGroupName g, "you are connected to group")
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 _ ->
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} ->
when (userNtf u) $ sendNtf (viewName n <> ">", "wants to connect to you")
_ -> pure ()

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

@ -35,7 +35,11 @@ import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
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 GHC.Generics (Generic)
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.Crypto.File (CryptoFileArgs (..))
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.Util ((<$?>))
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)
data ChatSettings = ChatSettings
{ enableNtfs :: Bool,
{ enableNtfs :: MsgFilter,
sendRcpts :: Maybe Bool,
favorite :: Bool
}
@ -394,13 +398,48 @@ instance ToJSON ChatSettings where toEncoding = J.genericToEncoding J.defaultOpt
defaultChatSettings :: ChatSettings
defaultChatSettings =
ChatSettings
{ enableNtfs = True,
{ enableNtfs = MFAll,
sendRcpts = Nothing,
favorite = False
}
pattern DisableNtfs :: ChatSettings
pattern DisableNtfs <- ChatSettings {enableNtfs = False}
chatHasNtfs :: ChatSettings -> Bool
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 feature forWhom Contact {mergedPreferences} =
@ -628,6 +667,7 @@ data GroupMember = GroupMember
memberRole :: GroupMemberRole,
memberCategory :: GroupMemberCategory,
memberStatus :: GroupMemberStatus,
memberSettings :: GroupMemberSettings,
invitedBy :: InvitedBy,
localDisplayName :: ContactName,
-- 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
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}
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]
CRContactCode u ct code -> ttyUser u $ viewContactCode ct 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
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
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
CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted 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
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 u chat reaction $ viewItemReaction showReactions chat reaction added ts tz
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
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)]
contactList :: [ContactRef] -> String
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
unmuted :: ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted chat ChatItem {chatDir} = unmuted' chat chatDir
unmutedReaction :: ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
unmutedReaction chat CIReaction {chatDir} = unmuted' chat chatDir
unmuted' :: ChatInfo c -> CIDirection c d -> [StyledString] -> [StyledString]
unmuted' chat chatDir s
| muted chat chatDir = []
| otherwise = s
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isMention ci
unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString]
unmutedReaction u chat CIReaction {chatDir} = unmuted' u chat chatDir False
unmuted' :: User -> ChatInfo c -> CIDirection c d -> Bool -> [StyledString] -> [StyledString]
unmuted' u chat chatDir mention s
| chatDirNtf u chat chatDir mention = 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 ci membership_ = deletedStateToText <$> chatItemDeletedState ci
chatItemDeletedText ChatItem {meta = CIMeta {itemDeleted}, content} membership_ =
deletedText <$> itemDeleted
where
deletedStateToText = \CIDeletedState {markedDeleted, deletedByMember} ->
if markedDeleted
then "marked deleted" <> byMember deletedByMember
else "deleted" <> byMember deletedByMember
byMember m_ = case (m_, membership_) of
(Just GroupMember {groupMemberId = mId, localDisplayName = n}, Just GroupMember {groupMemberId = membershipId}) ->
deletedText = \case
CIModerated _ m -> markedDeleted content <> byMember m
CIDeleted _ -> markedDeleted content
CIBlocked _ -> "blocked"
markedDeleted = \case
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
_ -> ""
@ -384,12 +416,6 @@ viewUsersList = mapMaybe userInfo . sortOn ldn
<> ["muted" | not showNtfs]
<> [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 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
where
muted' Contact {chatSettings, localDisplayName = ldn}
| enableNtfs chatSettings = ""
| chatHasNtfs chatSettings = ""
| otherwise = " (muted, you can " <> highlight ("/unmute @" <> ldn) <> ")"
alias Contact {profile = LocalProfile {localAlias}}
| localAlias == "" = ""
@ -822,21 +848,25 @@ viewGroupMembers :: Group -> [StyledString]
viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members
where
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
groupMember m = memIncognito m <> ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m
role m = plain . strEncode $ memberRole (m :: GroupMember)
groupMember m = memIncognito m <> ttyFullMember m <> ": " <> plain (intercalate ", " $ [role m] <> category m <> status m <> muted m)
role :: GroupMember -> String
role m = B.unpack . strEncode $ memberRole (m :: GroupMember)
category m = case memberCategory m of
GCUserMember -> "you, "
GCInviteeMember -> "invited, "
GCHostMember -> "host, "
_ -> ""
GCUserMember -> ["you"]
GCInviteeMember -> ["invited"]
GCHostMember -> ["host"]
_ -> []
status m = case memberStatus m of
GSMemRemoved -> "removed"
GSMemLeft -> "left"
GSMemInvited -> "not yet joined"
GSMemConnected -> "connected"
GSMemComplete -> "connected"
GSMemCreator -> "created group"
_ -> ""
GSMemRemoved -> ["removed"]
GSMemLeft -> ["left"]
GSMemInvited -> ["not yet joined"]
GSMemConnected -> ["connected"]
GSMemComplete -> ["connected"]
GSMemCreator -> ["created group"]
_ -> []
muted m
| showMessages (memberSettings m) = []
| otherwise = ["blocked"]
viewContactConnected :: Contact -> Maybe Profile -> Bool -> [StyledString]
viewContactConnected ct userIncognitoProfile testView =
@ -857,8 +887,9 @@ viewGroupsList :: [(GroupInfo, GroupSummary)] -> [StyledString]
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
viewGroupsList gs = map groupSS $ sortOn ldn_ gs
where
ldn_ :: GroupInfo -> Text
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
GSMemInvited -> groupInvitation' g
s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s
@ -867,9 +898,13 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs
GSMemRemoved -> delete "you are removed"
GSMemLeft -> delete "you left"
GSMemGroupDeleted -> delete "group deleted"
_
| enableNtfs chatSettings -> " (" <> memberCount <> ")"
| otherwise -> " (" <> memberCount <> ", muted, you can " <> highlight ("/unmute #" <> viewGroupName g) <> ")"
_ -> " (" <> memberCount <>
case enableNtfs of
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) <> ")"
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 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 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
describe "mute/unmute messages" $ do
it "mute/unmute contact" testMuteContact
it "mute/unmute group" testMuteGroup
it "mute/unmute group and member" testMuteGroup
describe "multiple users" $ do
it "create second user" testCreateSecondUser
it "multiple users subscribe and receive messages after restart" testUsersSubscribeAfterRestart
@ -1196,14 +1196,79 @@ testMuteGroup =
concurrently_
(bob </)
(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 <## "#team (3 members, muted, you can /unmute #team)"
bob <## "#team (3 members, mentions only, you can /unmute #team)"
bob ##> "/unmute #team"
bob <## "ok"
alice #> "#team hi again"
concurrently_
(bob <# "#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 <## "#team (3 members)"
@ -1937,7 +2002,7 @@ testUserPrivacy =
-- shows hidden user when active
alice ##> "/users"
alice <## "alice (Alice)"
alice <## "alisa (active, hidden, muted)"
alice <## "alisa (active, hidden, muted, unread: 1)"
-- hidden message is saved
alice ##> "/tail"
alice <##? chatHistory

11
tests/ChatTests/Groups.hs
View File

@ -1538,7 +1538,6 @@ testGroupDelayedModerationFullDelete tmp = do
testGroupAsync :: HasCallStack => FilePath -> IO ()
testGroupAsync tmp = do
print (0 :: Integer)
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
connectUsers alice bob
@ -3252,9 +3251,9 @@ testMemberContactProhibitedRepeatInv =
testMemberContactInvitedConnectionReplaced :: HasCallStack => FilePath -> IO ()
testMemberContactInvitedConnectionReplaced tmp = do
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withNewTestChat tmp "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \b -> withTestOutput b $ \bob -> do
withNewTestChat tmp "cath" cathProfile $ \c -> withTestOutput c $ \cath -> do
createGroup3 "team" alice bob cath
alice ##> "/d bob"
@ -3277,7 +3276,9 @@ testMemberContactInvitedConnectionReplaced tmp = do
(alice <## "bob (Bob): 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
subscriptions bob 1