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

group commands (remove member, leave group, delete group) (#87)

Browse Source 
* remove group member

* leave group, fix remove member, tests for leave group/remove member

* delete group with test

* prevent contact deletion error when it is a group member

* support inviting the group member who left or was removed

* use small retry interval in the tests

* test multiline outputs
This commit is contained in:
Evgeny Poberezkin 2021-08-02 20:10:24 +01:00 committed by GitHub
parent b7c4a6e195
commit b798342c61
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
14 changed files with 537 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.github/workflows/build.yml vendored
View File

@ -4,6 +4,7 @@ on:
push:
branches:
- master
- v4
tags:
- "v*"
pull_request:

2
apps/simplex-chat/Main.hs
View File

@ -14,7 +14,7 @@ main :: IO ()
main = do
opts <- welcomeGetOpts
t <- withTerminal pure
simplexChat opts t
simplexChat defaultChatConfig opts t
welcomeGetOpts :: IO ChatOpts
welcomeGetOpts = do

4
migrations/20210612_initial.sql
View File

@ -117,9 +117,7 @@ CREATE TABLE group_members ( -- group members, excluding the local user
REFERENCES display_names (user_id, local_display_name)
ON DELETE RESTRICT
ON UPDATE CASCADE,
UNIQUE (group_id, member_id),
UNIQUE (group_id, contact_id),
UNIQUE (group_id, local_display_name)
UNIQUE (group_id, member_id)
);
CREATE TABLE group_member_intros (

202
src/Simplex/Chat.hs
View File

@ -28,6 +28,7 @@ import Data.Maybe (isJust, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Numeric.Natural
import Simplex.Chat.Controller
import Simplex.Chat.Help
import Simplex.Chat.Input
@ -40,9 +41,8 @@ import Simplex.Chat.Terminal
import Simplex.Chat.Types
import Simplex.Chat.View
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig)
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Client (smpDefaultConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (raceAny_)
@ -71,39 +71,46 @@ data ChatCommand
| QuitChat
deriving (Show)
cfg :: AgentConfig
cfg =
AgentConfig
{ tcpPort = undefined, -- agent does not listen to TCP
smpServers = undefined, -- filled in from options
rsaKeySize = 2048 `div` 8,
connIdBytes = 12,
tbqSize = 16,
dbFile = undefined, -- filled in from options
data ChatConfig = ChatConfig
{ agentConfig :: AgentConfig,
dbPoolSize :: Int,
tbqSize :: Natural
}
defaultChatConfig :: ChatConfig
defaultChatConfig =
ChatConfig
{ agentConfig =
defaultAgentConfig
{ tcpPort = undefined, -- agent does not listen to TCP
smpServers = undefined, -- filled in from options
dbFile = undefined, -- filled in from options
dbPoolSize = 1
},
dbPoolSize = 1,
smpCfg = smpDefaultConfig
tbqSize = 16
}
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
simplexChat :: WithTerminal t => ChatOpts -> t -> IO ()
simplexChat opts t =
simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
simplexChat cfg opts t =
-- setLogLevel LogInfo -- LogError
-- withGlobalLogging logCfg $ do
initializeNotifications
>>= newChatController opts t
>>= newChatController cfg opts t
>>= runSimplexChat
newChatController :: WithTerminal t => ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
newChatController ChatOpts {dbFile, smpServers} t sendNotification = do
chatStore <- createStore (dbFile <> ".chat.db") 1
newChatController :: WithTerminal t => ChatConfig -> ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
newChatController ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {dbFile, smpServers} t sendNotification = do
chatStore <- createStore (dbFile <> ".chat.db") dbPoolSize
currentUser <- getCreateActiveUser chatStore
chatTerminal <- newChatTerminal t
smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
idsDrg <- newTVarIO =<< drgNew
inputQ <- newTBQueueIO $ tbqSize cfg
notifyQ <- newTBQueueIO $ tbqSize cfg
inputQ <- newTBQueueIO tbqSize
notifyQ <- newTBQueueIO tbqSize
pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, idsDrg, inputQ, notifyQ, sendNotification}
runSimplexChat :: ChatController -> IO ()
@ -145,13 +152,16 @@ processChatCommand user@User {userId, profile} = \case
Connect qInfo -> do
connId <- withAgent $ \a -> joinConnection a qInfo . directMessage $ XInfo profile
withStore $ \st -> createDirectConnection st userId connId
DeleteContact cName -> do
conns <- withStore $ \st -> getContactConnections st userId cName
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteContact st userId cName
unsetActive $ ActiveC cName
showContactDeleted cName
DeleteContact cName ->
withStore (\st -> getContactGroupNames st userId cName) >>= \case
[] -> do
conns <- withStore $ \st -> getContactConnections st userId cName
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteContact st userId cName
unsetActive $ ActiveC cName
showContactDeleted cName
gs -> showContactGroups cName gs
SendMessage cName msg -> do
contact <- withStore $ \st -> getContact st userId cName
let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
@ -166,42 +176,70 @@ processChatCommand user@User {userId, profile} = \case
let Group {groupId, groupProfile, membership, members} = group
userRole = memberRole membership
userMemberId = memberId membership
when (userRole < GRAdmin || userRole < memRole) $ throwError $ ChatError CEGroupUserRole
when (isMember contact members) . throwError . ChatError $ CEGroupDuplicateMember cName
when (memberStatus membership == GSMemInvited) . throwError . ChatError $ CEGroupNotJoined gName
unless (memberActive membership) . throwError . ChatError $ CEGroupMemberNotActive
when (userRole < GRAdmin || userRole < memRole) $ chatError CEGroupUserRole
when (memberStatus membership == GSMemInvited) $ chatError (CEGroupNotJoined gName)
unless (memberActive membership) $ chatError CEGroupMemberNotActive
when (isJust $ contactMember contact members) $ chatError (CEGroupDuplicateMember cName)
gVar <- asks idsDrg
(agentConnId, qInfo) <- withAgent createConnection
GroupMember {memberId} <- withStore $ \st -> createContactGroupMember st gVar user groupId contact memRole agentConnId
let msg = XGrpInv $ GroupInvitation (userMemberId, userRole) (memberId, memRole) qInfo groupProfile
sendDirectMessage (contactConnId contact) msg
showSentGroupInvitation group cName
showSentGroupInvitation gName cName
setActive $ ActiveG gName
JoinGroup gName -> do
ReceivedGroupInvitation {fromMember, userMember, queueInfo} <- withStore $ \st -> getGroupInvitation st user gName
agentConnId <- withAgent $ \a -> joinConnection a queueInfo . directMessage . XGrpAcpt $ memberId userMember
withStore $ \st -> do
createMemberConnection st userId (groupMemberId fromMember) agentConnId
updateGroupMemberStatus st userId (groupMemberId fromMember) GSMemAccepted
updateGroupMemberStatus st userId (groupMemberId userMember) GSMemAccepted
createMemberConnection st userId fromMember agentConnId
updateGroupMemberStatus st userId fromMember GSMemAccepted
updateGroupMemberStatus st userId userMember GSMemAccepted
MemberRole _gName _cName _mRole -> pure ()
RemoveMember _gName _cName -> pure ()
LeaveGroup _gName -> pure ()
DeleteGroup _gName -> pure ()
RemoveMember gName cName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
case find ((== cName) . (localDisplayName :: GroupMember -> ContactName)) members of
Nothing -> chatError $ CEGroupMemberNotFound cName
Just member -> do
let userRole = memberRole membership
when (userRole < GRAdmin || userRole < memberRole member) $ chatError CEGroupUserRole
sendGroupMessage members . XGrpMemDel $ memberId member
deleteMemberConnection member
withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved
showDeletedMember gName Nothing (Just member)
LeaveGroup gName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
sendGroupMessage members XGrpLeave
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft
showLeftMemberUser gName
DeleteGroup gName -> do
g@Group {membership, members} <- withStore $ \st -> getGroup st user gName
let s = memberStatus membership
canDelete =
memberRole membership == GROwner
|| (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted)
unless canDelete $ chatError CEGroupUserRole
when (memberActive membership) $ sendGroupMessage members XGrpDel
mapM_ deleteMemberConnection members
withStore $ \st -> deleteGroup st user g
showGroupDeletedUser gName
ListMembers gName -> do
group <- withStore $ \st -> getGroup st user gName
showGroupMembers group
SendGroupMessage gName msg -> do
-- TODO save sent messages
-- TODO save pending message delivery for members without connections
Group {members} <- withStore $ \st -> getGroup st user gName
Group {members, membership} <- withStore $ \st -> getGroup st user gName
unless (memberActive membership) $ chatError CEGroupMemberUserRemoved
let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
sendGroupMessage members msgEvent
setActive $ ActiveG gName
QuitChat -> liftIO exitSuccess
where
isMember :: Contact -> [GroupMember] -> Bool
isMember Contact {contactId} members = isJust $ find ((== Just contactId) . memberContactId) members
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
agentSubscriber = do
@ -224,12 +262,18 @@ subscribeUserConnections = void . runExceptT $ do
forM_ contacts $ \ct@Contact {localDisplayName = c} ->
(subscribe (contactConnId ct) >> showContactSubscribed c) `catchError` showContactSubError c
subscribeGroups user = do
groups <- filter (not . null . members) <$> withStore (`getUserGroups` user)
forM_ groups $ \Group {members, localDisplayName = g} -> do
groups <- withStore (`getUserGroups` user)
forM_ groups $ \Group {members, membership, localDisplayName = g} -> do
let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members
forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
subscribe cId `catchError` showMemberSubError g c
showGroupSubscribed g
if null connectedMembers
then
if memberActive membership
then showGroupEmpty g
else showGroupRemoved g
else do
forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
subscribe cId `catchError` showMemberSubError g c
showGroupSubscribed g
subscribe cId = withAgent (`subscribeConnection` cId)
processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m ()
@ -324,7 +368,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
case chatMsgEvent of
XGrpAcpt memId
| memId == memberId m -> do
withStore $ \st -> updateGroupMemberStatus st userId (groupMemberId m) GSMemAccepted
withStore $ \st -> updateGroupMemberStatus st userId m GSMemAccepted
acceptAgentConnection conn confId XOk
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
_ -> messageError "CONF from invited member must have x.grp.acpt"
@ -351,9 +395,9 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
CON -> do
group@Group {members, membership} <- withStore $ \st -> getGroup st user gName
withStore $ \st -> do
updateGroupMemberStatus st userId (groupMemberId m) GSMemConnected
updateGroupMemberStatus st userId m GSMemConnected
unless (memberActive membership) $
updateGroupMemberStatus st userId (groupMemberId membership) GSMemConnected
updateGroupMemberStatus st userId membership GSMemConnected
-- TODO forward any pending (GMIntroInvReceived) introductions
case memberCategory m of
GCHostMember -> do
@ -389,6 +433,9 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
XGrpMemIntro memInfo -> xGrpMemIntro gName m memInfo
XGrpMemInv memId introInv -> xGrpMemInv gName m memId introInv
XGrpMemFwd memInfo introInv -> xGrpMemFwd gName m memInfo introInv
XGrpMemDel memId -> xGrpMemDel gName m memId
XGrpLeave -> xGrpLeave gName m
XGrpDel -> xGrpDel gName m
_ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent)
_ -> messageError $ "unsupported agent event: " <> T.pack (show agentMsg)
@ -437,8 +484,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
processGroupInvitation :: Contact -> GroupInvitation -> m ()
processGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (fromMemId, fromRole) (memId, memRole) _ _) = do
when (fromRole < GRAdmin || fromRole < memRole) . throwError . ChatError $ CEGroupContactRole localDisplayName
when (fromMemId == memId) $ throwError $ ChatError CEGroupDuplicateMemberId
when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole localDisplayName)
when (fromMemId == memId) $ chatError CEGroupDuplicateMemberId
group <- withStore $ \st -> createGroupInvitation st user ct inv
showReceivedGroupInvitation group localDisplayName memRole
@ -450,7 +497,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
xInfoProbeCheck :: Contact -> ByteString -> m ()
xInfoProbeCheck c1 probeHash = do
r <- withStore $ \st -> matchReceivedProbeHash st userId c1 probeHash
forM_ r $ \(c2, probe) -> probeMatch c1 c2 probe
forM_ r . uncurry $ probeMatch c1
probeMatch :: Contact -> Contact -> ByteString -> m ()
probeMatch c1@Contact {profile = p1} c2@Contact {profile = p2} probe =
@ -503,7 +550,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
newMember <- withStore $ \st -> createIntroReMember st user group m memInfo groupConnId directConnId
let msg = XGrpMemInv memId IntroInvitation {groupQInfo, directQInfo}
sendDirectMessage agentConnId msg
withStore $ \st -> updateGroupMemberStatus st userId (groupMemberId newMember) GSMemIntroInvited
withStore $ \st -> updateGroupMemberStatus st userId newMember GSMemIntroInvited
_ -> messageError "x.grp.mem.intro can be only sent by host member"
xGrpMemInv :: GroupName -> GroupMember -> MemberId -> IntroInvitation -> m ()
@ -538,6 +585,50 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
directConnId <- withAgent $ \a -> joinConnection a directQInfo $ directMessage msg
withStore $ \st -> createIntroToMemberContact st userId m toMember groupConnId directConnId
xGrpMemDel :: GroupName -> GroupMember -> MemberId -> m ()
xGrpMemDel gName m memId = do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
if memberId membership == memId
then do
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved
showDeletedMemberUser gName m
else case find ((== memId) . memberId) members of
Nothing -> messageError "x.grp.mem.del with unknown member ID"
Just member -> do
let mRole = memberRole m
if mRole < GRAdmin || mRole < memberRole member
then messageError "x.grp.mem.del with insufficient member permissions"
else do
deleteMemberConnection member
withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved
showDeletedMember gName (Just m) (Just member)
xGrpLeave :: GroupName -> GroupMember -> m ()
xGrpLeave gName m = do
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemLeft
showLeftMember gName m
xGrpDel :: GroupName -> GroupMember -> m ()
xGrpDel gName m = do
when (memberRole m /= GROwner) $ chatError CEGroupUserRole
ms <- withStore $ \st -> do
Group {members, membership} <- getGroup st user gName
updateGroupMemberStatus st userId membership GSMemGroupDeleted
pure members
mapM_ deleteMemberConnection ms
showGroupDeleted gName m
chatError :: ChatMonad m => ChatErrorType -> m ()
chatError = throwError . ChatError
deleteMemberConnection :: ChatMonad m => GroupMember -> m ()
deleteMemberConnection m = do
User {userId} <- asks currentUser
withAgent $ forM_ (memberConnId m) . deleteConnection
withStore $ \st -> deleteGroupMemberConnection st userId m
sendDirectMessage :: ChatMonad m => ConnId -> ChatMsgEvent -> m ()
sendDirectMessage agentConnId chatMsgEvent =
void . withAgent $ \a -> sendMessage a agentConnId $ directMessage chatMsgEvent
@ -647,12 +738,13 @@ chatCommandP =
<|> ("/group #" <|> "/group " <|> "/g #" <|> "/g ") *> (NewGroup <$> groupProfile)
<|> ("/add #" <|> "/add " <|> "/a #" <|> "/a ") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole)
<|> ("/join #" <|> "/join " <|> "/j #" <|> "/j ") *> (JoinGroup <$> displayName)
<|> ("/remove #" <|> "/rm #") *> (RemoveMember <$> displayName <* A.space <*> displayName)
<|> ("/remove #" <|> "/remove " <|> "/rm #" <|> "/rm ") *> (RemoveMember <$> displayName <* A.space <*> displayName)
<|> ("/leave #" <|> "/leave " <|> "/l #" <|> "/l ") *> (LeaveGroup <$> displayName)
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName)
<|> ("/members #" <|> "/members " <|> "/ms #" <|> "/ms ") *> (ListMembers <$> displayName)
<|> A.char '#' *> (SendGroupMessage <$> displayName <* A.space <*> A.takeByteString)
<|> ("/add" <|> "/a") $> AddContact
<|> ("/connect " <|> "/c ") *> (Connect <$> smpQueueInfoP)
<|> ("/connect" <|> "/c") $> AddContact
<|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName)
<|> A.char '@' *> (SendMessage <$> displayName <*> (A.space *> A.takeByteString))
<|> ("/markdown" <|> "/m") $> MarkdownHelp

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

@ -47,6 +47,8 @@ data ChatErrorType
| CEGroupDuplicateMemberId
| CEGroupNotJoined GroupName
| CEGroupMemberNotActive
| CEGroupMemberUserRemoved
| CEGroupMemberNotFound ContactName
| CEGroupInternal String
deriving (Show, Exception)

2
src/Simplex/Chat/Help.hs
View File

@ -14,7 +14,7 @@ chatHelpInfo =
[ highlight "Using Simplex chat prototype.",
"Follow these steps to set up a connection:",
"",
Markdown (Colored Green) "Step 1: " <> highlight "/add" <> " -- Alice adds a contact.",
Markdown (Colored Green) "Step 1: " <> highlight "/connect" <> " -- Alice adds a contact.",
indent <> "Alice should send the invitation printed by the /add command",
indent <> "to her contact, Bob, out-of-band, via any trusted channel.",
"",

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

@ -55,6 +55,9 @@ data ChatMsgEvent
| XGrpMemInfo MemberId Profile
| XGrpMemCon MemberId
| XGrpMemConAll MemberId
| XGrpMemDel MemberId
| XGrpLeave
| XGrpDel
| XInfoProbe ByteString
| XInfoProbeCheck ByteString
| XInfoProbeOk ByteString
@ -122,6 +125,12 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod
chatMsg . XGrpMemCon =<< B64.decode memId
("x.grp.mem.con.all", [memId]) ->
chatMsg . XGrpMemConAll =<< B64.decode memId
("x.grp.mem.del", [memId]) ->
chatMsg . XGrpMemDel =<< B64.decode memId
("x.grp.leave", []) ->
chatMsg XGrpLeave
("x.grp.del", []) ->
chatMsg XGrpDel
("x.info.probe", [probe]) -> do
chatMsg . XInfoProbe =<< B64.decode probe
("x.info.probe.check", [probeHash]) -> do
@ -200,6 +209,12 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
rawMsg "x.grp.mem.con" [B64.encode memId] []
XGrpMemConAll memId ->
rawMsg "x.grp.mem.con.all" [B64.encode memId] []
XGrpMemDel memId ->
rawMsg "x.grp.mem.del" [B64.encode memId] []
XGrpLeave ->
rawMsg "x.grp.leave" [] []
XGrpDel ->
rawMsg "x.grp.del" [] []
XInfoProbe probe ->
rawMsg "x.info.probe" [B64.encode probe] []
XInfoProbeCheck probeHash ->

43
src/Simplex/Chat/Store.hs
View File

@ -21,6 +21,7 @@ module Simplex.Chat.Store
setActiveUser,
createDirectConnection,
createDirectContact,
getContactGroupNames,
deleteContact,
getContact,
getUserContacts,
@ -30,12 +31,14 @@ module Simplex.Chat.Store
createNewGroup,
createGroupInvitation,
getGroup,
deleteGroup,
getUserGroups,
getGroupInvitation,
createContactGroupMember,
createMemberConnection,
updateGroupMemberStatus,
createNewGroupMember,
deleteGroupMemberConnection,
createIntroductions,
updateIntroStatus,
saveIntroInvitation,
@ -182,6 +185,20 @@ createContact_ db userId connId Profile {displayName, fullName} viaGroup =
DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId)
pure (ldn, contactId, profileId)
getContactGroupNames :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactName -> m [GroupName]
getContactGroupNames st userId displayName =
liftIO . withTransaction st $ \db -> do
map fromOnly
<$> DB.query
db
[sql|
SELECT DISTINCT g.local_display_name
FROM groups g
JOIN group_members m ON m.group_id = g.group_id
WHERE g.user_id = ? AND m.local_display_name = ?
|]
(userId, displayName)
deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactName -> m ()
deleteContact st userId displayName =
liftIO . withTransaction st $ \db -> do
@ -587,6 +604,14 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
[] -> Left SEGroupWithoutUser
u : ms -> Right (b <> ms, u)
deleteGroup :: MonadUnliftIO m => SQLiteStore -> User -> Group -> m ()
deleteGroup st User {userId} Group {groupId, members, localDisplayName} =
liftIO . withTransaction st $ \db -> do
forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId m)
DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId)
DB.execute db "DELETE FROM groups WHERE user_id = ? AND group_id = ?" (userId, groupId)
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
getUserGroups :: MonadUnliftIO m => SQLiteStore -> User -> m [Group]
getUserGroups st user =
liftIO . withTransaction st $ \db -> do
@ -624,13 +649,13 @@ createContactGroupMember st gVar user groupId contact memberRole agentConnId =
void $ createMemberConnection_ db (userId user) groupMemberId agentConnId Nothing 0
pure member
createMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> m ()
createMemberConnection st userId groupMemberId agentConnId =
createMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> ConnId -> m ()
createMemberConnection st userId GroupMember {groupMemberId} agentConnId =
liftIO . withTransaction st $ \db ->
void $ createMemberConnection_ db userId groupMemberId agentConnId Nothing 0
updateGroupMemberStatus :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> GroupMemberStatus -> m ()
updateGroupMemberStatus st userId groupMemberId memberStatus =
updateGroupMemberStatus :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> GroupMemberStatus -> m ()
updateGroupMemberStatus st userId GroupMember {groupMemberId} memStatus =
liftIO . withTransaction st $ \db ->
DB.executeNamed
db
@ -641,7 +666,7 @@ updateGroupMemberStatus st userId groupMemberId memberStatus =
|]
[ ":user_id" := userId,
":group_member_id" := groupMemberId,
":member_status" := memberStatus
":member_status" := memStatus
]
-- | add new member with profile
@ -701,6 +726,14 @@ createNewMember_
activeConn = Nothing
}
deleteGroupMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> m ()
deleteGroupMemberConnection st userId m =
liftIO . withTransaction st $ \db -> deleteGroupMemberConnection_ db userId m
deleteGroupMemberConnection_ :: DB.Connection -> UserId -> GroupMember -> IO ()
deleteGroupMemberConnection_ db userId GroupMember {groupMemberId} =
DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId)
createIntroductions :: MonadUnliftIO m => SQLiteStore -> Group -> GroupMember -> m [GroupMemberIntro]
createIntroductions st Group {members} toMember = do
let reMembers = filter (\m -> memberCurrent m && groupMemberId m /= groupMemberId toMember) members

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

@ -227,6 +227,7 @@ serializeMemberCategory = \case
data GroupMemberStatus
= GSMemRemoved -- member who was removed from the group
| GSMemLeft -- member who left the group
| GSMemGroupDeleted -- user member of the deleted group
| GSMemInvited -- member is sent to or received invitation to join the group
| GSMemIntroduced -- user received x.grp.mem.intro for this member (only with GCPreMember)
| GSMemIntroInvited -- member is sent to or received from intro invitation
@ -245,6 +246,7 @@ memberActive :: GroupMember -> Bool
memberActive m = case memberStatus m of
GSMemRemoved -> False
GSMemLeft -> False
GSMemGroupDeleted -> False
GSMemInvited -> False
GSMemIntroduced -> False
GSMemIntroInvited -> False
@ -258,6 +260,7 @@ memberCurrent :: GroupMember -> Bool
memberCurrent m = case memberStatus m of
GSMemRemoved -> False
GSMemLeft -> False
GSMemGroupDeleted -> False
GSMemInvited -> False
GSMemIntroduced -> True
GSMemIntroInvited -> True
@ -271,6 +274,7 @@ memberStatusT :: Text -> Maybe GroupMemberStatus
memberStatusT = \case
"removed" -> Just GSMemRemoved
"left" -> Just GSMemLeft
"deleted" -> Just GSMemGroupDeleted
"invited" -> Just GSMemInvited
"introduced" -> Just GSMemIntroduced
"intro-inv" -> Just GSMemIntroInvited
@ -285,6 +289,7 @@ serializeMemberStatus :: GroupMemberStatus -> Text
serializeMemberStatus = \case
GSMemRemoved -> "removed"
GSMemLeft -> "left"
GSMemGroupDeleted -> "deleted"
GSMemInvited -> "invited"
GSMemIntroduced -> "introduced"
GSMemIntroInvited -> "intro-inv"

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

@ -10,23 +10,32 @@ module Simplex.Chat.View
showInvitation,
showChatError,
showContactDeleted,
showContactGroups,
showContactConnected,
showContactDisconnected,
showContactSubscribed,
showContactSubError,
showGroupSubscribed,
showGroupEmpty,
showGroupRemoved,
showMemberSubError,
showReceivedMessage,
showReceivedGroupMessage,
showSentMessage,
showSentGroupMessage,
showGroupCreated,
showGroupDeletedUser,
showGroupDeleted,
showSentGroupInvitation,
showReceivedGroupInvitation,
showJoinedGroupMember,
showUserJoinedGroup,
showJoinedGroupMemberConnecting,
showConnectedToGroupMember,
showDeletedMember,
showDeletedMemberUser,
showLeftMemberUser,
showLeftMember,
showGroupMembers,
showContactsMerged,
safeDecodeUtf8,
@ -63,6 +72,9 @@ showChatError = printToView . chatError
showContactDeleted :: ChatReader m => ContactName -> m ()
showContactDeleted = printToView . contactDeleted
showContactGroups :: ChatReader m => ContactName -> [GroupName] -> m ()
showContactGroups = printToView .: contactGroups
showContactConnected :: ChatReader m => Contact -> m ()
showContactConnected = printToView . contactConnected
@ -78,6 +90,12 @@ showContactSubError = printToView .: contactSubError
showGroupSubscribed :: ChatReader m => GroupName -> m ()
showGroupSubscribed = printToView . groupSubscribed
showGroupEmpty :: ChatReader m => GroupName -> m ()
showGroupEmpty = printToView . groupEmpty
showGroupRemoved :: ChatReader m => GroupName -> m ()
showGroupRemoved = printToView . groupRemoved
showMemberSubError :: ChatReader m => GroupName -> ContactName -> ChatError -> m ()
showMemberSubError = printToView .:. memberSubError
@ -102,7 +120,13 @@ showSentMessage_ to msg = printToView =<< liftIO (sentMessage to msg)
showGroupCreated :: ChatReader m => Group -> m ()
showGroupCreated = printToView . groupCreated
showSentGroupInvitation :: ChatReader m => Group -> ContactName -> m ()
showGroupDeletedUser :: ChatReader m => GroupName -> m ()
showGroupDeletedUser = printToView . groupDeletedUser
showGroupDeleted :: ChatReader m => GroupName -> GroupMember -> m ()
showGroupDeleted = printToView .: groupDeleted
showSentGroupInvitation :: ChatReader m => GroupName -> ContactName -> m ()
showSentGroupInvitation = printToView .: sentGroupInvitation
showReceivedGroupInvitation :: ChatReader m => Group -> ContactName -> GroupMemberRole -> m ()
@ -120,6 +144,18 @@ showJoinedGroupMemberConnecting = printToView .:. joinedGroupMemberConnecting
showConnectedToGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
showConnectedToGroupMember = printToView .: connectedToGroupMember
showDeletedMember :: ChatReader m => GroupName -> Maybe GroupMember -> Maybe GroupMember -> m ()
showDeletedMember = printToView .:. deletedMember
showDeletedMemberUser :: ChatReader m => GroupName -> GroupMember -> m ()
showDeletedMemberUser = printToView .: deletedMemberUser
showLeftMemberUser :: ChatReader m => GroupName -> m ()
showLeftMemberUser = printToView . leftMemberUser
showLeftMember :: ChatReader m => GroupName -> GroupMember -> m ()
showLeftMember = printToView .: leftMember
showGroupMembers :: ChatReader m => Group -> m ()
showGroupMembers = printToView . groupMembers
@ -136,22 +172,36 @@ invitation qInfo =
]
contactDeleted :: ContactName -> [StyledString]
contactDeleted c = [ttyContact c <> " is deleted"]
contactDeleted c = [ttyContact c <> ": contact is deleted"]
contactGroups :: ContactName -> [GroupName] -> [StyledString]
contactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
where
ttyGroups :: [GroupName] -> StyledString
ttyGroups [] = ""
ttyGroups [g] = ttyGroup g
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
contactConnected :: Contact -> [StyledString]
contactConnected ct = [ttyFullContact ct <> " is connected"]
contactConnected ct = [ttyFullContact ct <> ": contact is connected"]
contactDisconnected :: ContactName -> [StyledString]
contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"]
contactDisconnected c = [ttyContact c <> ": contact is disconnected - restart chat"]
contactSubscribed :: ContactName -> [StyledString]
contactSubscribed c = [ttyContact c <> " is active"]
contactSubscribed c = [ttyContact c <> ": contact is active"]
contactSubError :: ContactName -> ChatError -> [StyledString]
contactSubError c e = ["contact " <> ttyContact c <> " error: " <> plain (show e)]
contactSubError c e = [ttyContact c <> ": contact error " <> plain (show e)]
groupSubscribed :: GroupName -> [StyledString]
groupSubscribed g = [ttyGroup g <> " is active"]
groupSubscribed g = [ttyGroup g <> ": group is active"]
groupEmpty :: GroupName -> [StyledString]
groupEmpty g = [ttyGroup g <> ": group is empty"]
groupRemoved :: GroupName -> [StyledString]
groupRemoved g = [ttyGroup g <> ": you are no longer a member or group deleted"]
memberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
memberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> plain (show e)]
@ -162,8 +212,17 @@ groupCreated g@Group {localDisplayName} =
"use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members"
]
sentGroupInvitation :: Group -> ContactName -> [StyledString]
sentGroupInvitation g c = ["invitation to join the group " <> ttyFullGroup g <> " sent to " <> ttyContact c]
groupDeletedUser :: GroupName -> [StyledString]
groupDeletedUser g = groupDeleted_ g Nothing
groupDeleted :: GroupName -> GroupMember -> [StyledString]
groupDeleted g m = groupDeleted_ g (Just m) <> ["use " <> highlight ("/d #" <> g) <> " to delete the local copy of the group"]
groupDeleted_ :: GroupName -> Maybe GroupMember -> [StyledString]
groupDeleted_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " deleted the group"]
sentGroupInvitation :: GroupName -> ContactName -> [StyledString]
sentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
receivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString]
receivedGroupInvitation g@Group {localDisplayName} c role =
@ -183,6 +242,27 @@ joinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <>
connectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
connectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
deletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString]
deletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"]
deletedMemberUser :: GroupName -> GroupMember -> [StyledString]
deletedMemberUser g by = deletedMember g (Just by) Nothing <> groupPreserved g
leftMemberUser :: GroupName -> [StyledString]
leftMemberUser g = leftMember_ g Nothing <> groupPreserved g
leftMember :: GroupName -> GroupMember -> [StyledString]
leftMember g m = leftMember_ g (Just m)
leftMember_ :: GroupName -> Maybe GroupMember -> [StyledString]
leftMember_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " left the group"]
groupPreserved :: GroupName -> [StyledString]
groupPreserved g = ["use " <> highlight ("/d #" <> g) <> " to delete the group"]
memberOrUser :: Maybe GroupMember -> StyledString
memberOrUser = maybe "you" ttyMember
connectedMember :: GroupMember -> StyledString
connectedMember m = case memberCategory m of
GCPreMember -> "member " <> ttyFullMember m
@ -262,6 +342,8 @@ chatError = \case
CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]
CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> g)]
CEGroupMemberNotActive -> ["you cannot invite other members yet, try later"]
CEGroupMemberUserRemoved -> ["you are no longer the member of the group"]
CEGroupMemberNotFound c -> ["contact " <> ttyContact c <> " is not a group member"]
CEGroupInternal s -> ["chat group bug: " <> plain s]
-- e -> ["chat error: " <> plain (show e)]
ChatErrorStore err -> case err of
@ -271,13 +353,7 @@ chatError = \case
SEGroupNotFound g -> ["no group " <> ttyGroup g]
SEGroupAlreadyJoined -> ["you already joined this group"]
e -> ["chat db error: " <> plain (show e)]
ChatErrorAgent err -> case err of
-- CONN e -> case e of
-- -- TODO replace with ChatErrorContact errors, these errors should never happen
-- NOT_FOUND -> ["no contact " <> ttyContact c]
-- DUPLICATE -> ["contact " <> ttyContact c <> " already exists"]
-- SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"]
e -> ["smp agent error: " <> plain (show e)]
ChatErrorAgent e -> ["smp agent error: " <> plain (show e)]
ChatErrorMessage e -> ["chat message error: " <> plain (show e)]
printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()

8
src/Simplex/Chat/protocol.md
View File

@ -91,8 +91,8 @@ M -> B: establish direct connection (M: JOIN, B: LET)
M -> Bg: confirm profile and role - `CONF: x.grp.mem.info G_MEM_ID_M,G_MEM_ROLE x.json:NNN <M_profile>`
B -> Mg: send profile probe - `MSG: x.info.probe <probe>` - it should always be send, even when there is no profile match.
if M is a known contact (profile match) send probe to M:
B -> M (via old DM conn): profile match probe: `MSG: x.info.probe.check G_MEM_ID_B,<probe_hash>`
M -> B (via old DM conn): probe confirm: `MSG: x.info.probe.ok G_MEM_ID_M,<probe>`
B -> M (via old DM conn): profile match probe: `MSG: x.info.probe.check <probe_hash>`
M -> B (via old DM conn): probe confirm: `MSG: x.info.probe.ok <probe>`
link to the same contact
B -> Ag: connected to M: `MSG: x.grp.mem.con G_MEM_ID_M`
M -> Ag: connected to M: `MSG: x.grp.mem.con G_MEM_ID_B`
@ -102,7 +102,9 @@ A -> group: `MSG: N x.grp.mem.con.all G_MEM_ID_B`
#### Send group message
`MSG: N x.msg.new G_MEM_ROLE,<invitation> x.json:NNN <group_profile>`
Example:
`MSG: N x.msg.new c.text x.text:5 hello `
#### Group member statuses

2
stack.yaml
View File

@ -43,7 +43,7 @@ extra-deps:
# - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688
# - ../simplexmq
- github: simplex-chat/simplexmq
commit: 53aadca635a6953bd18a305423783b0d71a13cb6
commit: 8a4bced56972363c073c05bf81ecc0a3b1c2cd8d
# this commit is in PR #164
#
# extra-deps: []

13
tests/ChatClient.hs
View File

@ -14,6 +14,7 @@ import Simplex.Chat.Controller (ChatController (..))
import Simplex.Chat.Options
import Simplex.Chat.Store
import Simplex.Chat.Types (Profile)
import Simplex.Messaging.Agent.Env.SQLite
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
import qualified System.Terminal as C
import System.Terminal.Internal (VirtualTerminal, VirtualTerminalSettings (..), withVirtualTerminal)
@ -39,12 +40,22 @@ termSettings =
data TestCC = TestCC ChatController VirtualTerminal (Async ())
aCfg :: AgentConfig
aCfg = agentConfig defaultChatConfig
cfg :: ChatConfig
cfg =
defaultChatConfig
{ agentConfig =
aCfg {retryInterval = (retryInterval aCfg) {initialInterval = 50000}}
}
virtualSimplexChat :: FilePath -> Profile -> IO TestCC
virtualSimplexChat dbFile profile = do
st <- createStore (dbFile <> ".chat.db") 1
void . runExceptT $ createUser st profile True
t <- withVirtualTerminal termSettings pure
cc <- newChatController opts {dbFile} t . const $ pure () -- no notifications
cc <- newChatController cfg opts {dbFile} t . const $ pure () -- no notifications
a <- async $ runSimplexChat cc
pure (TestCC cc t a)

268
tests/ChatTests.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
module ChatTests where
@ -7,11 +8,12 @@ import ChatClient
import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Data.Char (isDigit)
import Data.List (dropWhileEnd, isPrefixOf)
import Data.List (dropWhileEnd, intercalate, isPrefixOf)
import qualified Data.Text as T
import Simplex.Chat.Controller
import Simplex.Chat.Types (Profile (..), User (..))
import System.Terminal.Internal (VirtualTerminal (..))
import System.Timeout (timeout)
import Test.Hspec
aliceProfile :: Profile
@ -33,35 +35,37 @@ chatTests = do
describe "chat groups" $ do
it "add contacts, create group and send/receive messages" testGroup
it "create and join group with 4 members" testGroup2
it "create and delete group" testGroupDelete
fit "remove contact from group and add again" testGroupRemoveAdd
testAddContact :: IO ()
testAddContact =
testChat2 aliceProfile bobProfile $
\alice bob -> do
alice ##> "/a"
alice ##> "/c"
Just inv <- invitation <$> getWindow alice
bob ##> ("/c " <> inv)
concurrently_
(bob <## "alice (Alice) is connected")
(alice <## "bob (Bob) is connected")
(bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected")
alice #> "@bob hello"
bob <# "alice> hello"
bob #> "@alice hi"
alice <# "bob> hi"
-- test adding the same contact one more time - local name will be different
alice ##> "/a"
alice ##> "/c"
Just inv' <- invitation <$> getWindow alice
bob ##> ("/c " <> inv')
concurrently_
(bob <## "alice_1 (Alice) is connected")
(alice <## "bob_1 (Bob) is connected")
(bob <## "alice_1 (Alice): contact is connected")
(alice <## "bob_1 (Bob): contact is connected")
alice #> "@bob_1 hello"
bob <# "alice_1> hello"
bob #> "@alice_1 hi"
alice <# "bob_1> hi"
-- test deleting contact
alice ##> "/d bob_1"
alice <## "bob_1 is deleted"
alice <## "bob_1: contact is deleted"
alice #:> "@bob_1 hey"
alice <## "no contact bob_1"
@ -73,11 +77,11 @@ testGroup =
connectUsers alice cath
alice #:> "/g team"
-- TODO this occasionally fails in case getWindow is run before the command above is printed
alice <## "use /a team <name> to add members"
alice <## "group #team is created\nuse /a team <name> to add members"
alice ##> "/a team bob"
concurrently_
(alice <## "invitation to join the group #team sent to bob")
(bob <## "use /j team to accept")
(bob <## "#team: alice invites you to join the group as admin\nuse /j team to accept")
bob ##> "/j team"
concurrently_
(alice <## "#team: bob joined the group")
@ -85,7 +89,7 @@ testGroup =
alice ##> "/a team cath"
concurrently_
(alice <## "invitation to join the group #team sent to cath")
(cath <## "use /j team to accept")
(cath <## "#team: alice invites you to join the group as admin\nuse /j team to accept")
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
@ -108,10 +112,25 @@ testGroup =
concurrently_
(alice <# "#team cath> hey")
(bob <# "#team cath> hey")
bob #> "@cath hello cath"
cath <# "bob> hello cath"
cath #> "@bob hello bob"
bob <# "cath> hello bob"
bob <##> cath
-- remove member
bob ##> "/rm team cath"
concurrentlyN_
[ bob <## "#team: you removed cath from the group",
alice <## "#team: bob removed cath from the group",
cath <## "#team: bob removed you from the group\nuse /d #team to delete the group"
]
bob #> "#team hi"
concurrently_
(alice <# "#team bob> hi")
(cath </)
alice #> "#team hello"
concurrently_
(bob <# "#team alice> hello")
(cath </)
cath #:> "#team hello"
cath <## "you are no longer the member of the group"
bob <##> cath
testGroup2 :: IO ()
testGroup2 =
@ -123,15 +142,15 @@ testGroup2 =
connectUsers alice dan
alice #:> "/g club"
-- TODO this occasionally fails in case getWindow is run before the command above is printed
alice <## "use /a club <name> to add members"
alice <## "group #club is created\nuse /a club <name> to add members"
alice ##> "/a club bob"
concurrently_
(alice <## "invitation to join the group #club sent to bob")
(bob <## "use /j club to accept")
(bob <## "#club: alice invites you to join the group as admin\nuse /j club to accept")
alice ##> "/a club cath"
concurrently_
(alice <## "invitation to join the group #club sent to cath")
(cath <## "use /j club to accept")
(cath <## "#club: alice invites you to join the group as admin\nuse /j club to accept")
bob ##> "/j club"
concurrently_
(alice <## "#club: bob joined the group")
@ -149,21 +168,18 @@ testGroup2 =
bob ##> "/a club dan"
concurrently_
(bob <## "invitation to join the group #club sent to dan")
(dan <## "use /j club to accept")
(dan <## "#club: bob invites you to join the group as admin\nuse /j club to accept")
dan ##> "/j club"
concurrentlyN_
[ bob <## "#club: dan joined the group",
do
dan <## "#club: you joined the group"
dan
<### [ "#club: member alice_1 (Alice) is connected",
"#club: member cath (Catherine) is connected",
"use @alice <message> to send messages"
],
dan <### ["#club: member alice_1 (Alice) is connected", "#club: member cath (Catherine) is connected"]
dan <## "contact alice_1 is merged into alice\nuse @alice <message> to send messages",
do
alice <## "#club: bob added dan_1 (Daniel) to the group (connecting...)"
alice <## "#club: new member dan_1 is connected"
alice <## "use @dan <message> to send messages",
alice <## "contact dan_1 is merged into dan\nuse @dan <message> to send messages",
do
cath <## "#club: bob added dan (Daniel) to the group (connecting...)"
cath <## "#club: new member dan is connected"
@ -192,58 +208,203 @@ testGroup2 =
bob <# "#club dan> how is it going?",
cath <# "#club dan> how is it going?"
]
bob #> "@cath hi cath"
cath <# "bob> hi cath"
cath #> "@bob hi bob"
bob <# "cath> hi bob"
dan #> "@cath hey cath"
cath <# "dan> hey cath"
cath #> "@dan hey dan"
dan <# "cath> hey dan"
dan #> "@alice hi alice"
alice <# "dan> hi alice"
alice #> "@dan hello dan"
dan <# "alice> hello dan"
bob <##> cath
dan <##> cath
dan <##> alice
-- remove member
cath ##> "/rm club dan"
concurrentlyN_
[ cath <## "#club: you removed dan from the group",
alice <## "#club: cath removed dan from the group",
bob <## "#club: cath removed dan from the group",
dan <## "#club: cath removed you from the group\nuse /d #club to delete the group"
]
alice #> "#club hello"
concurrentlyN_
[ bob <# "#club alice> hello",
cath <# "#club alice> hello",
(dan </)
]
bob #> "#club hi there"
concurrentlyN_
[ alice <# "#club bob> hi there",
cath <# "#club bob> hi there",
(dan </)
]
cath #> "#club hey"
concurrentlyN_
[ alice <# "#club cath> hey",
bob <# "#club cath> hey",
(dan </)
]
dan #:> "#club how is it going?"
dan <## "you are no longer the member of the group"
dan <##> cath
dan <##> alice
-- member leaves
bob ##> "/l club"
concurrentlyN_
[ bob <## "#club: you left the group\nuse /d #club to delete the group",
alice <## "#club: bob left the group",
cath <## "#club: bob left the group"
]
alice #> "#club hello"
concurrently_
(cath <# "#club alice> hello")
(bob </)
cath #> "#club hey"
concurrently_
(alice <# "#club cath> hey")
(bob </)
bob #:> "#club how is it going?"
bob <## "you are no longer the member of the group"
bob <##> cath
bob <##> alice
testGroupDelete :: IO ()
testGroupDelete =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
alice ##> "/d #team"
concurrentlyN_
[ alice <## "#team: you deleted the group",
bob <## "#team: alice deleted the group\nuse /d #team to delete the local copy of the group",
cath <## "#team: alice deleted the group\nuse /d #team to delete the local copy of the group"
]
bob #:> "/d #team"
bob <## "#team: you deleted the group"
cath #:> "#team hi"
cath <## "you are no longer the member of the group"
testGroupRemoveAdd :: IO ()
testGroupRemoveAdd =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
-- remove member
alice ##> "/rm team bob"
concurrentlyN_
[ alice <## "#team: you removed bob from the group",
bob <## "#team: alice removed you from the group\nuse /d #team to delete the group",
cath <## "#team: alice removed bob from the group"
]
alice ##> "/a team bob"
bob <## "#team_1 (team): alice invites you to join the group as admin\nuse /j team_1 to accept"
bob ##> "/j team_1"
concurrentlyN_
[ alice <## "#team: bob joined the group",
do
bob <## "#team_1: you joined the group"
bob <## "#team_1: member cath_1 (Catherine) is connected"
bob <## "contact cath_1 is merged into cath\nuse @cath <message> to send messages",
do
cath <## "#team: alice added bob_1 (Bob) to the group (connecting...)"
cath <## "#team: new member bob_1 is connected"
cath <## "contact bob_1 is merged into bob\nuse @bob <message> to send messages"
]
alice #> "#team hi"
concurrently_
(bob <# "#team_1 alice> hi")
(cath <# "#team alice> hi")
bob #> "#team_1 hey"
concurrently_
(alice <# "#team bob> hey")
(cath <# "#team bob> hey")
cath #> "#team hello"
concurrently_
(alice <# "#team cath> hello")
(bob <# "#team_1 cath> hello")
connectUsers :: TestCC -> TestCC -> IO ()
connectUsers cc1 cc2 = do
cc1 ##> "/a"
cc1 ##> "/c"
Just inv <- invitation <$> getWindow cc1
cc2 ##> ("/c " <> inv)
concurrently_
(cc2 <## (showName cc1 <> " is connected"))
(cc1 <## (showName cc2 <> " is connected"))
(cc2 <## (showName cc1 <> ": contact is connected"))
(cc1 <## (showName cc2 <> ": contact is connected"))
showName :: TestCC -> String
showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _) =
T.unpack $ localDisplayName <> " (" <> fullName <> ")"
createGroup3 :: String -> TestCC -> TestCC -> TestCC -> IO ()
createGroup3 gName cc1 cc2 cc3 = do
connectUsers cc1 cc2
connectUsers cc1 cc3
cc1 #:> ("/g " <> gName)
cc1 <## ("use /a " <> gName <> " <name> to add members")
cc1 ##> ("/a team " <> name cc2)
concurrently_
(cc1 <## ("invitation to join the group #" <> gName <> " sent to " <> name cc2))
(cc2 <## ("use /j " <> gName <> " to accept"))
cc2 ##> ("/j " <> gName)
concurrently_
(cc1 <## ("#" <> gName <> ": " <> name cc2 <> " joined the group"))
(cc2 <## ("#" <> gName <> ": you joined the group"))
cc1 ##> ("/a team " <> name cc3)
concurrently_
(cc1 <## ("invitation to join the group #" <> gName <> " sent to " <> name cc3))
(cc3 <## ("use /j " <> gName <> " to accept"))
cc3 ##> ("/j " <> gName)
concurrentlyN_
[ cc1 <## ("#" <> gName <> ": " <> name cc3 <> " joined the group"),
do
cc3 <## ("#" <> gName <> ": you joined the group")
cc3 <## ("#" <> gName <> ": member " <> showName cc2 <> " is connected"),
do
cc2 <## ("#" <> gName <> ": alice added " <> showName cc3 <> " to the group (connecting...)")
cc2 <## ("#" <> gName <> ": new member " <> name cc3 <> " is connected")
]
where
showName :: TestCC -> String
showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _) =
T.unpack $ localDisplayName <> " (" <> fullName <> ")"
name :: TestCC -> String
name (TestCC ChatController {currentUser = User {localDisplayName}} _ _) =
T.unpack localDisplayName
-- | test sending direct messages
(<##>) :: TestCC -> TestCC -> IO ()
cc1 <##> cc2 = do
cc1 #> ("@" <> name cc2 <> " hi")
cc2 <# (name cc1 <> "> hi")
cc2 #> ("@" <> name cc1 <> " hey")
cc1 <# (name cc2 <> "> hey")
where
name (TestCC ChatController {currentUser = User {localDisplayName}} _ _) = T.unpack localDisplayName
(##>) :: TestCC -> String -> IO ()
(##>) cc cmd = do
cc ##> cmd = do
cc #:> cmd
cc <## cmd
(#>) :: TestCC -> String -> IO ()
(#>) cc cmd = do
cc #> cmd = do
cc #:> cmd
cc <# cmd
(#:>) :: TestCC -> String -> IO ()
(#:>) (TestCC cc _ _) cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd
(TestCC cc _ _) #:> cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd
(<##) :: TestCC -> String -> Expectation
cc <## line = (lastOutput <$> getWindow cc) `shouldReturn` line
cc <## line =
let n = length $ lines line
in (lastOutput n <$> getWindow cc) `shouldReturn` line
(<###) :: TestCC -> [String] -> Expectation
_ <### [] = pure ()
cc <### ls = do
line <- lastOutput <$> getWindow cc
line <- lastOutput 1 <$> getWindow cc
if line `elem` ls
then cc <### filter (/= line) ls
else error $ "unexpected output: " <> line
(<#) :: TestCC -> String -> Expectation
cc <# line = (dropTime . lastOutput <$> getWindow cc) `shouldReturn` line
cc <# line =
let n = length $ lines line
in (dropTime . lastOutput n <$> getWindow cc) `shouldReturn` line
(</) :: TestCC -> Expectation
(</) cc = timeout 500000 (getWindow cc) `shouldReturn` Nothing
dropTime :: String -> String
dropTime msg = case splitAt 6 msg of
@ -255,15 +416,18 @@ getWindow :: TestCC -> IO [String]
getWindow (TestCC _ t _) = do
let w = virtualWindow t
win <- readTVarIO w
atomically $ do
-- TODO to debug - putStrLn (lastOutput 1 win') - before returning it
r <- atomically $ do
win' <- readTVar w
if win' /= win then pure win' else retry
putStrLn $ lastOutput 1 r
pure r
invitation :: [String] -> Maybe String
invitation win = lastMaybe $ map (dropWhileEnd (== ' ')) $ filter ("smp::" `isPrefixOf`) win
lastOutput :: [String] -> String
lastOutput win = dropWhileEnd (== ' ') $ win !! (length win - 2) -- (- 2) to exclude prompt
lastOutput :: Int -> [String] -> String
lastOutput n win = intercalate "\n" $ map (dropWhileEnd (== ' ')) $ take n $ drop (length win - n - 1) win -- - 1 to exclude prompt
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing