android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-29 04:39:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

core: direct messages in group (#2994)

Browse source
This commit is contained in:
spaced4ndy 2023-09-11 18:38:57 +04:00 • committed by GitHub
parent 181323ce13
commit 5fddf64adb
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
18 changed files with 1298 additions and 428 deletions
Download patch file Download diff file Expand all files Collapse all files

1
simplex-chat.cabal
View file

@ -111,6 +111,7 @@ library
Simplex.Chat.Migrations.M20230827_file_encryption
Simplex.Chat.Migrations.M20230829_connections_chat_vrange
Simplex.Chat.Migrations.M20230903_connections_to_subscribe
Simplex.Chat.Migrations.M20230904_item_direct_group_member_id
Simplex.Chat.Mobile
Simplex.Chat.Mobile.File
Simplex.Chat.Mobile.Shared

585
src/Simplex/Chat.hs
View file

File diff suppressed because it is too large Load diff

2
src/Simplex/Chat/Bot.hs
View file

@ -67,7 +67,7 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
sendComposedMessage' cc ctId quotedItemId msgContent = do
let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent}
sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case
sendChatCmd cc (APISendMessage (SRDirect ctId) False Nothing cm) >>= \case
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
r -> putStrLn $ "unexpected send message response: " <> show r

51
src/Simplex/Chat/Controller.hs
View file

@ -34,6 +34,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (NominalDiffTime)
import Data.Time.Clock (UTCTime)
import Data.Version (showVersion)
@ -241,7 +242,7 @@ data ChatCommand
| APIGetChat ChatRef ChatPagination (Maybe String)
| APIGetChatItems ChatPagination (Maybe String)
| APIGetChatItemInfo ChatRef ChatItemId
| APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage}
| APISendMessage {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
| APIDeleteChatItem ChatRef ChatItemId CIDeleteMode
| APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId
@ -352,14 +353,14 @@ data ChatCommand
| AddressAutoAccept (Maybe AutoAccept)
| AcceptContact IncognitoEnabled ContactName
| RejectContact ContactName
| SendMessage ChatName Text
| SendLiveMessage ChatName Text
| SendMessage SendName Text
| SendLiveMessage SendName Text
| SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: Text, message :: Text}
| SendMessageBroadcast Text -- UserId (not used in UI)
| DeleteMessage ChatName Text
| DeleteMemberMessage GroupName ContactName Text
| EditMessage {chatName :: ChatName, editedMsg :: Text, message :: Text}
| UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text}
| UpdateLiveMessage {sendName :: SendName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text}
| ReactToMessage {add :: Bool, reaction :: MsgReaction, chatName :: ChatName, reactToMessage :: Text}
| APINewGroup UserId GroupProfile
| NewGroup GroupProfile
@ -381,17 +382,17 @@ data ChatCommand
| GroupLinkMemberRole GroupName GroupMemberRole
| DeleteGroupLink GroupName
| ShowGroupLink GroupName
| SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: Text, message :: Text}
| SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, directMemberName :: Maybe ContactName, quotedMsg :: Text, message :: Text}
| LastChats (Maybe Int) -- UserId (not used in UI)
| LastMessages (Maybe ChatName) Int (Maybe String) -- UserId (not used in UI)
| LastChatItemId (Maybe ChatName) Int -- UserId (not used in UI)
| ShowChatItem (Maybe ChatItemId) -- UserId (not used in UI)
| ShowChatItemInfo ChatName Text
| ShowLiveItems Bool
| SendFile ChatName FilePath
| SendImage ChatName FilePath
| ForwardFile ChatName FileTransferId
| ForwardImage ChatName FileTransferId
| SendFile SendName FilePath
| SendImage SendName FilePath
| ForwardFile SendName FileTransferId
| ForwardImage SendName FileTransferId
| SendFileDescription ChatName FilePath
| ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
| SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool}
@ -612,6 +613,37 @@ instance ToJSON ChatResponse where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
data SendRef
= SRDirect ContactId
| SRGroup GroupId (Maybe GroupMemberId)
deriving (Eq, Show)
sendToChatRef :: SendRef -> ChatRef
sendToChatRef = \case
SRDirect cId -> ChatRef CTDirect cId
SRGroup gId _ -> ChatRef CTGroup gId
data SendName
= SNDirect ContactName
| SNGroup GroupName (Maybe ContactName)
deriving (Eq, Show)
sendNameStr :: SendName -> String
sendNameStr = \case
SNDirect cName -> "@" <> T.unpack cName
SNGroup gName (Just cName) -> "#" <> T.unpack gName <> " @" <> T.unpack cName
SNGroup gName Nothing -> "#" <> T.unpack gName
data SendDirection
= SDDirect Contact
| SDGroup GroupInfo [GroupMember]
deriving (Eq, Show)
sendDirToContactOrGroup :: SendDirection -> ContactOrGroup
sendDirToContactOrGroup = \case
SDDirect c -> CGContact c
SDGroup g _ -> CGGroup g
newtype UserPwd = UserPwd {unUserPwd :: Text}
deriving (Eq, Show)
@ -927,6 +959,7 @@ data ChatErrorType
| CEAgentCommandError {message :: String}
| CEInvalidFileDescription {message :: String}
| CEConnectionIncognitoChangeProhibited
| CEPeerChatVRangeIncompatible
| CEInternalError {message :: String}
| CEException {message :: String}
deriving (Show, Exception, Generic)

79
src/Simplex/Chat/Messages.hs
View file

@ -50,16 +50,6 @@ data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
data ChatName = ChatName ChatType Text
deriving (Show)
chatTypeStr :: ChatType -> String
chatTypeStr = \case
CTDirect -> "@"
CTGroup -> "#"
CTContactRequest -> "<@"
CTContactConnection -> ":"
chatNameStr :: ChatName -> String
chatNameStr (ChatName cType name) = chatTypeStr cType <> T.unpack name
data ChatRef = ChatRef ChatType Int64
deriving (Eq, Show, Ord)
@ -148,16 +138,16 @@ instance MsgDirectionI d => ToJSON (ChatItem c d) where
data CIDirection (c :: ChatType) (d :: MsgDirection) where
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
CIGroupSnd :: CIDirection 'CTGroup 'MDSnd
CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv
CIGroupSnd :: Maybe GroupMember -> CIDirection 'CTGroup 'MDSnd
CIGroupRcv :: GroupMember -> MessageScope -> CIDirection 'CTGroup 'MDRcv
deriving instance Show (CIDirection c d)
data JSONCIDirection
= JCIDirectSnd
| JCIDirectRcv
| JCIGroupSnd
| JCIGroupRcv {groupMember :: GroupMember}
| JCIGroupSnd {directMember :: Maybe GroupMember}
| JCIGroupRcv {groupMember :: GroupMember, messageScope :: MessageScope}
deriving (Generic, Show)
instance ToJSON JSONCIDirection where
@ -172,8 +162,19 @@ jsonCIDirection :: CIDirection c d -> JSONCIDirection
jsonCIDirection = \case
CIDirectSnd -> JCIDirectSnd
CIDirectRcv -> JCIDirectRcv
CIGroupSnd -> JCIGroupSnd
CIGroupRcv m -> JCIGroupRcv m
CIGroupSnd dm -> JCIGroupSnd dm
CIGroupRcv m ms -> JCIGroupRcv m ms
ciDirDirectMember :: CIDirection 'CTGroup d -> Maybe GroupMember
ciDirDirectMember = \case
CIGroupSnd dm -> dm
CIGroupRcv _ MSGroup -> Nothing
CIGroupRcv m MSDirect -> Just m
directMemberToMsgScope :: Maybe GroupMember -> MessageScope
directMemberToMsgScope = \case
Nothing -> MSGroup
Just _ -> MSDirect
data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int}
deriving (Show, Generic)
@ -208,8 +209,8 @@ timedDeleteAt' CITimed {deleteAt} = deleteAt
chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> GroupMember
chatItemMember GroupInfo {membership} ChatItem {chatDir} = case chatDir of
CIGroupSnd -> membership
CIGroupRcv m -> m
CIGroupSnd _ -> membership
CIGroupRcv m _ -> m
ciReactionAllowed :: ChatItem c d -> Bool
ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False
@ -238,22 +239,22 @@ chatItemDeletedState ChatItem {meta = CIMeta {itemDeleted}, content} =
data ChatDirection (c :: ChatType) (d :: MsgDirection) where
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
CDGroupSnd :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupRcv :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
CDGroupSnd :: GroupInfo -> Maybe GroupMember -> ChatDirection 'CTGroup 'MDSnd
CDGroupRcv :: GroupInfo -> GroupMember -> MessageScope -> ChatDirection 'CTGroup 'MDRcv
toCIDirection :: ChatDirection c d -> CIDirection c d
toCIDirection = \case
CDDirectSnd _ -> CIDirectSnd
CDDirectRcv _ -> CIDirectRcv
CDGroupSnd _ -> CIGroupSnd
CDGroupRcv _ m -> CIGroupRcv m
CDGroupSnd _ dm -> CIGroupSnd dm
CDGroupRcv _ m ms -> CIGroupRcv m ms
toChatInfo :: ChatDirection c d -> ChatInfo c
toChatInfo = \case
CDDirectSnd c -> DirectChat c
CDDirectRcv c -> DirectChat c
CDGroupSnd g -> GroupChat g
CDGroupRcv g _ -> GroupChat g
CDGroupSnd g _ -> GroupChat g
CDGroupRcv g _ _ -> GroupChat g
data NewChatItem d = NewChatItem
{ createdByMsgId :: Maybe MessageId,
@ -433,29 +434,39 @@ instance ToJSON (JSONCIReaction c d) where
data CIQDirection (c :: ChatType) where
CIQDirectSnd :: CIQDirection 'CTDirect
CIQDirectRcv :: CIQDirection 'CTDirect
CIQGroupSnd :: CIQDirection 'CTGroup
CIQGroupRcv :: Maybe GroupMember -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet
CIQGroupSnd :: MessageScope -> CIQDirection 'CTGroup
CIQGroupRcv :: Maybe GroupMember -> MessageScope -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet
deriving instance Show (CIQDirection c)
data JSONCIQDirection
= JCIQDirectSnd
| JCIQDirectRcv
| JCIQGroupSnd {messageScope :: MessageScope}
| JCIQGroupRcv {groupMember :: Maybe GroupMember, messageScope :: MessageScope}
deriving (Generic, Show)
instance ToJSON JSONCIQDirection where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIQ"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIQ"
instance ToJSON (CIQDirection c) where
toJSON = J.toJSON . jsonCIQDirection
toEncoding = J.toEncoding . jsonCIQDirection
jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection
jsonCIQDirection :: CIQDirection c -> JSONCIQDirection
jsonCIQDirection = \case
CIQDirectSnd -> Just JCIDirectSnd
CIQDirectRcv -> Just JCIDirectRcv
CIQGroupSnd -> Just JCIGroupSnd
CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m
CIQGroupRcv Nothing -> Nothing
CIQDirectSnd -> JCIQDirectSnd
CIQDirectRcv -> JCIQDirectRcv
CIQGroupSnd ms -> JCIQGroupSnd ms
CIQGroupRcv m ms -> JCIQGroupRcv m ms
quoteMsgDirection :: CIQDirection c -> MsgDirection
quoteMsgDirection = \case
CIQDirectSnd -> MDSnd
CIQDirectRcv -> MDRcv
CIQGroupSnd -> MDSnd
CIQGroupRcv _ -> MDRcv
CIQGroupSnd _ -> MDSnd
CIQGroupRcv _ _ -> MDRcv
data CIFile (d :: MsgDirection) = CIFile
{ fileId :: Int64,

24
src/Simplex/Chat/Migrations/M20230904_item_direct_group_member_id.hs Normal file
View file

@ -0,0 +1,24 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20230904_item_direct_group_member_id where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230904_item_direct_group_member_id :: Query
m20230904_item_direct_group_member_id =
[sql|
ALTER TABLE chat_items ADD COLUMN item_direct_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL;
ALTER TABLE chat_items ADD COLUMN quoted_message_scope TEXT;
CREATE INDEX idx_chat_items_item_direct_group_member_id ON chat_items(item_direct_group_member_id);
|]
down_m20230904_item_direct_group_member_id :: Query
down_m20230904_item_direct_group_member_id =
[sql|
DROP INDEX idx_chat_items_item_direct_group_member_id;
ALTER TABLE chat_items DROP COLUMN quoted_message_scope;
ALTER TABLE chat_items DROP COLUMN item_direct_group_member_id;
|]

7
src/Simplex/Chat/Migrations/chat_schema.sql
View file

@ -392,7 +392,9 @@ CREATE TABLE chat_items(
timed_delete_at TEXT,
item_live INTEGER,
item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
item_deleted_ts TEXT
item_deleted_ts TEXT,
item_direct_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
quoted_message_scope TEXT
);
CREATE TABLE chat_item_messages(
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
@ -713,3 +715,6 @@ CREATE INDEX idx_chat_items_user_id_item_status ON chat_items(
item_status
);
CREATE INDEX idx_connections_to_subscribe ON connections(to_subscribe);
CREATE INDEX idx_chat_items_item_direct_group_member_id ON chat_items(
item_direct_group_member_id
);

39
src/Simplex/Chat/Protocol.hs
View file

@ -44,7 +44,7 @@ import Simplex.Chat.Types
import Simplex.Chat.Types.Util
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)
@ -58,6 +58,10 @@ supportedChatVRange = mkVersionRange 1 currentChatVersion
groupNoDirectVRange :: VersionRange
groupNoDirectVRange = mkVersionRange 2 currentChatVersion
-- version range that supports private messages from members in a group
groupPrivateMessagesVRange :: VersionRange
groupPrivateMessagesVRange = mkVersionRange 2 currentChatVersion
data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@ -158,11 +162,28 @@ instance ToJSON SharedMsgId where
toJSON = strToJSON
toEncoding = strToJEncoding
data MessageScope = MSGroup | MSDirect
deriving (Eq, Show, Generic)
instance FromJSON MessageScope where
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MS"
instance ToJSON MessageScope where
toJSON = J.genericToJSON . enumJSON $ dropPrefix "MS"
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MS"
instance ToField MessageScope where
toField = toField . encodeJSON
instance FromField MessageScope where
fromField = fromTextField_ decodeJSON
data MsgRef = MsgRef
{ msgId :: Maybe SharedMsgId,
sentAt :: UTCTime,
sent :: Bool,
memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received
memberId :: Maybe MemberId, -- must be present in all group message references, both referencing sent and received
msgScope :: Maybe MessageScope
}
deriving (Eq, Show, Generic)
@ -447,7 +468,13 @@ msgContentTag = \case
MCFile {} -> MCFile_
MCUnknown {tag} -> MCUnknown_ tag
data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool}
data ExtMsgContent = ExtMsgContent
{ content :: MsgContent,
file :: Maybe FileInvitation,
ttl :: Maybe Int,
live :: Maybe Bool,
scope :: Maybe MessageScope
}
deriving (Eq, Show)
parseMsgContainer :: J.Object -> JT.Parser MsgContainer
@ -456,10 +483,10 @@ parseMsgContainer v =
<|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc)
<|> MCSimple <$> mc
where
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live"
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live" <*> v .:? "scope"
extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing Nothing
justTrue :: Bool -> Maybe Bool
justTrue True = Just True
@ -503,7 +530,7 @@ msgContainerJSON = \case
MCSimple mc -> o $ msgContent mc
where
o = JM.fromList
msgContent (ExtMsgContent c file ttl live) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["content" .= c]
msgContent (ExtMsgContent c file ttl live scope) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) ["content" .= c]
instance ToJSON MsgContent where
toJSON = \case

154
src/Simplex/Chat/Store/Messages.hs
View file

@ -25,6 +25,7 @@ module Simplex.Chat.Store.Messages
createRcvMsgDeliveryEvent,
createPendingGroupMessage,
getPendingGroupMessages,
deleteMessage,
deletePendingGroupMessage,
deleteOldMessages,
updateChatTs,
@ -289,6 +290,10 @@ getPendingGroupMessages db groupMemberId =
pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) =
PendingGroupMessage {msgId, cmEventTag, msgBody, introId_}
deleteMessage :: DB.Connection -> MessageId -> IO ()
deleteMessage db msgId = do
DB.execute db "DELETE FROM messages WHERE message_id = ?" (Only msgId)
deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO ()
deletePendingGroupMessage db groupMemberId messageId =
DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId)
@ -297,7 +302,7 @@ deleteOldMessages :: DB.Connection -> UTCTime -> IO ()
deleteOldMessages db createdAtCutoff = do
DB.execute db "DELETE FROM messages WHERE created_at <= ?" (Only createdAtCutoff)
type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId)
type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId, Maybe MessageScope)
updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO ()
updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of
@ -320,14 +325,15 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
quoteRow = case quotedItem of
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} ->
uncurry (quotedSharedMsgId,Just sentAt,Just content,,) $ case chatDir of
CIQDirectSnd -> (Just True, Nothing)
CIQDirectRcv -> (Just False, Nothing)
CIQGroupSnd -> (Just True, Nothing)
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
CIQGroupRcv Nothing -> (Just False, Nothing)
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} -> do
let (quotedSent, quotedMemberId, quotedMsgScope) = case chatDir of
CIQDirectSnd -> (Just True, Nothing, Nothing)
CIQDirectRcv -> (Just False, Nothing, Nothing)
CIQGroupSnd messageScope -> (Just True, Nothing, Just messageScope)
CIQGroupRcv (Just GroupMember {memberId}) messageScope -> (Just False, Just memberId, Just messageScope)
CIQGroupRcv Nothing messageScope -> (Just False, Nothing, Just messageScope)
(quotedSharedMsgId, Just sentAt, Just content, quotedSent, quotedMemberId, quotedMsgScope)
createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c))
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent timed live itemTs createdAt = do
@ -338,19 +344,20 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} shar
quotedMsg = cmToQuotedMsg chatMsgEvent
quoteRow :: NewQuoteRow
quoteRow = case quotedMsg of
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId}, content} ->
uncurry (sharedMsgId,Just sentAt,Just content,,) $ case chatDirection of
CDDirectRcv _ -> (Just $ not sent, Nothing)
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
(Just $ Just userMemberId == memberId, memberId)
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId, msgScope}, content} -> do
let (quotedSent, quotedMemberId, quotedMsgScope) = case chatDirection of
CDDirectRcv _ -> (Just $ not sent, Nothing, Nothing)
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ _ ->
(Just $ Just userMemberId == memberId, memberId, msgScope)
(sharedMsgId, Just sentAt, Just content, quotedSent, quotedMemberId, quotedMsgScope)
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection ciContent =
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False
where
quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do
@ -359,12 +366,12 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
[sql|
INSERT INTO chat_items (
-- user and IDs
user_id, created_by_msg_id, contact_id, group_id, group_member_id,
user_id, created_by_msg_id, contact_id, group_id, group_member_id, item_direct_group_member_id,
-- meta
item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
-- quote
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, quoted_message_scope
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((userId, msgId_) :. idsRow :. itemRow :. quoteRow)
ciId <- insertedRowId db
@ -373,12 +380,16 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
where
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime)
itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64)
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
idsRow = case chatDirection of
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing)
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId)
CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing)
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} messageScope -> case messageScope of
MSGroup -> (Nothing, Just groupId, Just groupMemberId, Nothing)
MSDirect -> (Nothing, Just groupId, Just groupMemberId, Just groupMemberId)
CDGroupSnd GroupInfo {groupId} directMember -> case directMember of
Nothing -> (Nothing, Just groupId, Nothing, Nothing)
Just GroupMember {groupMemberId} -> (Nothing, Just groupId, Nothing, Just groupMemberId)
ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime)
ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt)
@ -388,19 +399,21 @@ insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime ->
insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts)
getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c)
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} =
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId, msgScope}, content} =
case chatDirection of
CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent)
CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} ->
CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} _directMember ->
case memberId of
Just mId
| mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId
| mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId
| mId == userMemberId -> (`ciQuote` CIQGroupSnd messageScope) <$> getUserGroupChatItemId_ groupId
| mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender) messageScope) <$> getGroupChatItemId_ groupId mId
| otherwise -> getGroupChatItemQuote_ groupId mId
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing messageScope
where
ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c
ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content
messageScope :: MessageScope
messageScope = fromMaybe MSGroup msgScope
getDirectChatItemQuote_ :: Int64 -> Bool -> IO (CIQuote 'CTDirect)
getDirectChatItemQuote_ contactId userSent = do
fmap ciQuoteDirect . maybeFirstRow fromOnly $
@ -447,8 +460,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
[":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId]
where
ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing messageScope
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId $ CIQGroupRcv (Just $ toGroupMember userContactId memberRow) messageScope
getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat]
getChatPreviews db user withPCC = do
@ -556,7 +569,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
m.member_status, 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,
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, i.quoted_message_scope,
-- 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,
@ -564,7 +577,11 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
-- 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,
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences,
-- direct GroupMember
dirm.group_member_id, dirm.group_id, dirm.member_id, dirm.member_role, dirm.member_category,
dirm.member_status, dirm.invited_by, dirm.local_display_name, dirm.contact_id, dirm.contact_profile_id, dirp.contact_profile_id,
dirp.display_name, dirp.full_name, dirp.image, dirp.contact_link, dirp.local_alias, dirp.preferences
FROM groups g
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
JOIN group_members mu ON mu.group_id = g.group_id
@ -590,6 +607,8 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id)
LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id
LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id)
LEFT JOIN group_members dirm ON dirm.group_member_id = i.item_direct_group_member_id
LEFT JOIN contact_profiles dirp ON dirp.contact_profile_id = COALESCE(dirm.member_profile_id, dirm.contact_profile_id)
WHERE g.user_id = ? AND mu.contact_id = ?
ORDER BY i.item_ts DESC
|]
@ -967,10 +986,8 @@ toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect)
toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent
where
direction sent = if sent then CIQDirectSnd else CIQDirectRcv
toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c)
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir =
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir =
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
-- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
@ -1013,37 +1030,60 @@ toDirectChatItemList currentTs (((Just itemId, Just itemTs, Just msgDir, Just it
either (const []) (: []) $ toDirectChatItem currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow)
toDirectChatItemList _ _ = []
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
type GroupQuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MessageScope)
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow
type GroupQuoteMemberRow = GroupQuoteRow :. MaybeGroupMemberRow
toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteMemberRow :. MaybeGroupMemberRow :. MaybeGroupMemberRow
toGroupQuote :: GroupQuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
toGroupQuote qr@(_, _, _, _, quotedSent, msgScope) quotedMember_ =
toQuote qr $ direction quotedSent quotedMember_
where
direction (Just True) _ = Just CIQGroupSnd
direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member
direction (Just False) Nothing = Just $ CIQGroupRcv Nothing
direction (Just True) _ = Just $ CIQGroupSnd messageScope
direction (Just False) (Just member) = Just $ CIQGroupRcv (Just member) messageScope
direction (Just False) Nothing = Just $ CIQGroupRcv Nothing messageScope
direction _ _ = Nothing
messageScope = fromMaybe MSGroup msgScope
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _, _) dir =
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
-- this function can be changed so it never fails, not only avoid failure on invalid json
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteMemberRow :. MaybeGroupMemberRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
member_ = toMaybeGroupMember userContactId memberRow_
quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_
directMember_ = toMaybeGroupMember userContactId directMemberRow_
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
chatItem itemContent = case (itemContent, itemStatus, member_, fileStatus_) of
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) ->
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus)
Right $ cItem SMDSnd (CIGroupSnd directMember_) ciStatus ciContent (maybeCIFile fileStatus)
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) ->
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing
Right $ cItem SMDSnd (CIGroupSnd directMember_) ciStatus ciContent Nothing
-- read of group chat item can be refactored so that direct member is not read for rcv items:
-- if item_direct_group_member_id is equal to group_member_id, then message scope is direct
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) ->
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus)
case directMember_ of
Just directMember
| sameMember member directMember ->
Right $ cItem SMDRcv (CIGroupRcv member MSDirect) ciStatus ciContent (maybeCIFile fileStatus)
| otherwise -> badItem
Nothing ->
Right $ cItem SMDRcv (CIGroupRcv member MSGroup) ciStatus ciContent (maybeCIFile fileStatus)
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) ->
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent Nothing
case directMember_ of
Just directMember
| sameMember member directMember ->
Right $ cItem SMDRcv (CIGroupRcv member MSDirect) ciStatus ciContent Nothing
| otherwise -> badItem
Nothing ->
Right $ cItem SMDRcv (CIGroupRcv member MSGroup) ciStatus ciContent Nothing
_ -> badItem
sameMember :: GroupMember -> GroupMember -> Bool
sameMember GroupMember {groupMemberId = gmId1} GroupMember {groupMemberId = gmId2} = gmId1 == gmId2
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
maybeCIFile fileStatus =
case (fileId_, fileName_, fileSize_, fileProtocol_) of
@ -1068,8 +1108,8 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup]
toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) =
either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_)
toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_) =
either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_)
toGroupChatItemList _ _ _ = []
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
@ -1484,7 +1524,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
m.member_status, 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,
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, i.quoted_message_scope,
-- 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,
@ -1492,7 +1532,11 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
-- 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,
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences,
-- direct GroupMember
dirm.group_member_id, dirm.group_id, dirm.member_id, dirm.member_role, dirm.member_category,
dirm.member_status, dirm.invited_by, dirm.local_display_name, dirm.contact_id, dirm.contact_profile_id, dirp.contact_profile_id,
dirp.display_name, dirp.full_name, dirp.image, dirp.contact_link, dirp.local_alias, dirp.preferences
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
@ -1502,6 +1546,8 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id)
LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id
LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id)
LEFT JOIN group_members dirm ON dirm.group_member_id = i.item_direct_group_member_id
LEFT JOIN contact_profiles dirp ON dirp.contact_profile_id = COALESCE(dirm.member_profile_id, dirm.contact_profile_id)
WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ?
|]
(userId, groupId, itemId)

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

@ -79,6 +79,7 @@ import Simplex.Chat.Migrations.M20230814_indexes
import Simplex.Chat.Migrations.M20230827_file_encryption
import Simplex.Chat.Migrations.M20230829_connections_chat_vrange
import Simplex.Chat.Migrations.M20230903_connections_to_subscribe
import Simplex.Chat.Migrations.M20230904_item_direct_group_member_id
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@ -157,7 +158,8 @@ schemaMigrations =
("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
("20230827_file_encryption", m20230827_file_encryption, Just down_m20230827_file_encryption),
("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange),
("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe)
("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe),
("20230904_item_direct_group_member_id", m20230904_item_direct_group_member_id, Just down_m20230904_item_direct_group_member_id)
]
-- | The list of migrations in ascending order by date

18
src/Simplex/Chat/Terminal/Input.hs
View file

@ -73,19 +73,19 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
Right SendMessageBroadcast {} -> True
_ -> False
startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO ()
startLiveMessage (Right (SendLiveMessage chatName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do
startLiveMessage (Right (SendLiveMessage sendName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do
whenM (isNothing <$> readTVarIO liveMessageState) $ do
let s = T.unpack msg
int = case cType of SCTGroup -> 5000000; _ -> 3000000 :: Int
liveThreadId <- mkWeakThreadId =<< runLiveMessage int `forkFinally` const (atomically $ writeTVar liveMessageState Nothing)
promptThreadId <- mkWeakThreadId =<< forkIO blinkLivePrompt
atomically $ do
let lm = LiveMessage {chatName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId}
let lm = LiveMessage {sendName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId}
writeTVar liveMessageState (Just lm)
modifyTVar termState $ \ts -> ts {inputString = s, inputPosition = length s, inputPrompt = liveInputPrompt lm}
where
liveInputPrompt LiveMessage {chatName = n, livePrompt} =
"> " <> chatNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] "
liveInputPrompt LiveMessage {sendName = n, livePrompt} =
"> " <> sendNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] "
runLiveMessage :: Int -> IO ()
runLiveMessage int = do
threadDelay int
@ -123,8 +123,8 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
startLiveMessage _ _ = pure ()
sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO ChatResponse
sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do
let cmd = UpdateLiveMessage chatName chatItemId live $ T.pack sentMsg
sendUpdatedLiveMessage cc sentMsg LiveMessage {sendName, chatItemId} live = do
let cmd = UpdateLiveMessage sendName chatItemId live $ T.pack sentMsg
either (CRChatCmdError Nothing) id <$> runExceptT (processChatCommand cmd) `runReaderT` cc
runTerminalInput :: ChatTerminal -> ChatController -> IO ()
@ -174,14 +174,14 @@ receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@C
let s = inputString ts
lm_ <- readTVar liveMessageState
case lm_ of
Just LiveMessage {chatName}
Just LiveMessage {sendName}
| live -> do
writeTVar termState ts' {previousInput}
writeTBQueue inputQ $ "/live " <> chatNameStr chatName
writeTBQueue inputQ $ "/live " <> sendNameStr sendName
| otherwise ->
writeTVar termState ts' {inputPrompt = "> ", previousInput}
where
previousInput = chatNameStr chatName <> " " <> s
previousInput = sendNameStr sendName <> " " <> s
_
| live -> when (isSend s) $ do
writeTVar termState ts' {previousInput = s}

2
src/Simplex/Chat/Terminal/Output.hs
View file

@ -55,7 +55,7 @@ data AutoCompleteState = ACState
}
data LiveMessage = LiveMessage
{ chatName :: ChatName,
{ sendName :: SendName,
chatItemId :: ChatItemId,
livePrompt :: Bool,
sentMsg :: String,

4
src/Simplex/Chat/Types.hs
View file

@ -330,12 +330,12 @@ data GroupSummary = GroupSummary
instance ToJSON GroupSummary where toEncoding = J.genericToEncoding J.defaultOptions
data ContactOrGroup = CGContact Contact | CGGroup Group
data ContactOrGroup = CGContact Contact | CGGroup GroupInfo
contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
contactAndGroupIds = \case
CGContact Contact {contactId} -> (Just contactId, Nothing)
CGGroup (Group GroupInfo {groupId} _) -> (Nothing, Just groupId)
CGGroup GroupInfo {groupId} -> (Nothing, Just groupId)
-- TODO when more settings are added we should create another type to allow partial setting updates (with all Maybe properties)
data ChatSettings = ChatSettings

123
src/Simplex/Chat/View.hs
View file

@ -322,14 +322,35 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
testViewChat :: AChat -> [StyledString]
testViewChat (AChat _ Chat {chatInfo, chatItems}) = [sShow $ map toChatView chatItems]
where
toChatView :: CChatItem c -> ((Int, Text), Maybe (Int, Text), Maybe String)
toChatView ci@(CChatItem dir ChatItem {quotedItem, file}) =
((msgDirectionInt $ toMsgDirection dir, testViewItem ci (chatInfoMembership chatInfo)), qItem, fPath)
toChatView :: CChatItem c -> ((Int, String, Text), Maybe (Int, String, Text), Maybe String)
toChatView ci@(CChatItem dir ChatItem {chatDir, quotedItem, file}) =
(item, qItem, fPath)
where
item =
( msgDirectionInt $ toMsgDirection dir,
directMemberName,
testViewItem ci (chatInfoMembership chatInfo)
)
directMemberName = case chatDir of
CIGroupSnd (Just GroupMember {localDisplayName = n}) -> T.unpack n
CIGroupRcv GroupMember {localDisplayName = n} MSDirect -> T.unpack n
_ -> ""
qItem = case quotedItem of
Nothing -> Nothing
Just CIQuote {chatDir = quoteDir, content} ->
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
Just
( msgDirectionInt $ quoteMsgDirection quoteDir,
qMsgScope,
msgContentText content
)
where
qMsgScope = case quoteDir of
CIQGroupSnd ms -> msgScopeText ms
CIQGroupRcv _ ms -> msgScopeText ms
_ -> ""
msgScopeText ms = case ms of
MSGroup -> "group"
MSDirect -> "direct"
fPath = case file of
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
_ -> Nothing
@ -380,7 +401,7 @@ viewUsersList = mapMaybe userInfo . sortOn ldn
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
(GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _ _) -> True
_ -> False
viewGroupSubscribed :: GroupInfo -> [StyledString]
@ -403,8 +424,9 @@ viewChats ts tz = concatMap chatPreview . reverse
where
chatName = case chat of
DirectChat ct -> [" " <> ttyToContact' ct]
GroupChat g -> [" " <> ttyToGroup g]
GroupChat g -> [" " <> ttyToGroup' g]
_ -> []
ttyToGroup' g@GroupInfo {localDisplayName = n} = membershipIncognito g <> ttyTo ("#" <> n <> " ")
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file} doShow ts tz =
@ -426,20 +448,20 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file}
where
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupSnd -> case content of
CIGroupSnd directMember -> case content of
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
CISndGroupInvitation {} -> showSndItemProhibited to
_ -> showSndItem to
where
to = ttyToGroup g
CIGroupRcv m -> case content of
to = ttyToGroup g directMember
CIGroupRcv m msgScope -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m msgScope) quote meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroup g m
from = ttyFromGroup g m msgScope
where
quote = maybe [] (groupQuote g) quotedItem
_ -> []
@ -531,18 +553,18 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive}
where
quote = maybe [] (directQuote chatDir) quotedItem
GroupChat g -> case chatDir of
CIGroupRcv m -> case content of
CIGroupRcv m msgScope -> case content of
CIRcvMsgContent mc
| itemLive == Just True && not liveItems -> []
| otherwise -> viewReceivedUpdatedMessage from quote mc ts tz meta
_ -> []
where
from = if itemEdited then ttyFromGroupEdited g m else ttyFromGroup g m
CIGroupSnd -> case content of
from = if itemEdited then ttyFromGroupEdited g m msgScope else ttyFromGroup g m msgScope
CIGroupSnd directMember -> case content of
CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts tz meta
_ -> []
where
to = if itemEdited then ttyToGroupEdited g else ttyToGroup g
to = if itemEdited then ttyToGroupEdited g directMember else ttyToGroup g directMember
where
quote = maybe [] (groupQuote g) quotedItem
_ -> []
@ -567,7 +589,8 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem
GroupChat g -> case ciMsgContent deletedContent of
Just mc ->
let m = chatItemMember g ci
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
msgScope = directMemberToMsgScope $ ciDirDirectMember chatDir
in viewReceivedMessage (ttyFromGroupDeleted g m msgScope deletedText_) [] mc ts tz meta
_ -> prohibited
_ -> prohibited
where
@ -586,14 +609,14 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md
where
from = ttyFromContact c
reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">"
(GroupChat g, CIGroupRcv m) -> case ciMsgContent content of
(GroupChat g, CIGroupRcv m messageScope) -> case ciMsgContent content of
Just mc -> view from $ reactionMsg mc
_ -> []
where
from = ttyFromGroup g m
from = ttyFromGroup g m messageScope
reactionMsg mc = quoteText mc . ttyQuotedMember . Just $ sentByMember' g itemDir
(_, CIDirectSnd) -> [sentText]
(_, CIGroupSnd) -> [sentText]
(_, CIGroupSnd _) -> [sentText]
where
view from msg
| showReactions = viewReceivedReaction from msg reactionText ts tz sentAt
@ -621,13 +644,13 @@ groupQuote g CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc . ttyQu
sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember
sentByMember GroupInfo {membership} = \case
CIQGroupSnd -> Just membership
CIQGroupRcv m -> m
CIQGroupSnd _ -> Just membership
CIQGroupRcv m _ -> m
sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> GroupMember
sentByMember' GroupInfo {membership} = \case
CIGroupSnd -> membership
CIGroupRcv m -> m
CIGroupSnd _ -> membership
CIGroupRcv m _ -> m
quoteText :: MsgContent -> StyledString -> [StyledString]
quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc
@ -1319,8 +1342,9 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
uploadingFile :: StyledString -> AChatItem -> [StyledString]
uploadingFile status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd}) =
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c]
uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd}) =
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g]
uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd directMember}) =
let forMember = maybe "" (\GroupMember {localDisplayName = m} -> styled (colored Blue) $ " @" <> m <> " (direct)") directMember
in [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g <> forMember]
uploadingFile status _ = [status <> " uploading file"] -- shouldn't happen
sndFile :: SndFileTransfer -> StyledString
@ -1352,7 +1376,7 @@ savingFile' :: Bool -> AChatItem -> [StyledString]
savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath cfArgs_)}, chatDir}) =
let from = case (chat, chatDir) of
(DirectChat Contact {localDisplayName = c}, CIDirectRcv) -> " from " <> ttyContact c
(_, CIGroupRcv GroupMember {localDisplayName = m}) -> " from " <> ttyContact m
(_, CIGroupRcv GroupMember {localDisplayName = m} _) -> " from " <> ttyContact m
_ -> ""
in ["saving file " <> sShow fileId <> from <> " to " <> plain filePath] <> cfArgsStr
where
@ -1366,7 +1390,7 @@ savingFile' _ _ = ["saving file"] -- shouldn't happen
receivingFile_' :: StyledString -> AChatItem -> [StyledString]
receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) =
[status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact c]
receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) =
receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m} _}) =
[status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact m]
receivingFile_' status _ = [status <> " receiving file"] -- shouldn't happen
@ -1582,7 +1606,7 @@ viewChatError logLevel = \case
CEXFTPSndFile fileId aFileId e -> ["error sending XFTP file " <> sShow fileId <> ", agent file id " <> sShow aFileId <> ": " <> sShow e | logLevel == CLLError]
CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"]
CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
CEInvalidQuote -> ["cannot reply to this message"]
CEInvalidQuote -> ["invalid message reply"]
CEInvalidChatItemUpdate -> ["cannot update this item"]
CEInvalidChatItemDelete -> ["cannot delete this item"]
CEHasCurrentCall -> ["call already in progress"]
@ -1597,6 +1621,7 @@ viewChatError logLevel = \case
CEAgentCommandError e -> ["agent command error: " <> plain e]
CEInvalidFileDescription e -> ["invalid file description: " <> plain e]
CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"]
CEPeerChatVRangeIncompatible -> ["peer chat protocol version range incompatible"]
CEInternalError e -> ["internal chat error: " <> plain e]
CEException e -> ["exception: " <> plain e]
-- e -> ["chat error: " <> sShow e]
@ -1737,19 +1762,24 @@ ttyFullGroup :: GroupInfo -> StyledString
ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} =
ttyGroup g <> optFullName g fullName
ttyFromGroup :: GroupInfo -> GroupMember -> StyledString
ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m)
ttyFromGroup :: GroupInfo -> GroupMember -> MessageScope -> StyledString
ttyFromGroup g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms)
ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString
ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ")
ttyFromGroupEdited :: GroupInfo -> GroupMember -> MessageScope -> StyledString
ttyFromGroupEdited g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> "[edited] ")
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString
ttyFromGroupDeleted g m deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> MessageScope -> Maybe Text -> StyledString
ttyFromGroupDeleted g m ms deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
fromGroup_ :: GroupInfo -> GroupMember -> Text
fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} =
"#" <> g <> " " <> m <> "> "
fromGroup_ :: GroupInfo -> GroupMember -> MessageScope -> Text
fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} ms =
"#" <> g <> " " <> m <> fromGroupScope ms <> "> "
fromGroupScope :: MessageScope -> Text
fromGroupScope = \case
MSGroup -> ""
MSDirect -> " (direct)"
ttyFrom :: Text -> StyledString
ttyFrom = styled $ colored Yellow
@ -1757,13 +1787,18 @@ ttyFrom = styled $ colored Yellow
ttyTo :: Text -> StyledString
ttyTo = styled $ colored Cyan
ttyToGroup :: GroupInfo -> StyledString
ttyToGroup g@GroupInfo {localDisplayName = n} =
membershipIncognito g <> ttyTo ("#" <> n <> " ")
ttyToGroup :: GroupInfo -> Maybe GroupMember -> StyledString
ttyToGroup g@GroupInfo {localDisplayName = n} dirMem =
membershipIncognito g <> ttyTo ("#" <> n <> toDirectMember dirMem <> " ")
ttyToGroupEdited :: GroupInfo -> StyledString
ttyToGroupEdited g@GroupInfo {localDisplayName = n} =
membershipIncognito g <> ttyTo ("#" <> n <> " [edited] ")
ttyToGroupEdited :: GroupInfo -> Maybe GroupMember -> StyledString
ttyToGroupEdited g@GroupInfo {localDisplayName = n} dirMem =
membershipIncognito g <> ttyTo ("#" <> n <> toDirectMember dirMem <> " [edited] ")
toDirectMember :: Maybe GroupMember -> Text
toDirectMember = \case
Nothing -> ""
Just GroupMember {localDisplayName = m} -> " @" <> m <> " (direct)"
ttyFilePath :: FilePath -> StyledString
ttyFilePath = plain

2
tests/ChatClient.hs
View file

@ -259,7 +259,7 @@ getTermLine cc =
Just s -> do
-- remove condition to always echo virtual terminal
when (printOutput cc) $ do
-- when True $ do
-- when True $ do
name <- userName cc
putStrLn $ name <> ": " <> s
pure s

577
tests/ChatTests/Groups.hs
View file

@ -8,8 +8,9 @@ import ChatTests.Utils
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Monad (when)
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Simplex.Chat.Controller (ChatConfig (..))
import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..))
import Simplex.Chat.Protocol (supportedChatVRange)
import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
import Simplex.Chat.Types (GroupMemberRole (..))
@ -81,6 +82,21 @@ chatGroupTests = do
testNoDirect4 _1 _0 _1 False False False -- False False True
testNoDirect4 _1 _1 _0 False False False
testNoDirect4 _1 _1 _1 False False False
describe "group direct messages" $ do
it "should send group direct messages" testGroupDirectMessages
it "should create group direct messages chat items" testGroupDirectMessagesItems
it "should send group direct quotes" testGroupDirectQuotes
it "should create group direct quotes chat items" testGroupDirectQuotesItems
it "should send group direct XFTP files" testGroupDirectFilesXFTP
it "should send group direct SMP files" testGroupDirectFilesSMP
it "should cancel sent group direct XFTP file" testGroupDirectCancelFileXFTP
it "should send group direct quotes with files" testGroupDirectQuotesFiles
it "should update group direct message" testGroupDirectUpdate
it "should delete group direct message" testGroupDirectDelete
it "should send group direct live message" testGroupDirectLiveMessage
it "should send group direct message reactions" testGroupDirectReactions
it "should prohibit group direct messages based on preference" testGroupDirectProhibitPreference
it "should prohibit group direct messages if peer version doesn't support" testGroupDirectProhibitNotSupported
where
_0 = supportedChatVRange -- don't create direct connections
_1 = groupCreateDirectVRange
@ -804,7 +820,7 @@ testGroupMessageQuotedReply =
(bob <# "#team alice> hello! how are you?")
(cath <# "#team alice> hello! how are you?")
threadDelay 1000000
bob `send` "> #team @alice (hello) hello, all good, you?"
bob `send` "> #team >@alice (hello) hello, all good, you?"
bob <# "#team > alice hello! how are you?"
bob <## " hello, all good, you?"
concurrently_
@ -819,7 +835,7 @@ testGroupMessageQuotedReply =
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 `send` "> #team >@bob (hello, all good) will tell more"
bob <# "#team > bob hello, all good, you?"
bob <## " will tell more"
concurrently_
@ -835,7 +851,7 @@ testGroupMessageQuotedReply =
alice #$> ("/_get chat #1 count=1", chat', [((0, "will tell more"), Just (0, "hello, all good, you?"))])
cath #$> ("/_get chat #1 count=1", chat', [((0, "will tell more"), Just (0, "hello, all good, you?"))])
threadDelay 1000000
cath `send` "> #team bob (hello) hi there!"
cath `send` "> #team >@bob (hello) hi there!"
cath <# "#team > bob hello, all good, you?"
cath <## " hi there!"
concurrently_
@ -891,7 +907,7 @@ testGroupMessageUpdate =
threadDelay 1000000
-- alice, bob: msg id 6, cath: msg id 5
bob `send` "> #team @alice (hey) hi alice"
bob `send` "> #team >@alice (hey) hi alice"
bob <# "#team > alice hey 👋"
bob <## " hi alice"
concurrently_
@ -918,7 +934,7 @@ testGroupMessageUpdate =
alice #$> ("/_update item #1 " <> msgItemId2 <> " text updating bob's message", id, "cannot update this item")
threadDelay 1000000
cath `send` "> #team @alice (greetings) greetings!"
cath `send` "> #team >@alice (greetings) greetings!"
cath <# "#team > alice greetings 🤝"
cath <## " greetings!"
concurrently_
@ -994,7 +1010,6 @@ testGroupMessageEditHistory =
alice ##> ("/_update item #1 " <> aliceItemId <> " text hey there")
alice <# "#team [edited] hey there"
bob <# "#team alice> [edited] hey there"
alice ##> "/item info #team hey"
alice <##. "sent at: "
@ -1004,10 +1019,7 @@ testGroupMessageEditHistory =
alice .<## ": hey 👋"
alice .<## ": hello!"
bob ##> "/item info #team hey"
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hey there"
bob <## "message not found by text: hey"
testGroupMessageDelete :: HasCallStack => FilePath -> IO ()
testGroupMessageDelete =
@ -1031,7 +1043,7 @@ testGroupMessageDelete =
threadDelay 1000000
-- alice: msg id 5, bob: msg id 6, cath: msg id 5
bob `send` "> #team @alice (hello) hi alic"
bob `send` "> #team >@alice (hello) hi alic"
bob <# "#team > alice hello!"
bob <## " hi alic"
concurrently_
@ -1060,14 +1072,10 @@ testGroupMessageDelete =
bob ##> ("/_update item #1 " <> msgItemId3 <> " text hi alice")
bob <# "#team [edited] > alice hello!"
bob <## " hi alice"
concurrently_
(alice <# "#team bob> [edited] hi alice")
( do
cath <# "#team bob> [edited] > alice hello!"
cath <## " hi alice"
)
cath <# "#team bob> [edited] > alice hello!"
cath <## " hi alice"
alice #$> ("/_get chat #1 count=1", chat', [((0, "hi alice"), Nothing)])
alice #$> ("/_get chat #1 count=1", chat', [((0, "connected"), Nothing)])
bob #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!"))])
cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alice"), Just (0, "hello!"))])
@ -2686,3 +2694,534 @@ testNoGroupDirectConns4Members hostVRange mem2VRange mem3VRange mem4VRange noCon
cc1 <## ("no contact " <> name2)
cc2 ##> ("@" <> name1 <> " hi")
cc2 <## ("no contact " <> name1)
testGroupDirectMessages :: HasCallStack => FilePath -> IO ()
testGroupDirectMessages =
testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do
createGroup3 "team" alice bob cath
connectUsers alice dan
addMember "team" alice dan GRMember
dan ##> "/j team"
concurrentlyN_
[ alice <## "#team: dan joined the group",
do
dan <## "#team: you joined the group"
dan
<### [ "#team: member bob (Bob) is connected",
"#team: member cath (Catherine) is connected"
],
aliceAddedDan bob,
aliceAddedDan cath
]
alice #> "#team hi"
bob <# "#team alice> hi"
cath <# "#team alice> hi"
dan <# "#team alice> hi"
alice `send` "#team @bob hi bob"
alice <# "#team @bob (direct) hi bob"
bob <# "#team alice (direct)> hi bob"
bob `send` "#team @alice hi alice"
bob <# "#team @alice (direct) hi alice"
alice <# "#team bob (direct)> hi alice"
dan #> "#team hello"
alice <# "#team dan> hello"
bob <# "#team dan> hello"
cath <# "#team dan> hello"
bob `send` "#team @cath hi cath"
bob <# "#team @cath (direct) hi cath"
cath <# "#team bob (direct)> hi cath"
cath `send` "#team @bob hello bob"
cath <# "#team @bob (direct) hello bob"
bob <# "#team cath (direct)> hello bob"
where
aliceAddedDan :: HasCallStack => TestCC -> IO ()
aliceAddedDan cc = do
cc <## "#team: alice added dan (Daniel) to the group (connecting...)"
cc <## "#team: new member dan is connected"
testGroupDirectMessagesItems :: HasCallStack => FilePath -> IO ()
testGroupDirectMessagesItems =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
alice #> "#team hi"
bob <# "#team alice> hi"
cath <# "#team alice> hi"
threadDelay 1000000
alice `send` "#team @bob hi bob"
alice <# "#team @bob (direct) hi bob"
bob <# "#team alice (direct)> hi bob"
threadDelay 1000000
bob `send` "#team @alice hi alice"
bob <# "#team @alice (direct) hi alice"
alice <# "#team bob (direct)> hi alice"
threadDelay 1000000
alice #$> ("/_get chat #1 count=4", mapChat, [(0, "", "connected"), (1, "", "hi"), (1, "bob", "hi bob"), (0, "bob", "hi alice")])
bob #$> ("/_get chat #1 count=4", mapChat, [(0, "", "connected"), (0, "", "hi"), (0, "alice", "hi bob"), (1, "alice", "hi alice")])
cath #$> ("/_get chat #1 count=2", mapChat, [(0, "", "connected"), (0, "", "hi")])
where
mapChat = map (\(a, _, _) -> a) . chat'''
testGroupDirectQuotes :: HasCallStack => FilePath -> IO ()
testGroupDirectQuotes =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
alice #> "#team 1-g-a"
bob <# "#team alice> 1-g-a"
cath <# "#team alice> 1-g-a"
bob #> "#team 2-g-b"
alice <# "#team bob> 2-g-b"
cath <# "#team bob> 2-g-b"
cath #> "#team 3-g-c"
alice <# "#team cath> 3-g-c"
bob <# "#team cath> 3-g-c"
alice `send` "#team @bob 4-p-ab"
alice <# "#team @bob (direct) 4-p-ab"
bob <# "#team alice (direct)> 4-p-ab"
bob `send` "#team @alice 5-p-ba"
bob <# "#team @alice (direct) 5-p-ba"
alice <# "#team bob (direct)> 5-p-ba"
alice `send` "#team @cath 6-p-ac"
alice <# "#team @cath (direct) 6-p-ac"
cath <# "#team alice (direct)> 6-p-ac"
cath `send` "#team @alice 7-p-ca"
cath <# "#team @alice (direct) 7-p-ca"
alice <# "#team cath (direct)> 7-p-ca"
-- quotes
alice `send` "> #team @bob (1-g-a) 8-pq-ab"
alice <# "#team @bob (direct) > alice 1-g-a"
alice <## " 8-pq-ab"
bob <# "#team alice (direct)> > alice 1-g-a"
bob <## " 8-pq-ab"
alice `send` "> #team @bob (2-g-b) 9-pq-ab"
alice <# "#team @bob (direct) > bob 2-g-b"
alice <## " 9-pq-ab"
bob <# "#team alice (direct)> > bob 2-g-b"
bob <## " 9-pq-ab"
alice `send` "> #team >@cath @bob (3-g-c) 10-pq-ab"
alice <# "#team @bob (direct) > cath 3-g-c"
alice <## " 10-pq-ab"
bob <# "#team alice (direct)> > cath 3-g-c"
bob <## " 10-pq-ab"
alice `send` "> #team @bob (4-p-ab) 11-pq-ab"
alice <# "#team @bob (direct) > alice 4-p-ab"
alice <## " 11-pq-ab"
bob <# "#team alice (direct)> > alice 4-p-ab"
bob <## " 11-pq-ab"
alice `send` "> #team >@bob @bob (5-p-ba) 12-pq-ab"
alice <# "#team @bob (direct) > bob 5-p-ba"
alice <## " 12-pq-ab"
bob <# "#team alice (direct)> > bob 5-p-ba"
bob <## " 12-pq-ab"
alice `send` "> #team @bob (6-p-ac) 13-pq-ab"
alice <## "> #team @bob (6-p-ac) 13-pq-ab"
alice <## "invalid message reply"
alice `send` "> #team @bob (7-p-ca) 14-pq-ab"
alice <## "> #team @bob (7-p-ca) 14-pq-ab"
alice <## "invalid message reply"
alice `send` "> #team (4-p-ab) 15-gq-a"
alice <## "> #team (4-p-ab) 15-gq-a"
alice <## "invalid message reply"
alice `send` "> #team (5-p-ba) 16-gq-a"
alice <## "> #team (5-p-ba) 16-gq-a"
alice <## "invalid message reply"
testGroupDirectQuotesItems :: HasCallStack => FilePath -> IO ()
testGroupDirectQuotesItems =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
alice #> "#team 1-g-a"
bob <# "#team alice> 1-g-a"
cath <# "#team alice> 1-g-a"
alice `send` "#team @bob 2-p-ab"
alice <# "#team @bob (direct) 2-p-ab"
bob <# "#team alice (direct)> 2-p-ab"
bob `send` "#team @alice 3-p-ba"
bob <# "#team @alice (direct) 3-p-ba"
alice <# "#team bob (direct)> 3-p-ba"
threadDelay 1000000
-- quotes
alice `send` "> #team @bob (1-g-a) 4-pq-ab"
alice <# "#team @bob (direct) > alice 1-g-a"
alice <## " 4-pq-ab"
bob <# "#team alice (direct)> > alice 1-g-a"
bob <## " 4-pq-ab"
threadDelay 1000000
alice `send` "> #team @bob (2-p-ab) 5-pq-ab"
alice <# "#team @bob (direct) > alice 2-p-ab"
alice <## " 5-pq-ab"
bob <# "#team alice (direct)> > alice 2-p-ab"
bob <## " 5-pq-ab"
threadDelay 1000000
alice `send` "> #team >@bob @bob (3-p-ba) 6-pq-ab"
alice <# "#team @bob (direct) > bob 3-p-ba"
alice <## " 6-pq-ab"
bob <# "#team alice (direct)> > bob 3-p-ba"
bob <## " 6-pq-ab"
alice
#$> ( "/_get chat #1 count=3",
mapChat,
[ ((1, "bob", "4-pq-ab"), Just (1, "group", "1-g-a")),
((1, "bob", "5-pq-ab"), Just (1, "direct", "2-p-ab")),
((1, "bob", "6-pq-ab"), Just (0, "direct", "3-p-ba"))
]
)
bob
#$> ( "/_get chat #1 count=3",
mapChat,
[ ((0, "alice", "4-pq-ab"), Just (0, "group", "1-g-a")),
((0, "alice", "5-pq-ab"), Just (0, "direct", "2-p-ab")),
((0, "alice", "6-pq-ab"), Just (1, "direct", "3-p-ba"))
]
)
where
mapChat = map (\(a, b, _) -> (a, b)) . chat'''
testGroupDirectFilesXFTP :: HasCallStack => FilePath -> IO ()
testGroupDirectFilesXFTP =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do
withXFTPServer $ do
createGroup3 "team" alice bob cath
threadDelay 1000000
alice `send` "/f #team @bob ./tests/fixtures/test.pdf"
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
alice <## "use /fc 1 to cancel sending"
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)"
bob ##> "/fr 1 ./tests/tmp"
bob
<### [ "saving file 1 from alice to ./tests/tmp/test.pdf",
"started receiving file 1 (test.pdf) from alice"
]
bob <## "completed receiving file 1 (test.pdf) from alice"
src <- B.readFile "./tests/fixtures/test.pdf"
dest <- B.readFile "./tests/tmp/test.pdf"
dest `shouldBe` src
cath <// 50000
cath ##> "/fr 1 ./tests/tmp"
cath <##. "chat db error: SEUserNotFoundByFileId"
alice `send` "/f #team @cath ./tests/fixtures/test.jpg"
alice <# "/f #team @cath (direct) ./tests/fixtures/test.jpg"
alice <## "use /fc 2 to cancel sending"
cath <# "#team alice (direct)> sends file test.jpg (136.5 KiB / 139737 bytes)"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
alice <## "completed uploading file 2 (test.jpg) for #team @cath (direct)"
cath ##> "/fr 1 ./tests/tmp"
cath
<### [ "saving file 1 from alice to ./tests/tmp/test.jpg",
"started receiving file 1 (test.jpg) from alice"
]
cath <## "completed receiving file 1 (test.jpg) from alice"
src2 <- B.readFile "./tests/fixtures/test.jpg"
dest2 <- B.readFile "./tests/tmp/test.jpg"
dest2 `shouldBe` src2
bob <// 50000
alice #$> ("/_get chat #1 count=2", mapChat, [((1, "bob", ""), Just "./tests/fixtures/test.pdf"), ((1, "cath", ""), Just "./tests/fixtures/test.jpg")])
bob #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.pdf")])
cath #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.jpg")])
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
mapChat = map (\(a, _, c) -> (a, c)) . chat'''
testGroupDirectFilesSMP :: HasCallStack => FilePath -> IO ()
testGroupDirectFilesSMP =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
alice `send` "/f #team @bob ./tests/fixtures/test.pdf"
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
alice <## "use /fc 1 to cancel sending"
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob ##> "/fr 1 ./tests/tmp"
bob <## "saving file 1 from alice to ./tests/tmp/test.pdf"
concurrently_
(alice <## "started sending file 1 (test.pdf) to bob")
(bob <## "started receiving file 1 (test.pdf) from alice")
concurrently_
(alice <## "completed sending file 1 (test.pdf) to bob")
(bob <## "completed receiving file 1 (test.pdf) from alice")
src <- B.readFile "./tests/fixtures/test.pdf"
dest <- B.readFile "./tests/tmp/test.pdf"
dest `shouldBe` src
cath <// 50000
cath ##> "/fr 1 ./tests/tmp"
cath <##. "chat db error: SEUserNotFoundByFileId"
alice `send` "/f #team @cath ./tests/fixtures/test.jpg"
alice <# "/f #team @cath (direct) ./tests/fixtures/test.jpg"
alice <## "use /fc 2 to cancel sending"
cath <# "#team alice (direct)> sends file test.jpg (136.5 KiB / 139737 bytes)"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
cath ##> "/fr 1 ./tests/tmp"
cath <## "saving file 1 from alice to ./tests/tmp/test.jpg"
concurrently_
(alice <## "started sending file 2 (test.jpg) to cath")
(cath <## "started receiving file 1 (test.jpg) from alice")
concurrently_
(alice <## "completed sending file 2 (test.jpg) to cath")
(cath <## "completed receiving file 1 (test.jpg) from alice")
src2 <- B.readFile "./tests/fixtures/test.jpg"
dest2 <- B.readFile "./tests/tmp/test.jpg"
dest2 `shouldBe` src2
bob <// 50000
alice #$> ("/_get chat #1 count=2", mapChat, [((1, "bob", ""), Just "./tests/fixtures/test.pdf"), ((1, "cath", ""), Just "./tests/fixtures/test.jpg")])
bob #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.pdf")])
cath #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.jpg")])
where
mapChat = map (\(a, _, c) -> (a, c)) . chat'''
testGroupDirectCancelFileXFTP :: HasCallStack => FilePath -> IO ()
testGroupDirectCancelFileXFTP =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do
withXFTPServer $ do
createGroup3 "team" alice bob cath
alice `send` "/f #team @bob ./tests/fixtures/test.pdf"
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
alice <## "use /fc 1 to cancel sending"
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)"
cath <// 50000
alice ##> "/fc 1"
alice <## "cancelled sending file 1 (test.pdf) to bob"
bob <## "alice cancelled sending file 1 (test.pdf)"
cath <// 50000
bob ##> "/fr 1 ./tests/tmp"
bob <## "file cancelled: test.pdf"
cath ##> "/fr 1 ./tests/tmp"
cath <##. "chat db error: SEUserNotFoundByFileId"
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupDirectQuotesFiles :: HasCallStack => FilePath -> IO ()
testGroupDirectQuotesFiles =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do
withXFTPServer $ do
createGroup3 "team" alice bob cath
threadDelay 1000000
bob `send` "#team @alice hi alice"
bob <# "#team @alice (direct) hi alice"
alice <# "#team bob (direct)> hi alice"
threadDelay 1000000
msgItemId1 <- lastItemId alice
alice ##> ("/_send #1 @2 json {\"filePath\": \"./tests/fixtures/test.pdf\", \"quotedItemId\": " <> msgItemId1 <> ", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}")
alice <# "#team @bob (direct) > bob hi alice"
alice <## " hey bob"
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
alice <## "use /fc 1 to cancel sending"
bob <# "#team alice (direct)> > bob hi alice"
bob <## " hey bob"
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)"
bob ##> "/fr 1 ./tests/tmp"
bob
<### [ "saving file 1 from alice to ./tests/tmp/test.pdf",
"started receiving file 1 (test.pdf) from alice"
]
bob <## "completed receiving file 1 (test.pdf) from alice"
src <- B.readFile "./tests/fixtures/test.pdf"
dest <- B.readFile "./tests/tmp/test.pdf"
dest `shouldBe` src
cath <// 50000
cath ##> "/fr 1 ./tests/tmp"
cath <##. "chat db error: SEUserNotFoundByFileId"
alice
#$> ( "/_get chat #1 count=2",
chat''',
[ ((0, "bob", "hi alice"), Nothing, Nothing),
((1, "bob", "hey bob"), Just (0, "direct", "hi alice"), Just "./tests/fixtures/test.pdf")
]
)
bob
#$> ( "/_get chat #1 count=2",
chat''',
[ ((1, "alice", "hi alice"), Nothing, Nothing),
((0, "alice", "hey bob"), Just (1, "direct", "hi alice"), Just "./tests/tmp/test.pdf")
]
)
cath #$> ("/_get chat #1 count=1", chat''', [((0, "", "connected"), Nothing, Nothing)])
where
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
testGroupDirectUpdate :: HasCallStack => FilePath -> IO ()
testGroupDirectUpdate =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
alice `send` "#team @bob hi bob"
alice <# "#team @bob (direct) hi bob"
bob <# "#team alice (direct)> hi bob"
msgItemId1 <- lastItemId alice
alice ##> ("/_update item #1 " <> msgItemId1 <> " text hey 👋")
alice <# "#team @bob (direct) [edited] hey 👋"
bob <# "#team alice (direct)> [edited] hey 👋"
cath <// 50000
alice ##> "! #team (hey 👋) hello there"
alice <# "#team @bob (direct) [edited] hello there"
bob <# "#team alice (direct)> [edited] hello there"
cath <// 50000
testGroupDirectDelete :: HasCallStack => FilePath -> IO ()
testGroupDirectDelete =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
alice `send` "#team @bob hi bob"
alice <# "#team @bob (direct) hi bob"
bob <# "#team alice (direct)> hi bob"
msgItemId1 <- lastItemId alice
alice #$> ("/_delete item #1 " <> msgItemId1 <> " broadcast", id, "message marked deleted")
bob <# "#team alice (direct)> [marked deleted] hi bob"
cath <// 50000
testGroupDirectLiveMessage :: HasCallStack => FilePath -> IO ()
testGroupDirectLiveMessage =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
alice `send` "/live #team @bob hello"
msgItemId1 <- lastItemId alice
bob <#. "#team alice (direct)> [LIVE started]"
alice ##> ("/_update item #1 " <> msgItemId1 <> " text hello there")
alice <# "#team @bob (direct) [LIVE] hello there"
bob <# "#team alice (direct)> [LIVE ended] hello there"
cath <// 50000
testGroupDirectReactions :: HasCallStack => FilePath -> IO ()
testGroupDirectReactions =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3 "team" alice bob cath
alice `send` "#team @bob hi bob"
alice <# "#team @bob (direct) hi bob"
bob <# "#team alice (direct)> hi bob"
bob ##> "+1 #team hi"
bob <## "added 👍"
alice <# "#team bob (direct)> > alice hi bob"
alice <## " + 👍"
cath <// 50000
alice ##> "+^ #team hi"
alice <## "added 🚀"
bob <# "#team alice (direct)> > alice hi bob"
bob <## " + 🚀"
cath <// 50000
testGroupDirectProhibitPreference :: HasCallStack => FilePath -> IO ()
testGroupDirectProhibitPreference =
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
createGroup3' "team" alice bob cath GRMember
alice ##> "/set direct #team off"
alice <## "updated group preferences:"
alice <## "Direct messages: off"
directProhibited bob
directProhibited cath
bob ##> "#team @cath hi cath"
bob <## "bad chat command: direct messages not allowed"
cath ##> "#team @bob hi cath"
cath <## "bad chat command: direct messages not allowed"
alice ##> "/mr team bob admin"
alice <## "#team: you changed the role of bob from member to admin"
concurrentlyN_
[ bob <## "#team: alice changed your role from member to admin",
cath <## "#team: alice changed the role of bob from member to admin"
]
-- admin can send & can send to admin
bob `send` "#team @cath hi cath, as admin"
bob <# "#team @cath (direct) hi cath, as admin"
cath <# "#team bob (direct)> hi cath, as admin"
cath `send` "#team @bob hi bob, to admin"
cath <# "#team @bob (direct) hi bob, to admin"
bob <# "#team cath (direct)> hi bob, to admin"
where
directProhibited :: HasCallStack => TestCC -> IO ()
directProhibited cc = do
cc <## "alice updated group #team:"
cc <## "updated group preferences:"
cc <## "Direct messages: off"
testGroupDirectProhibitNotSupported :: HasCallStack => FilePath -> IO ()
testGroupDirectProhibitNotSupported tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
withNewTestChatCfg tmp testCfg {chatVRange = mkVersionRange 1 1} "cath" cathProfile $ \cath -> do
createGroup3 "team" alice bob cath
bob ##> "#team @cath hi cath"
bob <## "peer chat protocol version range incompatible"

23
tests/ChatTests/Utils.hs
View file

@ -181,7 +181,12 @@ chatF :: String -> [((Int, String), Maybe String)]
chatF = map (\(a, _, c) -> (a, c)) . chat''
chat'' :: String -> [((Int, String), Maybe (Int, String), Maybe String)]
chat'' = read
chat'' = map (\(a, b, c) -> (mapNoDirect a, mapNoDirect <$> b, c)) . chat'''
where
mapNoDirect (a1, _, a3) = (a1, a3)
chat''' :: String -> [((Int, String, String), Maybe (Int, String, String), Maybe String)]
chat''' = read
chatFeatures :: [(Int, String)]
chatFeatures = map (\(a, _, _) -> a) chatFeatures''
@ -456,27 +461,33 @@ showName (TestCC ChatController {currentUser} _ _ _ _ _) = do
pure . T.unpack $ localDisplayName <> optionalFullName localDisplayName fullName
createGroup2 :: HasCallStack => String -> TestCC -> TestCC -> IO ()
createGroup2 gName cc1 cc2 = do
createGroup2 gName cc1 cc2 = createGroup2' gName cc1 cc2 GRAdmin
createGroup2' :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
createGroup2' gName cc1 cc2 memberRole = do
connectUsers cc1 cc2
name2 <- userName cc2
cc1 ##> ("/g " <> gName)
cc1 <## ("group #" <> gName <> " is created")
cc1 <## ("to add members use /a " <> gName <> " <name> or /create link #" <> gName)
addMember gName cc1 cc2 GRAdmin
addMember gName cc1 cc2 memberRole
cc2 ##> ("/j " <> gName)
concurrently_
(cc1 <## ("#" <> gName <> ": " <> name2 <> " joined the group"))
(cc2 <## ("#" <> gName <> ": you joined the group"))
createGroup3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO ()
createGroup3 gName cc1 cc2 cc3 = do
createGroup2 gName cc1 cc2
createGroup3 gName cc1 cc2 cc3 = createGroup3' gName cc1 cc2 cc3 GRAdmin
createGroup3' :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> GroupMemberRole -> IO ()
createGroup3' gName cc1 cc2 cc3 memberRole = do
createGroup2' gName cc1 cc2 memberRole
connectUsers cc1 cc3
name1 <- userName cc1
name3 <- userName cc3
sName2 <- showName cc2
sName3 <- showName cc3
addMember gName cc1 cc3 GRAdmin
addMember gName cc1 cc3 memberRole
cc3 ##> ("/j " <> gName)
concurrentlyN_
[ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"),

31
tests/ProtocolTests.hs
View file

@ -57,7 +57,7 @@ testConnReq = CRInvitationUri connReqData testE2ERatchetParams
quotedMsg :: QuotedMsg
quotedMsg =
QuotedMsg
(MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing)
(MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing Nothing)
$ MCText "hello there!"
(==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
@ -105,10 +105,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))
it "x.msg.new simple text - timed message TTL" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}"
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing))
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing Nothing))
it "x.msg.new simple text - live message" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"live\":true}}"
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True)))
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True) Nothing))
it "x.msg.new simple text - direct message scope" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"scope\":\"direct\"}}"
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing Nothing (Just MSDirect)))
it "x.msg.new simple link" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}"
#==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing}) Nothing))
@ -130,27 +133,41 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4")
(XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing)))
it "x.msg.new quote - direct referenced message scope" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\",\"msgScope\":\"direct\"}}}}"
##==## ChatMessage
chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4")
( XMsgNew
( MCQuote
( QuotedMsg
(MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing (Just MSDirect))
$ MCText "hello there!"
)
(extMsgContent (MCText "hello to you too") Nothing)
)
)
it "x.msg.new quote - timed message TTL" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"ttl\":3600}}"
##==## ChatMessage
chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4")
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing)))
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing Nothing)))
it "x.msg.new quote - live message" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"live\":true}}"
##==## ChatMessage
chatInitialVRange
(Just $ SharedMsgId "\1\2\3\4")
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True))))
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True) Nothing)))
it "x.msg.new forward" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}"
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing))
it "x.msg.new forward - timed message TTL" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}"
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing))
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing Nothing))
it "x.msg.new forward - live message" $
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}"
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True)))
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True) Nothing))
it "x.msg.new simple text with file" $
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})))