From 5e71deaa3d9f9d6298b6bbab2fceb1045a746ab0 Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Wed, 20 Jul 2022 16:56:55 +0400 Subject: [PATCH] core: auxiliary group chat items (#821) --- src/Simplex/Chat.hs | 80 +++++--- src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Messages.hs | 61 ++++++ src/Simplex/Chat/View.hs | 46 +++-- tests/ChatTests.hs | 337 ++++++++++++++++++--------------- 5 files changed, 326 insertions(+), 200 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 1131d276ec..3822fe42a4 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -31,7 +31,7 @@ import Data.Either (fromRight) import Data.Fixed (div') import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (find, isSuffixOf, sortBy) +import Data.List (find, isSuffixOf, sortBy, sortOn) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -722,18 +722,23 @@ processChatCommand = \case Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId case find ((== memberId) . groupMemberId') members of Nothing -> throwChatError CEGroupMemberNotFound - Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do + Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do let userRole = memberRole (membership :: GroupMember) when (userRole < GRAdmin || userRole < mRole) $ throwChatError CEGroupUserRole withChatLock . procCmd $ do - when (mStatus /= GSMemInvited) . void . sendGroupMessage gInfo members $ XGrpMemDel mId + when (mStatus /= GSMemInvited) $ do + msg <- sendGroupMessage gInfo members $ XGrpMemDel mId + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId memberProfile) Nothing Nothing + toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci deleteMemberConnection m withStore' $ \db -> updateGroupMemberStatus db userId m GSMemRemoved - pure $ CRUserDeletedMember gInfo m + pure $ CRUserDeletedMember gInfo m {memberStatus = GSMemRemoved} APILeaveGroup groupId -> withUser $ \user@User {userId} -> do Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId withChatLock . procCmd $ do - void $ sendGroupMessage gInfo members XGrpLeave + msg <- sendGroupMessage gInfo members XGrpLeave + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) Nothing Nothing + toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci -- TODO delete direct connections that were unused mapM_ deleteMemberConnection members withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft @@ -1151,7 +1156,7 @@ subscribeUserConnections agentBatchSubscribe user = do where mErrors :: [(GroupMember, ChatError)] mErrors = - sortBy (comparing (\(GroupMember {localDisplayName = n}, _) -> n)) + sortOn (\(GroupMember {localDisplayName = n}, _) -> n) . filterErrors $ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs groupEvent :: ChatResponse @@ -1381,10 +1386,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage sendPendingGroupMessages m conn case memberCategory m of GCHostMember -> do - toView $ CRUserJoinedGroup gInfo {membership = membership {memberStatus = GSMemConnected}} + memberConnectedChatItem gInfo m + toView $ CRUserJoinedGroup gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} setActive $ ActiveG gName showToast ("#" <> gName) "you are connected to group" GCInviteeMember -> do + memberConnectedChatItem gInfo m toView $ CRJoinedGroupMember gInfo m {memberStatus = GSMemConnected} setActive $ ActiveG gName showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected" @@ -1415,13 +1422,13 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage XFile fInv -> processGroupFileInvitation' gInfo m fInv msg msgMeta XFileCancel sharedMsgId -> xFileCancelGroup gInfo m sharedMsgId msgMeta XFileAcptInv sharedMsgId fileConnReq fName -> xFileAcptInvGroup gInfo m sharedMsgId fileConnReq fName msgMeta - XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo + XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo msg msgMeta XGrpMemIntro memInfo -> xGrpMemIntro conn gInfo m memInfo XGrpMemInv memId introInv -> xGrpMemInv gInfo m memId introInv XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m memInfo introInv - XGrpMemDel memId -> xGrpMemDel gInfo m memId - XGrpLeave -> xGrpLeave gInfo m - XGrpDel -> xGrpDel gInfo m + XGrpMemDel memId -> xGrpMemDel gInfo m memId msg msgMeta + XGrpLeave -> xGrpLeave gInfo m msg msgMeta + XGrpDel -> xGrpDel gInfo m msg msgMeta _ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent) ackMsgDeliveryEvent conn msgMeta SENT msgId -> @@ -1571,8 +1578,19 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage cancelRcvFileTransfer user ft throwChatError $ CEFileRcvChunk err + memberConnectedChatItem :: GroupInfo -> GroupMember -> m () + memberConnectedChatItem gInfo m = do + createdAt <- liftIO getCurrentTime + let content = CIRcvGroupEvent RGEMemberConnected + cd = CDGroupRcv gInfo m + -- first ts should be broker ts but we don't have it for CON + ciId <- withStore' $ \db -> createNewChatItemNoMsg db user cd content createdAt createdAt + ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing createdAt createdAt + toView $ CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci + notifyMemberConnected :: GroupInfo -> GroupMember -> m () notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} = do + memberConnectedChatItem gInfo m toView $ CRConnectedToGroupMember gInfo m let g = groupName' gInfo setActive $ ActiveG g @@ -1925,14 +1943,16 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage -- TODO show/log error, other events in SMP confirmation _ -> pure () - xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> m () - xGrpMemNew gInfo m memInfo@(MemberInfo memId _ _) = do + xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> MsgMeta -> m () + xGrpMemNew gInfo m memInfo@(MemberInfo memId _ memberProfile) msg msgMeta = do members <- withStore' $ \db -> getGroupMembers db user gInfo unless (sameMemberId memId $ membership gInfo) $ if isMember memId gInfo members then messageError "x.grp.mem.new error: member already exists" else do - newMember <- withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced + newMember@GroupMember {groupMemberId} <- withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile) Nothing + groupMsgToView gInfo m ci msgMeta toView $ CRJoinedGroupMemberConnecting gInfo m newMember xGrpMemIntro :: Connection -> GroupInfo -> GroupMember -> MemberInfo -> m () @@ -1979,43 +1999,51 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage directConnId <- withAgent $ \a -> joinConnection a directConnReq $ directMessage msg withStore' $ \db -> createIntroToMemberContact db userId m toMember groupConnId directConnId - xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> m () - xGrpMemDel gInfo@GroupInfo {membership} m memId = do + xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> MsgMeta -> m () + xGrpMemDel gInfo@GroupInfo {membership} m memId msg msgMeta = do members <- withStore' $ \db -> getGroupMembers db user gInfo if memberId (membership :: GroupMember) == memId then do mapM_ deleteMemberConnection members withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved - toView $ CRDeletedMemberUser gInfo m + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEUserDeleted) Nothing + groupMsgToView gInfo m ci msgMeta + toView $ CRDeletedMemberUser gInfo {membership = membership {memberStatus = GSMemRemoved}} m else case find (sameMemberId memId) members of Nothing -> messageError "x.grp.mem.del with unknown member ID" - Just member -> do + Just member@GroupMember {groupMemberId, memberProfile} -> do let mRole = memberRole (m :: GroupMember) if mRole < GRAdmin || mRole < memberRole (member :: GroupMember) then messageError "x.grp.mem.del with insufficient member permissions" else do deleteMemberConnection member withStore' $ \db -> updateGroupMemberStatus db userId member GSMemRemoved - toView $ CRDeletedMember gInfo m member + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberDeleted groupMemberId memberProfile) Nothing + groupMsgToView gInfo m ci msgMeta + toView $ CRDeletedMember gInfo m member {memberStatus = GSMemRemoved} sameMemberId :: MemberId -> GroupMember -> Bool sameMemberId memId GroupMember {memberId} = memId == memberId - xGrpLeave :: GroupInfo -> GroupMember -> m () - xGrpLeave gInfo m = do + xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> MsgMeta -> m () + xGrpLeave gInfo m msg msgMeta = do deleteMemberConnection m withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft - toView $ CRLeftMember gInfo m + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEMemberLeft) Nothing + groupMsgToView gInfo m ci msgMeta + toView $ CRLeftMember gInfo m {memberStatus = GSMemLeft} - xGrpDel :: GroupInfo -> GroupMember -> m () - xGrpDel gInfo m@GroupMember {memberRole} = do + xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> MsgMeta -> m () + xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg msgMeta = do when (memberRole /= GROwner) $ throwChatError CEGroupUserRole ms <- withStore' $ \db -> do members <- getGroupMembers db user gInfo - updateGroupMemberStatus db userId (membership gInfo) GSMemGroupDeleted + updateGroupMemberStatus db userId membership GSMemGroupDeleted pure members mapM_ deleteMemberConnection ms - toView $ CRGroupDeleted gInfo m + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEMemberLeft) Nothing + groupMsgToView gInfo m ci msgMeta + toView $ CRGroupDeleted gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m parseChatMessage :: ByteString -> Either ChatError ChatMessage parseChatMessage = first (ChatError . CEInvalidChatMessage) . strDecode diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 80901ef175..1ade7cd5ef 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -260,7 +260,7 @@ data ChatResponse | CRContactSubSummary {contactSubscriptions :: [ContactSubStatus]} | CRGroupInvitation {groupInfo :: GroupInfo} | CRReceivedGroupInvitation {groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole} - | CRUserJoinedGroup {groupInfo :: GroupInfo} + | CRUserJoinedGroup {groupInfo :: GroupInfo, hostMember :: GroupMember} | CRJoinedGroupMember {groupInfo :: GroupInfo, member :: GroupMember} | CRJoinedGroupMemberConnecting {groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember} | CRConnectedToGroupMember {groupInfo :: GroupInfo, member :: GroupMember} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 299ea87928..52cebd44df 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -499,6 +499,23 @@ ciGroupInvitationToText :: CIGroupInvitation -> GroupMemberRole -> Text ciGroupInvitationToText CIGroupInvitation {groupProfile = GroupProfile {displayName, fullName}} role = "invitation to join group " <> displayName <> optionalFullName displayName fullName <> " as " <> (decodeLatin1 . strEncode $ role) +rcvGroupEventToText :: RcvGroupEvent -> Text +rcvGroupEventToText = \case + RGEMemberAdded _ p -> "added " <> memberProfileToText p + RGEMemberConnected -> "connected" + RGEMemberLeft -> "left" + RGEMemberDeleted _ p -> "removed " <> memberProfileToText p + RGEUserDeleted -> "removed you" + RGEGroupDeleted -> "deleted group" + +sndGroupEventToText :: SndGroupEvent -> Text +sndGroupEventToText = \case + SGEMemberDeleted _ p -> "removed " <> memberProfileToText p + SGEUserLeft -> "left" + +memberProfileToText :: Profile -> Text +memberProfileToText Profile {displayName, fullName} = displayName <> optionalFullName displayName fullName + -- This type is used both in API and in DB, so we use different JSON encodings for the database and for the API data CIContent (d :: MsgDirection) where CISndMsgContent :: MsgContent -> CIContent 'MDSnd @@ -510,9 +527,39 @@ data CIContent (d :: MsgDirection) where CIRcvIntegrityError :: MsgErrorType -> CIContent 'MDRcv CIRcvGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDRcv CISndGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDSnd + CIRcvGroupEvent :: RcvGroupEvent -> CIContent 'MDRcv + CISndGroupEvent :: SndGroupEvent -> CIContent 'MDSnd deriving instance Show (CIContent d) +data RcvGroupEvent + = RGEMemberAdded GroupMemberId Profile -- CRJoinedGroupMemberConnecting + | RGEMemberConnected -- CRUserJoinedGroup, CRJoinedGroupMember, CRConnectedToGroupMember + | RGEMemberLeft -- CRLeftMember + | RGEMemberDeleted GroupMemberId Profile -- CRDeletedMember + | RGEUserDeleted -- CRDeletedMemberUser + | RGEGroupDeleted -- CRGroupDeleted + deriving (Show, Generic) + +instance FromJSON RcvGroupEvent where + parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "RGE" + +instance ToJSON RcvGroupEvent where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "RGE" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "RGE" + +data SndGroupEvent + = SGEMemberDeleted GroupMemberId Profile -- CRUserDeletedMember + | SGEUserLeft -- CRLeftMemberUser + deriving (Show, Generic) + +instance FromJSON SndGroupEvent where + parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SGE" + +instance ToJSON SndGroupEvent where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "SGE" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "SGE" + data CIGroupInvitation = CIGroupInvitation { groupId :: GroupId, groupMemberId :: GroupMemberId, @@ -551,6 +598,8 @@ ciContentToText = \case CIRcvIntegrityError err -> msgIntegrityError err CIRcvGroupInvitation groupInvitation memberRole -> "received " <> ciGroupInvitationToText groupInvitation memberRole CISndGroupInvitation groupInvitation memberRole -> "sent " <> ciGroupInvitationToText groupInvitation memberRole + CIRcvGroupEvent event -> rcvGroupEventToText event + CISndGroupEvent event -> sndGroupEventToText event msgIntegrityError :: MsgErrorType -> Text msgIntegrityError = \case @@ -597,6 +646,8 @@ data JSONCIContent | JCIRcvIntegrityError {msgError :: MsgErrorType} | JCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole} | JCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole} + | JCIRcvGroupEvent {rcvGroupEvent :: RcvGroupEvent} + | JCISndGroupEvent {sndGroupEvent :: SndGroupEvent} deriving (Generic) instance FromJSON JSONCIContent where @@ -617,6 +668,8 @@ jsonCIContent = \case CIRcvIntegrityError err -> JCIRcvIntegrityError err CIRcvGroupInvitation groupInvitation memberRole -> JCIRcvGroupInvitation {groupInvitation, memberRole} CISndGroupInvitation groupInvitation memberRole -> JCISndGroupInvitation {groupInvitation, memberRole} + CIRcvGroupEvent rcvGroupEvent -> JCIRcvGroupEvent {rcvGroupEvent} + CISndGroupEvent sndGroupEvent -> JCISndGroupEvent {sndGroupEvent} aciContentJSON :: JSONCIContent -> ACIContent aciContentJSON = \case @@ -629,6 +682,8 @@ aciContentJSON = \case JCIRcvIntegrityError err -> ACIContent SMDRcv $ CIRcvIntegrityError err JCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole JCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole + JCIRcvGroupEvent {rcvGroupEvent} -> ACIContent SMDRcv $ CIRcvGroupEvent rcvGroupEvent + JCISndGroupEvent {sndGroupEvent} -> ACIContent SMDSnd $ CISndGroupEvent sndGroupEvent -- platform independent data DBJSONCIContent @@ -641,6 +696,8 @@ data DBJSONCIContent | DBJCIRcvIntegrityError {msgError :: MsgErrorType} | DBJCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole} | DBJCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole} + | DBJCIRcvGroupEvent {rcvGroupEvent :: RcvGroupEvent} + | DBJCISndGroupEvent {sndGroupEvent :: SndGroupEvent} deriving (Generic) instance FromJSON DBJSONCIContent where @@ -661,6 +718,8 @@ dbJsonCIContent = \case CIRcvIntegrityError err -> DBJCIRcvIntegrityError err CIRcvGroupInvitation groupInvitation memberRole -> DBJCIRcvGroupInvitation {groupInvitation, memberRole} CISndGroupInvitation groupInvitation memberRole -> DBJCISndGroupInvitation {groupInvitation, memberRole} + CIRcvGroupEvent rcvGroupEvent -> DBJCIRcvGroupEvent {rcvGroupEvent} + CISndGroupEvent sndGroupEvent -> DBJCISndGroupEvent {sndGroupEvent} aciContentDBJSON :: DBJSONCIContent -> ACIContent aciContentDBJSON = \case @@ -673,6 +732,8 @@ aciContentDBJSON = \case DBJCIRcvIntegrityError err -> ACIContent SMDRcv $ CIRcvIntegrityError err DBJCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole DBJCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole + DBJCIRcvGroupEvent {rcvGroupEvent} -> ACIContent SMDRcv $ CIRcvGroupEvent rcvGroupEvent + DBJCISndGroupEvent {sndGroupEvent} -> ACIContent SMDSnd $ CISndGroupEvent sndGroupEvent data CICallStatus = CISCallPending diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index c02912c848..f28e6bbe4e 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -6,7 +6,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Simplex.Chat.View where @@ -60,8 +59,8 @@ responseToView testView = \case CRApiChat chat -> if testView then testViewChat chat else [plain . bshow $ J.encode chat] CRApiParsedMarkdown ft -> [plain . bshow $ J.encode ft] CRUserSMPServers smpServers -> viewSMPServers smpServers testView - CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item - CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item) chatItems + CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item False + CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True) chatItems CRChatItemStatusUpdated _ -> [] CRChatItemUpdated (AChatItem _ _ chat item) -> viewItemUpdate chat item CRChatItemDeleted (AChatItem _ _ chat deletedItem) (AChatItem _ _ _ toItem) -> viewItemDelete chat deletedItem toItem @@ -134,7 +133,7 @@ responseToView testView = \case CRGroupInvitation GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} -> [groupInvitation' ldn fullName] CRReceivedGroupInvitation g c role -> viewReceivedGroupInvitation g c role - CRUserJoinedGroup g -> [ttyGroup' g <> ": you joined the group"] + CRUserJoinedGroup g _ -> [ttyGroup' g <> ": you joined the group"] CRJoinedGroupMember g m -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "] CRJoinedGroupMemberConnecting g host m -> [ttyGroup' g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"] CRConnectedToGroupMember g m -> [ttyGroup' g <> ": " <> connectedMember m <> " is connected"] @@ -200,22 +199,24 @@ responseToView testView = \case contactList :: [ContactRef] -> String contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs -viewChatItem :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> [StyledString] -viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case chat of +viewChatItem :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> [StyledString] +viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} doShow = case chat of DirectChat c -> case chatDir of CIDirectSnd -> case content of CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc - CISndDeleted _ -> [] - CISndCall {} -> [] - CISndGroupInvitation {} -> [] + CISndDeleted _ -> showSndItem to + CISndCall {} -> showSndItem to + CISndGroupInvitation {} -> showSndItem to + CISndGroupEvent {} -> showSndItemProhibited to where to = ttyToContact' c CIDirectRcv -> case content of CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc - CIRcvDeleted _ -> [] - CIRcvCall {} -> [] + CIRcvDeleted _ -> showRcvItem from + CIRcvCall {} -> showRcvItem from CIRcvIntegrityError err -> viewRcvIntegrityError from err meta - CIRcvGroupInvitation {} -> [] + CIRcvGroupInvitation {} -> showRcvItem from + CIRcvGroupEvent {} -> showRcvItemProhibited from where from = ttyFromContact' c where @@ -223,17 +224,19 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha GroupChat g -> case chatDir of CIGroupSnd -> case content of CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc - CISndDeleted _ -> [] - CISndCall {} -> [] - CISndGroupInvitation {} -> [] -- prohibited + CISndDeleted _ -> showSndItem to + CISndCall {} -> showSndItem to + CISndGroupInvitation {} -> showSndItemProhibited to + CISndGroupEvent {} -> showSndItem to where to = ttyToGroup g CIGroupRcv m -> case content of CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc - CIRcvDeleted _ -> [] - CIRcvCall {} -> [] + CIRcvDeleted _ -> showRcvItem from + CIRcvCall {} -> showRcvItem from CIRcvIntegrityError err -> viewRcvIntegrityError from err meta - CIRcvGroupInvitation {} -> [] -- prohibited + CIRcvGroupInvitation {} -> showRcvItemProhibited from + CIRcvGroupEvent {} -> showRcvItem from where from = ttyFromGroup' g m where @@ -249,6 +252,13 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha ("", Just _, []) -> [] ("", Just CIFile {fileName}, _) -> view dir quote (MCText $ T.pack fileName) meta _ -> view dir quote mc meta + showSndItem to = showItem $ sentWithTime_ [to <> plainContent content] meta + showRcvItem from = showItem $ receivedWithTime_ from [] meta [plainContent content] + showSndItemProhibited to = showItem $ sentWithTime_ [to <> plainContent content <> " " <> prohibited] meta + showRcvItemProhibited from = showItem $ receivedWithTime_ from [] meta [plainContent content <> " " <> prohibited] + showItem ss = if doShow then ss else [] + plainContent = plain . ciContentToText + prohibited = styled (colored Red) ("[prohibited - it's a bug if this chat item was created in this context, please report it to dev team]" :: String) viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> [StyledString] viewItemUpdate chat ChatItem {chatDir, meta, content, quotedItem} = case chat of diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 156ba67ebc..dc86b962ad 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -9,7 +9,7 @@ import ChatClient import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM -import Control.Monad (forM_) +import Control.Monad (forM_, when) import Data.Aeson (ToJSON) import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B @@ -46,6 +46,7 @@ chatTests = do it "direct message delete" testDirectMessageDelete describe "chat groups" $ do describe "add contacts, create group and send/receive messages" testGroup + it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages it "create and join group with 4 members" testGroup2 it "create and delete group" testGroupDelete it "invitee delete group when in status invited" testGroupDeleteWhenInvited @@ -362,109 +363,120 @@ testDirectMessageDelete = testGroup :: Spec testGroup = versionTestMatrix3 runTestGroup where - runTestGroup alice bob cath = do - connectUsers alice bob - connectUsers alice cath - alice ##> "/g team" - alice <## "group #team is created" - alice <## "use /a team to add members" - alice ##> "/a team bob" - concurrentlyN_ - [ alice <## "invitation to join the group #team sent to bob", - do - bob <## "#team: alice invites you to join the group as admin" - bob <## "use /j team to accept" - ] - bob ##> "/j team" - concurrently_ - (alice <## "#team: bob joined the group") - (bob <## "#team: you joined the group") - alice ##> "/a team cath" - concurrentlyN_ - [ alice <## "invitation to join the group #team sent to cath", - do - cath <## "#team: alice invites you to join the group as admin" - cath <## "use /j team to accept" - ] - cath ##> "/j team" - concurrentlyN_ - [ alice <## "#team: cath joined the group", - do - cath <## "#team: you joined the group" - cath <## "#team: member bob (Bob) is connected", - do - bob <## "#team: alice added cath (Catherine) to the group (connecting...)" - bob <## "#team: new member cath is connected" - ] - alice #> "#team hello" - concurrently_ - (bob <# "#team alice> hello") - (cath <# "#team alice> hello") - threadDelay 1000000 -- server assigns timestamps with one second precision - bob #> "#team hi there" - concurrently_ - (alice <# "#team bob> hi there") - (cath <# "#team bob> hi there") - threadDelay 1000000 - cath #> "#team hey team" - concurrently_ - (alice <# "#team cath> hey team") - (bob <# "#team cath> hey team") - bob <##> cath - getReadChats alice bob cath - -- list groups - alice ##> "/gs" - alice <## "#team" - -- list group members - alice ##> "/ms team" - alice - <### [ "alice (Alice): owner, you, created group", - "bob (Bob): admin, invited, connected", - "cath (Catherine): admin, invited, connected" - ] - -- list contacts - alice ##> "/cs" - alice <## "bob (Bob)" - alice <## "cath (Catherine)" - -- remove member - bob ##> "/rm team cath" - concurrentlyN_ - [ bob <## "#team: you removed cath from the group", - alice <## "#team: bob removed cath from the group", - do - cath <## "#team: bob removed you from the group" - cath <## "use /d #team to delete the group" - ] - bob #> "#team hi" - concurrently_ - (alice <# "#team bob> hi") - (cath "#team hello" - concurrently_ - (bob <# "#team alice> hello") - (cath "#team hello" - cath <## "you are no longer a member of the group" - bob <##> cath - -- test clearing chat - alice #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") - alice #$> ("/_get chat #1 count=100", chat, []) - bob #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") - bob #$> ("/_get chat #1 count=100", chat, []) - cath #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") - cath #$> ("/_get chat #1 count=100", chat, []) - getReadChats :: TestCC -> TestCC -> TestCC -> IO () - getReadChats alice bob cath = do + runTestGroup alice bob cath = testGroupShared alice bob cath False + +testGroupCheckMessages :: IO () +testGroupCheckMessages = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> testGroupShared alice bob cath True + +testGroupShared :: TestCC -> TestCC -> TestCC -> Bool -> IO () +testGroupShared alice bob cath checkMessages = do + connectUsers alice bob + connectUsers alice cath + alice ##> "/g team" + alice <## "group #team is created" + alice <## "use /a team to add members" + alice ##> "/a team bob" + concurrentlyN_ + [ alice <## "invitation to join the group #team sent to bob", + do + bob <## "#team: alice invites you to join the group as admin" + bob <## "use /j team to accept" + ] + bob ##> "/j team" + concurrently_ + (alice <## "#team: bob joined the group") + (bob <## "#team: you joined the group") + when checkMessages $ threadDelay 1000000 -- for deterministic order of messages and "connected" events + alice ##> "/a team cath" + concurrentlyN_ + [ alice <## "invitation to join the group #team sent to cath", + do + cath <## "#team: alice invites you to join the group as admin" + cath <## "use /j team to accept" + ] + cath ##> "/j team" + concurrentlyN_ + [ alice <## "#team: cath joined the group", + do + cath <## "#team: you joined the group" + cath <## "#team: member bob (Bob) is connected", + do + bob <## "#team: alice added cath (Catherine) to the group (connecting...)" + bob <## "#team: new member cath is connected" + ] + when checkMessages $ threadDelay 1000000 -- for deterministic order of messages and "connected" events + alice #> "#team hello" + concurrently_ + (bob <# "#team alice> hello") + (cath <# "#team alice> hello") + threadDelay 1000000 -- server assigns timestamps with one second precision + bob #> "#team hi there" + concurrently_ + (alice <# "#team bob> hi there") + (cath <# "#team bob> hi there") + threadDelay 1000000 + cath #> "#team hey team" + concurrently_ + (alice <# "#team cath> hey team") + (bob <# "#team cath> hey team") + bob <##> cath + when checkMessages getReadChats + -- list groups + alice ##> "/gs" + alice <## "#team" + -- list group members + alice ##> "/ms team" + alice + <### [ "alice (Alice): owner, you, created group", + "bob (Bob): admin, invited, connected", + "cath (Catherine): admin, invited, connected" + ] + -- list contacts + alice ##> "/cs" + alice <## "bob (Bob)" + alice <## "cath (Catherine)" + -- remove member + bob ##> "/rm team cath" + concurrentlyN_ + [ bob <## "#team: you removed cath from the group", + alice <## "#team: bob removed cath from the group", + do + cath <## "#team: bob removed you from the group" + cath <## "use /d #team to delete the group" + ] + bob #> "#team hi" + concurrently_ + (alice <# "#team bob> hi") + (cath "#team hello" + concurrently_ + (bob <# "#team alice> hello") + (cath "#team hello" + cath <## "you are no longer a member of the group" + bob <##> cath + -- test clearing chat + alice #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") + alice #$> ("/_get chat #1 count=100", chat, []) + bob #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") + bob #$> ("/_get chat #1 count=100", chat, []) + cath #$> ("/clear #team", id, "#team: all messages are removed locally ONLY") + cath #$> ("/_get chat #1 count=100", chat, []) + where + getReadChats :: IO () + getReadChats = do alice @@@ [("#team", "hey team"), ("@cath", "sent invitation to join group team as admin"), ("@bob", "sent invitation to join group team as admin")] - alice #$> ("/_get chat #1 count=100", chat, [(1, "hello"), (0, "hi there"), (0, "hey team")]) + alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (0, "connected"), (1, "hello"), (0, "hi there"), (0, "hey team")]) -- "before" and "after" define a chat item id across all chats, - -- so we take into account sent group invitations in direct chats - alice #$> ("/_get chat #1 after=3 count=100", chat, [(0, "hi there"), (0, "hey team")]) - alice #$> ("/_get chat #1 before=5 count=100", chat, [(1, "hello"), (0, "hi there")]) + -- so we take into account group event items as well as sent group invitations in direct chats + alice #$> ("/_get chat #1 after=5 count=100", chat, [(0, "hi there"), (0, "hey team")]) + alice #$> ("/_get chat #1 before=7 count=100", chat, [(0, "connected"), (0, "connected"), (1, "hello"), (0, "hi there")]) bob @@@ [("@cath", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")] - bob #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (1, "hi there"), (0, "hey team")]) + bob #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (0, "added cath (Catherine)"), (0, "connected"), (0, "hello"), (1, "hi there"), (0, "hey team")]) cath @@@ [("@bob", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")] - cath #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (0, "hi there"), (1, "hey team")]) + cath #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (0, "connected"), (0, "hello"), (0, "hi there"), (1, "hey team")]) alice #$> ("/_read chat #1 from=1 to=100", id, "ok") bob #$> ("/_read chat #1 from=1 to=100", id, "ok") cath #$> ("/_read chat #1 from=1 to=100", id, "ok") @@ -566,9 +578,13 @@ testGroup2 = dan <##> cath dan <##> alice -- show last messages - alice ##> "/t #club 4" + alice ##> "/t #club 8" alice -- these strings are expected in any order because of sorting by time and rounding of time for sent - <##? [ "#club hello", + <##? [ "#club bob> connected", + "#club cath> connected", + "#club bob> added dan (Daniel)", + "#club dan> connected", + "#club hello", "#club bob> hi there", "#club cath> hey", "#club dan> how is it going?" @@ -578,9 +594,15 @@ testGroup2 = <##? [ "dan> hi", "@dan hey" ] - alice ##> "/t 8" + alice ##> "/t 12" alice - <##? [ "#club hello", + <##? [ "@bob sent invitation to join group club as admin", + "@cath sent invitation to join group club as admin", + "#club bob> connected", + "#club cath> connected", + "#club bob> added dan (Daniel)", + "#club dan> connected", + "#club hello", "#club bob> hi there", "#club cath> hey", "#club dan> how is it going?", @@ -811,6 +833,7 @@ testGroupMessageQuotedReply = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do createGroup3 "team" alice bob cath + threadDelay 1000000 alice #> "#team hello! how are you?" concurrently_ (bob <# "#team alice> hello! how are you?") @@ -828,9 +851,9 @@ testGroupMessageQuotedReply = cath <# "#team bob> > alice hello! how are you?" cath <## " hello, all good, you?" ) - bob #$> ("/_get chat #1 count=100", chat', [((0, "hello! how are you?"), Nothing), ((1, "hello, all good, you?"), Just (0, "hello! how are you?"))]) - alice #$> ("/_get chat #1 count=100", chat', [((1, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (1, "hello! how are you?"))]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (0, "hello! how are you?"))]) + bob #$> ("/_get chat #1 count=2", chat', [((0, "hello! how are you?"), Nothing), ((1, "hello, all good, you?"), Just (0, "hello! how are you?"))]) + alice #$> ("/_get chat #1 count=2", chat', [((1, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (1, "hello! how are you?"))]) + cath #$> ("/_get chat #1 count=2", chat', [((0, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (0, "hello! how are you?"))]) bob `send` "> #team bob (hello, all good) will tell more" bob <# "#team > bob hello, all good, you?" bob <## " will tell more" @@ -880,23 +903,24 @@ testGroupMessageUpdate = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do createGroup3 "team" alice bob cath - -- alice: msg id 3, bob, cath: msg id 2 (after group invitations) + threadDelay 1000000 + -- alice, bob: msg id 5, cath: msg id 4 (after group invitations & group events) alice #> "#team hello!" concurrently_ (bob <# "#team alice> hello!") (cath <# "#team alice> hello!") - alice #$> ("/_update item #1 3 text hey 👋", id, "message updated") + alice #$> ("/_update item #1 5 text hey 👋", id, "message updated") concurrently_ (bob <# "#team alice> [edited] hey 👋") (cath <# "#team alice> [edited] hey 👋") - alice #$> ("/_get chat #1 count=100", chat', [((1, "hey 👋"), Nothing)]) - bob #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing)]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing)]) + alice #$> ("/_get chat #1 count=1", chat', [((1, "hey 👋"), Nothing)]) + bob #$> ("/_get chat #1 count=1", chat', [((0, "hey 👋"), Nothing)]) + cath #$> ("/_get chat #1 count=1", chat', [((0, "hey 👋"), Nothing)]) threadDelay 1000000 - -- alice: msg id 4, bob, cath: msg id 3 + -- alice, bob: msg id 6, cath: msg id 5 bob `send` "> #team @alice (hey) hi alice" bob <# "#team > alice hey 👋" bob <## " hi alice" @@ -910,16 +934,16 @@ testGroupMessageUpdate = cath <## " hi alice" ) - alice #$> ("/_get chat #1 count=100", chat', [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hey 👋"))]) - bob #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hey 👋"))]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((0, "hi alice"), Just (0, "hey 👋"))]) + alice #$> ("/_get chat #1 count=2", chat', [((1, "hey 👋"), Nothing), ((0, "hi alice"), Just (1, "hey 👋"))]) + bob #$> ("/_get chat #1 count=2", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hey 👋"))]) + cath #$> ("/_get chat #1 count=2", chat', [((0, "hey 👋"), Nothing), ((0, "hi alice"), Just (0, "hey 👋"))]) - alice #$> ("/_update item #1 3 text greetings 🤝", id, "message updated") + alice #$> ("/_update item #1 5 text greetings 🤝", id, "message updated") concurrently_ (bob <# "#team alice> [edited] greetings 🤝") (cath <# "#team alice> [edited] greetings 🤝") - alice #$> ("/_update item #1 4 text updating bob's message", id, "cannot update this item") + alice #$> ("/_update item #1 6 text updating bob's message", id, "cannot update this item") threadDelay 1000000 cath `send` "> #team @alice (greetings) greetings!" @@ -935,32 +959,33 @@ testGroupMessageUpdate = bob <## " greetings!" ) - alice #$> ("/_get chat #1 count=100", chat', [((1, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (1, "hey 👋")), ((0, "greetings!"), Just (1, "greetings 🤝"))]) - bob #$> ("/_get chat #1 count=100", chat', [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hey 👋")), ((0, "greetings!"), Just (0, "greetings 🤝"))]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (0, "hey 👋")), ((1, "greetings!"), Just (0, "greetings 🤝"))]) + alice #$> ("/_get chat #1 count=3", chat', [((1, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (1, "hey 👋")), ((0, "greetings!"), Just (1, "greetings 🤝"))]) + bob #$> ("/_get chat #1 count=3", chat', [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hey 👋")), ((0, "greetings!"), Just (0, "greetings 🤝"))]) + cath #$> ("/_get chat #1 count=3", chat', [((0, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (0, "hey 👋")), ((1, "greetings!"), Just (0, "greetings 🤝"))]) testGroupMessageDelete :: IO () testGroupMessageDelete = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do createGroup3 "team" alice bob cath - -- alice: msg id 3, bob, cath: msg id 2 (after group invitations) + threadDelay 1000000 + -- alice, bob: msg id 5, cath: msg id 4 (after group invitations & group events) alice #> "#team hello!" concurrently_ (bob <# "#team alice> hello!") (cath <# "#team alice> hello!") - alice #$> ("/_delete item #1 3 internal", id, "message deleted") + alice #$> ("/_delete item #1 5 internal", id, "message deleted") - alice #$> ("/_get chat #1 count=100", chat, []) - bob #$> ("/_get chat #1 count=100", chat, [(0, "hello!")]) - cath #$> ("/_get chat #1 count=100", chat, [(0, "hello!")]) + alice #$> ("/_get chat #1 count=1", chat, [(0, "connected")]) + bob #$> ("/_get chat #1 count=1", chat, [(0, "hello!")]) + cath #$> ("/_get chat #1 count=1", chat, [(0, "hello!")]) - alice #$> ("/_update item #1 3 text updating deleted message", id, "cannot update this item") - alice #$> ("/_send #1 json {\"quotedItemId\": 3, \"msgContent\": {\"type\": \"text\", \"text\": \"quoting deleted message\"}}", id, "cannot reply to this message") + alice #$> ("/_update item #1 5 text updating deleted message", id, "cannot update this item") + alice #$> ("/_send #1 json {\"quotedItemId\": 5, \"msgContent\": {\"type\": \"text\", \"text\": \"quoting deleted message\"}}", id, "cannot reply to this message") threadDelay 1000000 - -- alice: msg id 4, bob, cath: msg id 3 + -- alice, bob: msg id 6, cath: msg id 5 bob `send` "> #team @alice (hello) hi alic" bob <# "#team > alice hello!" bob <## " hi alic" @@ -974,22 +999,22 @@ testGroupMessageDelete = cath <## " hi alic" ) - alice #$> ("/_get chat #1 count=100", chat', [((0, "hi alic"), Just (1, "hello!"))]) - bob #$> ("/_get chat #1 count=100", chat', [((0, "hello!"), Nothing), ((1, "hi alic"), Just (0, "hello!"))]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) + alice #$> ("/_get chat #1 count=1", chat', [((0, "hi alic"), Just (1, "hello!"))]) + bob #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((1, "hi alic"), Just (0, "hello!"))]) + cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) - alice #$> ("/_delete item #1 3 broadcast", id, "message deleted") + alice #$> ("/_delete item #1 5 broadcast", id, "message deleted") concurrently_ (bob <# "#team alice> [deleted] hello!") (cath <# "#team alice> [deleted] hello!") - alice #$> ("/_delete item #1 4 internal", id, "message deleted") + alice #$> ("/_delete item #1 6 internal", id, "message deleted") - alice #$> ("/_get chat #1 count=100", chat', []) - bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alic"), Just (0, "hello!"))]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) + alice #$> ("/_get chat #1 count=1", chat', [((0, "connected"), Nothing)]) + bob #$> ("/_get chat #1 count=2", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alic"), Just (0, "hello!"))]) + cath #$> ("/_get chat #1 count=2", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) - bob #$> ("/_update item #1 3 text hi alice", id, "message updated") + bob #$> ("/_update item #1 6 text hi alice", id, "message updated") concurrently_ (alice <# "#team bob> [edited] hi alice") ( do @@ -997,28 +1022,28 @@ testGroupMessageDelete = cath <## " hi alice" ) - alice #$> ("/_get chat #1 count=100", chat', [((0, "hi alice"), Nothing)]) - bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!"))]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))]) + alice #$> ("/_get chat #1 count=1", chat', [((0, "hi alice"), Nothing)]) + bob #$> ("/_get chat #1 count=2", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!"))]) + cath #$> ("/_get chat #1 count=2", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))]) threadDelay 1000000 - -- alice: msg id 5, bob, cath: msg id 4 + -- alice, bob: msg id 7, cath: msg id 6 cath #> "#team how are you?" concurrently_ (alice <# "#team cath> how are you?") (bob <# "#team cath> how are you?") - cath #$> ("/_delete item #1 4 broadcast", id, "message deleted") + cath #$> ("/_delete item #1 6 broadcast", id, "message deleted") concurrently_ (alice <# "#team cath> [deleted] how are you?") (bob <# "#team cath> [deleted] how are you?") - alice #$> ("/_delete item #1 4 broadcast", id, "cannot delete this item") - alice #$> ("/_delete item #1 4 internal", id, "message deleted") + alice #$> ("/_delete item #1 6 broadcast", id, "cannot delete this item") + alice #$> ("/_delete item #1 6 internal", id, "message deleted") - alice #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing)]) - bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "this item is deleted (broadcast)"), Nothing)]) - cath #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))]) + alice #$> ("/_get chat #1 count=1", chat', [((0, "this item is deleted (broadcast)"), Nothing)]) + bob #$> ("/_get chat #1 count=3", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "this item is deleted (broadcast)"), Nothing)]) + cath #$> ("/_get chat #1 count=2", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))]) testGroupAsync :: IO () testGroupAsync = withTmpFiles $ do @@ -1613,6 +1638,7 @@ testGroupSendImage = versionTestMatrix3 runTestGroupSendImage where runTestGroupSendImage alice bob cath = do createGroup3 "team" alice bob cath + threadDelay 1000000 alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" alice <# "/f #team ./tests/fixtures/test.jpg" alice <## "use /fc 1 to cancel sending" @@ -1649,21 +1675,22 @@ testGroupSendImage = versionTestMatrix3 runTestGroupSendImage dest `shouldBe` src dest2 <- B.readFile "./tests/tmp/test_1.jpg" dest2 `shouldBe` src - alice #$> ("/_get chat #1 count=100", chatF, [((1, ""), Just "./tests/fixtures/test.jpg")]) - bob #$> ("/_get chat #1 count=100", chatF, [((0, ""), Just "./tests/tmp/test.jpg")]) - cath #$> ("/_get chat #1 count=100", chatF, [((0, ""), Just "./tests/tmp/test_1.jpg")]) + alice #$> ("/_get chat #1 count=1", chatF, [((1, ""), Just "./tests/fixtures/test.jpg")]) + bob #$> ("/_get chat #1 count=1", chatF, [((0, ""), Just "./tests/tmp/test.jpg")]) + cath #$> ("/_get chat #1 count=1", chatF, [((0, ""), Just "./tests/tmp/test_1.jpg")]) testGroupSendImageWithTextAndQuote :: IO () testGroupSendImageWithTextAndQuote = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do createGroup3 "team" alice bob cath + threadDelay 1000000 bob #> "#team hi team" concurrently_ (alice <# "#team bob> hi team") (cath <# "#team bob> hi team") threadDelay 1000000 - alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": 3, \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" + alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": 5, \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}" alice <# "#team > bob hi team" alice <## " hey bob" alice <# "/f #team ./tests/fixtures/test.jpg" @@ -1705,11 +1732,11 @@ testGroupSendImageWithTextAndQuote = dest `shouldBe` src dest2 <- B.readFile "./tests/tmp/test_1.jpg" dest2 `shouldBe` src - alice #$> ("/_get chat #1 count=100", chat'', [((0, "hi team"), Nothing, Nothing), ((1, "hey bob"), Just (0, "hi team"), Just "./tests/fixtures/test.jpg")]) + alice #$> ("/_get chat #1 count=2", chat'', [((0, "hi team"), Nothing, Nothing), ((1, "hey bob"), Just (0, "hi team"), Just "./tests/fixtures/test.jpg")]) alice @@@ [("#team", "hey bob"), ("@bob", "sent invitation to join group team as admin"), ("@cath", "sent invitation to join group team as admin")] - bob #$> ("/_get chat #1 count=100", chat'', [((1, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi team"), Just "./tests/tmp/test.jpg")]) + bob #$> ("/_get chat #1 count=2", chat'', [((1, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi team"), Just "./tests/tmp/test.jpg")]) bob @@@ [("#team", "hey bob"), ("@alice", "received invitation to join group team as admin")] - cath #$> ("/_get chat #1 count=100", chat'', [((0, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (0, "hi team"), Just "./tests/tmp/test_1.jpg")]) + cath #$> ("/_get chat #1 count=2", chat'', [((0, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (0, "hi team"), Just "./tests/tmp/test_1.jpg")]) cath @@@ [("#team", "hey bob"), ("@alice", "received invitation to join group team as admin")] testUserContactLink :: Spec