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

core chat groups protocol for adding members (#78)

Browse Source 
* add category and local display name to group members, extend member status

* additional chat commands, serialization

* parse all chat messages

* draft group protocol implementation

* group protocol: connect new member to existing members (TODO fix race condition with contact connection)

* send/receive group messages (race condition still there - the 3rd member cannot send either group or direct messages to the 2nd member - CONN SIMPLEX)

* send x.grp.mem.info and x.ok in SMP confirmation

* fix host user adding new member, update simplexmq to fix sqlite concurrency, remove logs, make # optional in chat commands

* more precise view messages about members joining and connecting

* track connection status; only send messages to active members (TODO change to current members); group name autocomplete after joining the group

* track via which group the contact was added; show only one message when a contact fully connected; group tests

* test sending messages to the new direct contacts created via the group

* update simplexmq to include .cabal file

* remove unused import
This commit is contained in:
Evgeny Poberezkin 2021-07-24 10:26:28 +01:00 committed by GitHub
parent 94f89ed8f7
commit 189cd7e09d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
14 changed files with 1262 additions and 347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
migrations/20210612_initial.sql
View File

@ -14,6 +14,7 @@ CREATE TABLE users (
FOREIGN KEY (user_id, local_display_name)
REFERENCES display_names (user_id, local_display_name)
ON DELETE RESTRICT
ON UPDATE CASCADE
DEFERRABLE INITIALLY DEFERRED
);
@ -32,10 +33,12 @@ CREATE TABLE contacts (
user_id INTEGER NOT NULL REFERENCES users,
local_display_name TEXT NOT NULL,
is_user INTEGER NOT NULL DEFAULT 0, -- 1 if this contact is a user
via_group INTEGER REFERENCES groups (group_id) ON DELETE SET NULL,
created_at TEXT NOT NULL DEFAULT (datetime('now')),
FOREIGN KEY (user_id, local_display_name)
REFERENCES display_names (user_id, local_display_name)
ON DELETE RESTRICT,
ON DELETE RESTRICT
ON UPDATE CASCADE,
UNIQUE (user_id, local_display_name),
UNIQUE (user_id, contact_profile_id)
);
@ -64,7 +67,8 @@ CREATE TABLE groups (
inv_queue_info BLOB,
FOREIGN KEY (user_id, local_display_name)
REFERENCES display_names (user_id, local_display_name)
ON DELETE RESTRICT,
ON DELETE RESTRICT
ON UPDATE CASCADE,
UNIQUE (user_id, local_display_name),
UNIQUE (user_id, group_profile_id)
);
@ -74,20 +78,32 @@ CREATE TABLE group_members ( -- group members, excluding the local user
group_id INTEGER NOT NULL REFERENCES groups ON DELETE RESTRICT,
member_id BLOB NOT NULL, -- shared member ID, unique per group
member_role TEXT NOT NULL, -- owner, admin, member
member_status TEXT NOT NULL, -- new, invited, accepted, connected, ready
member_category TEXT NOT NULL, -- see GroupMemberCategory
member_status TEXT NOT NULL, -- see GroupMemberStatus
invited_by INTEGER REFERENCES contacts (contact_id) ON DELETE RESTRICT, -- NULL for the members who joined before the current user and for the group creator
group_queue_info BLOB,
direct_queue_info BLOB,
user_id INTEGER NOT NULL REFERENCES users,
local_display_name TEXT NOT NULL, -- should be the same as contact
contact_profile_id INTEGER NOT NULL REFERENCES contact_profiles ON DELETE RESTRICT,
contact_id INTEGER REFERENCES contacts ON DELETE RESTRICT,
FOREIGN KEY (user_id, local_display_name)
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, contact_id),
UNIQUE (group_id, local_display_name)
);
CREATE TABLE group_member_intros (
group_member_intro_id INTEGER PRIMARY KEY,
group_member_id INTEGER NOT NULL REFERENCES group_members ON DELETE CASCADE,
re_group_member_id INTEGER NOT NULL REFERENCES group_members (group_member_id) ON DELETE CASCADE,
to_group_member_id INTEGER NOT NULL REFERENCES group_members (group_member_id) ON DELETE CASCADE,
intro_status TEXT NOT NULL DEFAULT '', -- new, intro, inv, fwd, con
UNIQUE (group_member_id, to_group_member_id)
group_queue_info BLOB,
direct_queue_info BLOB,
intro_status TEXT NOT NULL, -- see GroupMemberIntroStatus
UNIQUE (re_group_member_id, to_group_member_id)
);
CREATE TABLE connections ( -- all SMP agent connections

337
src/Simplex/Chat.hs
View File

@ -23,7 +23,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List (find)
import Data.Maybe (isJust, isNothing)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
@ -77,7 +77,7 @@ cfg =
connIdBytes = 12,
tbqSize = 16,
dbFile = undefined, -- filled in from options
dbPoolSize = 4,
dbPoolSize = 1,
smpCfg = smpDefaultConfig
}
@ -85,7 +85,7 @@ logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
simplexChat :: WithTerminal t => ChatOpts -> t -> IO ()
simplexChat opts t = do
simplexChat opts t =
-- setLogLevel LogInfo -- LogError
-- withGlobalLogging logCfg $ do
initializeNotifications
@ -94,7 +94,7 @@ simplexChat opts t = do
newChatController :: WithTerminal t => ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
newChatController ChatOpts {dbFile, smpServers} t sendNotification = do
chatStore <- createStore (dbFile <> ".chat.db") 4
chatStore <- createStore (dbFile <> ".chat.db") 1
currentUser <- getCreateActiveUser chatStore
chatTerminal <- newChatTerminal t
smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
@ -126,6 +126,7 @@ inputSubscriber = do
Right cmd -> do
case cmd of
SendMessage c msg -> showSentMessage c msg
SendGroupMessage g msg -> showSentGroupMessage g msg
_ -> printToView [plain s]
user <- asks currentUser
void . runExceptT $ processChatCommand user cmd `catchError` showChatError
@ -150,7 +151,7 @@ processChatCommand user@User {userId, profile} = \case
showContactDeleted cName
SendMessage cName msg -> do
contact <- withStore $ \st -> getContact st userId cName
let msgEvent = XMsgNew MTText [] [MsgBodyContent {contentType = SimplexContentType XCText, contentData = msg}]
let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
sendDirectMessage (contactConnId contact) msgEvent
setActive $ ActiveC cName
NewGroup gProfile -> do
@ -162,29 +163,39 @@ 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 CEGroupRole
when (userRole < GRAdmin || userRole < memRole) $ throwError $ ChatError CEGroupUserRole
when (isMember contact members) . throwError . ChatError $ CEGroupDuplicateMember cName
when (memberStatus membership == GSMemInvited) . throwError . ChatError $ CEGroupNotJoined gName
when (memberStatus membership < GSMemReady) . throwError . ChatError $ CEGroupMemberNotReady
unless (memberActive membership) . throwError . ChatError $ CEGroupMemberNotActive
gVar <- asks idsDrg
(agentConnId, qInfo) <- withAgent createConnection
GroupMember {memberId} <- withStore $ \st -> createGroupMember st gVar user groupId contact memRole agentConnId
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
setActive $ ActiveG gName
JoinGroup gName -> do
ReceivedGroupInvitation {fromMember, invitedMember, queueInfo} <- withStore $ \st -> getGroupInvitation st user gName
agentConnId <- withAgent $ \a -> joinConnection a queueInfo . directMessage . XGrpAcpt $ memberId invitedMember
withStore $ \st -> createMemberConnection st userId (groupMemberId fromMember) agentConnId
MemberRole _gRef _cRef _mRole -> pure ()
RemoveMember _gRef _cRef -> pure ()
LeaveGroup _gRef -> pure ()
DeleteGroup _gRef -> pure ()
ListMembers _gRef -> pure ()
SendGroupMessage _gRef _msg -> pure ()
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
MemberRole _gName _cName _mRole -> pure ()
RemoveMember _gName _cName -> pure ()
LeaveGroup _gName -> pure ()
DeleteGroup _gName -> pure ()
ListMembers _gName -> pure ()
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
let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
sendGroupMessage members msgEvent
setActive $ ActiveG gName
where
isMember :: Contact -> [(GroupMember, Maybe Connection)] -> Bool
isMember Contact {contactId} members = isJust $ find ((== Just contactId) . memberContactId . fst) members
isMember :: Contact -> [GroupMember] -> Bool
isMember Contact {contactId} members = isJust $ find ((== Just contactId) . memberContactId) members
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
agentSubscriber = do
@ -199,92 +210,230 @@ processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agen
processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId
case chatDirection of
ReceivedDirectMessage (CContact ct@Contact {localDisplayName = c}) ->
ReceivedDMContact ct@Contact {localDisplayName = c, activeConn} ->
case agentMessage of
MSG meta msgBody -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
case chatMsgEvent of
XMsgNew MTText [] body -> newTextMessage c meta $ find (isSimplexContentType XCText) body
XMsgNew (MsgContent MTText [] body) -> newTextMessage c meta $ find (isSimplexContentType XCText) body
XInfo _ -> pure () -- TODO profile update
XGrpInv gInv -> saveGroupInvitation ct gInv
XGrpInv gInv -> processGroupInvitation ct gInv
_ -> pure ()
CON -> do
-- TODO update connection status
showContactConnected ct
showToast ("@" <> c) "connected"
setActive $ ActiveC c
END -> do
showContactDisconnected c
showToast ("@" <> c) "disconnected"
unsetActive $ ActiveC c
_ -> pure ()
ReceivedDirectMessage (CConnection conn) ->
case agentMessage of
CONF confId connInfo -> do
-- TODO update connection status
saveConnInfo conn connInfo
withAgent $ \a -> allowConnection a agentConnId confId . directMessage $ XInfo profile
INFO connInfo ->
saveConnInfo conn connInfo
_ -> pure ()
ReceivedGroupMessage gName m ->
case agentMessage of
CONF confId connInfo -> do
-- confirming direct connection with a member
withStore $ \st -> updateConnectionStatus st activeConn ConnRequested
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case chatMsgEvent of
XGrpAcpt memId
| memId == memberId m -> do
withStore $ \st -> updateGroupMemberStatus st userId (groupMemberId m) GSMemAccepted
withAgent $ \a -> allowConnection a agentConnId confId ""
| otherwise -> pure () -- TODO error not matching member ID
_ -> pure () -- TODO show/log error, other events in SMP confirmation
XGrpMemInfo _memId _memProfile -> do
-- TODO check member ID
-- TODO update member profile
acceptAgentConnection activeConn confId XOk
_ -> messageError "CONF from member must have x.grp.mem.info"
INFO connInfo -> do
withStore $ \st -> updateConnectionStatus st activeConn ConnSndReady
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case chatMsgEvent of
XGrpMemInfo _memId _memProfile -> do
-- TODO check member ID
-- TODO update member profile
pure ()
XOk -> pure ()
_ -> messageError "INFO from member must have x.grp.mem.info or x.ok"
CON -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
-- TODO because the contact is not created instantly, if the member is not created from contact,
-- it should still have a unique local display name.
-- If it is created from contact it can still be duplicated on the member (and match the contact)
case invitedBy m of
IBUser -> do
-- sender was invited by the current user
withStore $ \st -> updateGroupMemberStatus st userId (groupMemberId m) GSMemConnected
sendGroupMessage members $ XGrpMemNew (memberId m) (memberRole m) (memberProfile m)
showConnectedGroupMember gName $ displayName (memberProfile m :: Profile)
forM_ (filter (\m' -> memberStatus m' >= GSMemConnected) . map fst $ members) $ \m' ->
sendDirectMessage agentConnId $ XGrpMemIntro (memberId m') (memberRole m') (memberProfile m')
withStore $ \st -> updateConnectionStatus st activeConn ConnReady
withStore (\st -> getViaGroupMember st user ct) >>= \case
Nothing -> do
showContactConnected ct
setActive $ ActiveC c
showToast (c <> "> ") "connected"
Just (gName, m) ->
when (memberIsReady m) $ notifyMemberConnected gName m
END -> do
showContactDisconnected c
showToast (c <> "> ") "disconnected"
unsetActive $ ActiveC c
_ -> messageError $ "unexpected agent event: " <> T.pack (show agentMessage)
ReceivedDMConnection conn ->
case agentMessage of
CONF confId connInfo -> do
withStore $ \st -> updateConnectionStatus st conn ConnRequested
saveConnInfo conn connInfo
acceptAgentConnection conn confId $ XInfo profile
INFO connInfo -> do
withStore $ \st -> updateConnectionStatus st conn ConnSndReady
saveConnInfo conn connInfo
CON ->
withStore $ \st -> updateConnectionStatus st conn ConnReady
_ -> messageError $ "unsupported agent event: " <> T.pack (show agentMessage)
ReceivedGroupMessage conn gName m ->
case agentMessage of
CONF confId connInfo -> do
withStore $ \st -> updateConnectionStatus st conn ConnRequested
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case memberCategory m of
GCInviteeMember ->
case chatMsgEvent of
XGrpAcpt memId
| memId == memberId m -> do
withStore $ \st -> updateGroupMemberStatus st userId (groupMemberId 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"
_ ->
case chatMsgEvent of
XGrpMemInfo memId _memProfile
| memId == memberId m -> do
-- TODO update member profile
Group {membership} <- withStore $ \st -> getGroup st user gName
acceptAgentConnection conn confId $ XGrpMemInfo (memberId membership) profile
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
_ -> messageError "CONF from member must have x.grp.mem.info"
INFO connInfo -> do
withStore $ \st -> updateConnectionStatus st conn ConnSndReady
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case chatMsgEvent of
XGrpMemInfo memId _memProfile
| memId == memberId m -> do
-- TODO update member profile
pure ()
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
XOk -> pure ()
_ -> messageError "INFO from member must have x.grp.mem.info"
pure ()
CON -> do
group@Group {members, membership} <- withStore $ \st -> getGroup st user gName
withStore $ \st -> do
updateConnectionStatus st conn ConnReady
updateGroupMemberStatus st userId (groupMemberId m) GSMemConnected
updateGroupMemberStatus st userId (groupMemberId membership) GSMemConnected
-- TODO forward any pending (GMIntroInvReceived) introductions
case memberCategory m of
GCHostMember -> do
showUserJoinedGroup gName
setActive $ ActiveG gName
showToast ("#" <> gName) "you are connected to group"
GCInviteeMember -> do
showJoinedGroupMember gName m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
intros <- withStore $ \st -> createIntroductions st group m
sendGroupMessage members . XGrpMemNew $ memberInfo m
forM_ intros $ \intro -> do
sendDirectMessage agentConnId . XGrpMemIntro . memberInfo $ reMember intro
withStore $ \st -> updateIntroStatus st intro GMIntroSent
_ -> do
if Just (invitedBy membership) == (IBContact <$> memberContactId m)
then do
-- sender invited the current user
withStore $ \st -> updateGroupMemberStatus st userId (groupMemberId m) GSMemConnected
showUserConnectedToGroup gName
pure ()
else do
showConnectedGroupMember gName $ displayName (memberProfile m :: Profile)
-- TODO send probe and decide whether to use existing contact connection or the new contact connection
-- TODO notify member who forwarded introduction - question - where it is stored? There is via_contact but probably there should be via_member in group_members table
withStore (\st -> getViaGroupContact st user m) >>= \case
Nothing -> do
notifyMemberConnected gName m
messageError "implementation error: connected member does not have contact"
Just ct ->
when (contactIsReady ct) $ notifyMemberConnected gName m
MSG meta msgBody -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
case chatMsgEvent of
XGrpMemNew memId memRole memProfile -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
when (memberId membership /= memId && isNothing (find ((== memId) . memberId . fst) members)) $
withStore $ \st -> pure () -- add new member as GSMemAccepted
_ -> pure ()
_ -> pure ()
XMsgNew (MsgContent MTText [] body) ->
newGroupTextMessage gName m meta $ find (isSimplexContentType XCText) body
XGrpMemNew memInfo@(MemberInfo memId _ _) -> do
group@Group {membership} <- withStore $ \st -> getGroup st user gName
when (memberId membership /= memId) $
if isMember memId group
then messageError "x.grp.mem.new error: member already exists"
else do
newMember <- withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced
showJoinedGroupMemberConnecting gName m newMember
XGrpMemIntro memInfo@(MemberInfo memId _ _) ->
case memberCategory m of
GCHostMember -> do
group <- withStore $ \st -> getGroup st user gName
if isMember memId group
then messageWarning "x.grp.mem.intro ignored: member already exists"
else do
(groupConnId, groupQInfo) <- withAgent createConnection
(directConnId, directQInfo) <- withAgent createConnection
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
_ -> messageError "x.grp.mem.intro can be only sent by host member"
XGrpMemInv memId introInv ->
case memberCategory m of
GCInviteeMember -> do
group <- withStore $ \st -> getGroup st user gName
case find ((== memId) . memberId) $ members group of
Nothing -> messageError "x.grp.mem.inv error: referenced member does not exists"
Just reMember -> do
intro <- withStore $ \st -> saveIntroInvitation st reMember m introInv
case activeConn (reMember :: GroupMember) of
Nothing -> pure () -- this is not an error, introduction will be forwarded once the member is connected
Just Connection {agentConnId = reAgentConnId} -> do
sendDirectMessage reAgentConnId $ XGrpMemFwd (memberInfo m) introInv
withStore $ \st -> updateIntroStatus st intro GMIntroInvForwarded
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
XGrpMemFwd memInfo@(MemberInfo memId _ _) introInv@IntroInvitation {groupQInfo, directQInfo} -> do
group@Group {membership} <- withStore $ \st -> getGroup st user gName
toMember <- case find ((== memId) . memberId) $ members group of
-- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
-- the situation when member does not exist is an error
-- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
-- For now, this branch compensates for the lack of delayed message delivery.
Nothing -> withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced
Just m' -> pure m'
withStore $ \st -> saveMemberInvitation st toMember introInv
let msg = XGrpMemInfo (memberId membership) profile
groupConnId <- withAgent $ \a -> joinConnection a groupQInfo $ directMessage msg
directConnId <- withAgent $ \a -> joinConnection a directQInfo $ directMessage msg
withStore $ \st -> createIntroToMemberContact st userId m toMember groupConnId directConnId
_ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent)
_ -> messageError $ "unsupported agent event: " <> T.pack (show agentMessage)
where
newTextMessage :: ContactName -> MsgMeta -> Maybe MsgBodyContent -> m ()
isMember :: MemberId -> Group -> Bool
isMember memId Group {membership, members} =
memberId membership == memId || isJust (find ((== memId) . memberId) members)
contactIsReady :: Contact -> Bool
contactIsReady Contact {activeConn} = connStatus activeConn == ConnReady
memberIsReady :: GroupMember -> Bool
memberIsReady GroupMember {activeConn} = maybe False ((== ConnReady) . connStatus) activeConn
notifyMemberConnected :: GroupName -> GroupMember -> m ()
notifyMemberConnected gName m@GroupMember {localDisplayName} = do
showConnectedToGroupMember gName m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName <> " is connected"
messageWarning :: Text -> m ()
messageWarning = liftIO . print
messageError :: Text -> m ()
messageError = liftIO . print
newTextMessage :: ContactName -> MsgMeta -> Maybe MsgContentBody -> m ()
newTextMessage c meta = \case
Just MsgBodyContent {contentData = bs} -> do
Just MsgContentBody {contentData = bs} -> do
let text = safeDecodeUtf8 bs
showReceivedMessage c (snd $ broker meta) text (integrity meta)
showToast ("@" <> c) text
showToast (c <> "> ") text
setActive $ ActiveC c
_ -> pure ()
_ -> messageError "x.msg.new: no expected message body"
saveGroupInvitation :: Contact -> GroupInvitation -> m ()
saveGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (fromMemId, fromRole) (memId, memRole) _ _) = do
when (fromRole < GRAdmin || fromRole < memRole) $ throwError $ ChatError CEGroupRole
newGroupTextMessage :: GroupName -> GroupMember -> MsgMeta -> Maybe MsgContentBody -> m ()
newGroupTextMessage gName GroupMember {localDisplayName = c} meta = \case
Just MsgContentBody {contentData = bs} -> do
let text = safeDecodeUtf8 bs
showReceivedGroupMessage gName c (snd $ broker meta) text (integrity meta)
showToast ("#" <> gName <> " " <> c <> "> ") text
setActive $ ActiveG gName
_ -> messageError "x.msg.new: no expected message body"
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
group <- withStore $ \st -> createGroupInvitation st user ct inv
showReceivedGroupInvitation group localDisplayName
showReceivedGroupInvitation group localDisplayName memRole
parseChatMessage :: ByteString -> Either ChatError ChatMessage
parseChatMessage msgBody = first ChatErrorMessage (parseAll rawChatMessageP msgBody >>= toChatMessage)
@ -306,8 +455,18 @@ directMessage chatMsgEvent =
serializeRawChatMessage $
rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent, chatDAG = Nothing}
sendGroupMessage :: ChatMonad m => [(GroupMember, Maybe Connection)] -> ChatMsgEvent -> m ()
sendGroupMessage _members _chatMsgEvent = pure ()
sendGroupMessage :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> m ()
sendGroupMessage members chatMsgEvent = do
let msg = directMessage chatMsgEvent
-- TODO once scheduled delivery is implemented memberActive should be changed to memberCurrent
withAgent $ \a ->
forM_ (filter memberActive members) $
traverse (\connId -> sendMessage a connId msg) . memberConnId
acceptAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m ()
acceptAgentConnection conn@Connection {agentConnId} confId msg = do
withAgent $ \a -> allowConnection a agentConnId confId $ directMessage msg
withStore $ \st -> updateConnectionStatus st conn ConnAccepted
getCreateActiveUser :: SQLiteStore -> IO User
getCreateActiveUser st = do
@ -393,9 +552,9 @@ withStore action =
chatCommandP :: Parser ChatCommand
chatCommandP =
("/help" <|> "/h") $> ChatHelp
<|> ("/group #" <|> "/g #") *> (NewGroup <$> groupProfile)
<|> ("/add #" <|> "/a #") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole)
<|> ("/join #" <|> "/j #") *> (JoinGroup <$> displayName)
<|> ("/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)
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName)
<|> ("/members #" <|> "/ms #") *> (ListMembers <$> displayName)
@ -416,4 +575,4 @@ chatCommandP =
(" owner" $> GROwner)
<|> (" admin" $> GRAdmin)
<|> (" normal" $> GRMember)
<|> pure GRMember
<|> pure GRAdmin

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

@ -41,11 +41,12 @@ data ChatError
deriving (Show, Exception)
data ChatErrorType
= CEGroupRole
= CEGroupUserRole
| CEGroupContactRole ContactName
| CEGroupDuplicateMember ContactName
| CEGroupDuplicateMemberId
| CEGroupNotJoined GroupName
| CEGroupMemberNotReady
| CEGroupMemberNotActive
| CEGroupInternal String
deriving (Show, Exception)

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

@ -81,7 +81,7 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition
contactPrefix = case ac of
ActiveNone -> ""
ActiveC c -> "@" <> T.unpack c <> " "
-- ActiveG (Group g) -> "#" <> B.unpack g <> " "
ActiveG g -> "#" <> T.unpack g <> " "
backDeleteChar
| p == 0 || null s = ts
| p >= length s = ts' (init s, length s - 1)

1
src/Simplex/Chat/Notification.hs
View File

@ -5,7 +5,6 @@
module Simplex.Chat.Notification (Notification (..), initializeNotifications) where
import Control.Monad (void)
import Data.Char (toLower)
import Data.List (isInfixOf)
import Data.Text (Text)
import qualified Data.Text as T

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

@ -29,33 +29,43 @@ import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util (bshow)
data ChatDirection (p :: AParty) where
ReceivedDirectMessage :: ConnContact -> ChatDirection 'Agent
ReceivedDMConnection :: Connection -> ChatDirection 'Agent
ReceivedDMContact :: Contact -> ChatDirection 'Agent
SentDirectMessage :: Contact -> ChatDirection 'Client
ReceivedGroupMessage :: GroupName -> GroupMember -> ChatDirection 'Agent
ReceivedGroupMessage :: Connection -> GroupName -> GroupMember -> ChatDirection 'Agent
SentGroupMessage :: GroupName -> ChatDirection 'Client
deriving instance Eq (ChatDirection p)
deriving instance Show (ChatDirection p)
data ConnContact = CContact Contact | CConnection Connection
deriving (Eq, Show)
data ChatMsgEvent
= XMsgNew
{ messageType :: MessageType,
files :: [(ContentType, Int)],
content :: [MsgBodyContent]
}
= XMsgNew MsgContent
| XInfo Profile
| XGrpInv GroupInvitation
| XGrpAcpt MemberId
| XGrpMemNew MemberId GroupMemberRole Profile
| XGrpMemIntro MemberId GroupMemberRole Profile
| XGrpMemNew MemberInfo
| XGrpMemIntro MemberInfo
| XGrpMemInv MemberId IntroInvitation
| XGrpMemFwd MemberInfo IntroInvitation
| XGrpMemInfo MemberId Profile
| XGrpMemCon MemberId
| XGrpMemConAll MemberId
| XInfoProbe ByteString
| XInfoProbeCheck MemberId ByteString
| XInfoProbeOk MemberId ByteString
| XOk
deriving (Eq, Show)
data MessageType = MTText | MTImage deriving (Eq, Show)
data MsgContent = MsgContent
{ messageType :: MessageType,
files :: [(ContentType, Int)],
content :: [MsgContentBody]
}
deriving (Eq, Show)
toMsgType :: ByteString -> Either String MessageType
toMsgType = \case
"c.text" -> Right MTText
@ -77,118 +87,148 @@ data ChatMessage = ChatMessage
toChatMessage :: RawChatMessage -> Either String ChatMessage
toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
(chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody
case chatMsgEvent of
"x.msg.new" -> case chatMsgParams of
mt : rawFiles -> do
t <- toMsgType mt
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
let msg = XMsgNew {messageType = t, files, content = body}
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
[] -> Left "x.msg.new expects at least one parameter"
"x.info" -> case chatMsgParams of
[] -> do
profile <- getJSON body
pure ChatMessage {chatMsgId, chatMsgEvent = XInfo profile, chatDAG}
_ -> Left "x.info expects no parameters"
"x.grp.inv" -> case chatMsgParams of
[fromMemId, fromRole, memId, role, qInfo] -> do
fromMember <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole
invitedMember <- (,) <$> B64.decode memId <*> toMemberRole role
inv <- GroupInvitation fromMember invitedMember <$> parseAll smpQueueInfoP qInfo <*> getJSON body
pure ChatMessage {chatMsgId, chatMsgEvent = XGrpInv inv, chatDAG}
_ -> Left "x.grp.inv expects 5 parameters"
"x.grp.acpt" -> case chatMsgParams of
[memId] -> do
msg <- XGrpAcpt <$> B64.decode memId
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
_ -> Left "x.grp.acpt expects one parameter"
"x.grp.mem.new" -> memberMessage chatMsgParams XGrpMemNew body chatDAG
"x.grp.mem.intro" -> memberMessage chatMsgParams XGrpMemIntro body chatDAG
_ -> Left $ "unsupported event " <> B.unpack chatMsgEvent
let chatMsg msg = pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
case (chatMsgEvent, chatMsgParams) of
("x.msg.new", mt : rawFiles) -> do
t <- toMsgType mt
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
chatMsg . XMsgNew $ MsgContent {messageType = t, files, content = body}
("x.info", []) -> do
profile <- getJSON body
chatMsg $ XInfo profile
("x.grp.inv", [fromMemId, fromRole, memId, role, qInfo]) -> do
fromMem <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole
invitedMem <- (,) <$> B64.decode memId <*> toMemberRole role
groupQInfo <- parseAll smpQueueInfoP qInfo
profile <- getJSON body
chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupQInfo profile
("x.grp.acpt", [memId]) ->
chatMsg . XGrpAcpt =<< B64.decode memId
("x.grp.mem.new", [memId, role]) -> do
chatMsg . XGrpMemNew =<< toMemberInfo memId role body
("x.grp.mem.intro", [memId, role]) ->
chatMsg . XGrpMemIntro =<< toMemberInfo memId role body
("x.grp.mem.inv", [memId, groupQInfo, directQInfo]) ->
chatMsg =<< (XGrpMemInv <$> B64.decode memId <*> toIntroInv groupQInfo directQInfo)
("x.grp.mem.fwd", [memId, role, groupQInfo, directQInfo]) -> do
chatMsg =<< (XGrpMemFwd <$> toMemberInfo memId role body <*> toIntroInv groupQInfo directQInfo)
("x.grp.mem.info", [memId]) ->
chatMsg =<< (XGrpMemInfo <$> B64.decode memId <*> getJSON body)
("x.grp.mem.con", [memId]) ->
chatMsg . XGrpMemCon =<< B64.decode memId
("x.grp.mem.con.all", [memId]) ->
chatMsg . XGrpMemConAll =<< B64.decode memId
("x.info.probe", [probe]) -> do
chatMsg . XInfoProbe =<< B64.decode probe
("x.info.probe.check", [memId, probeHash]) -> do
chatMsg =<< (XInfoProbeCheck <$> B64.decode memId <*> B64.decode probeHash)
("x.info.probe.ok", [memId, probe]) -> do
chatMsg =<< (XInfoProbeOk <$> B64.decode memId <*> B64.decode probe)
("x.ok", []) ->
chatMsg XOk
_ -> Left $ "bad syntax or unsupported event " <> B.unpack chatMsgEvent
where
getDAG :: [MsgBodyContent] -> (Maybe ByteString, [MsgBodyContent])
getDAG :: [MsgContentBody] -> (Maybe ByteString, [MsgContentBody])
getDAG body = case break (isContentType SimplexDAG) body of
(b, MsgBodyContent SimplexDAG dag : a) -> (Just dag, b <> a)
(b, MsgContentBody SimplexDAG dag : a) -> (Just dag, b <> a)
_ -> (Nothing, body)
memberMessage ::
FromJSON a => [ByteString] -> (MemberId -> GroupMemberRole -> a -> ChatMsgEvent) -> [MsgBodyContent] -> Maybe ByteString -> Either String ChatMessage
memberMessage [memId, role] mkMsg body chatDAG = do
msg <- mkMsg <$> B64.decode memId <*> toMemberRole role <*> getJSON body
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
memberMessage _ _ _ _ = Left "message expects 2 parameters"
toMemberInfo :: ByteString -> ByteString -> [MsgContentBody] -> Either String MemberInfo
toMemberInfo memId role body = MemberInfo <$> B64.decode memId <*> toMemberRole role <*> getJSON body
toIntroInv :: ByteString -> ByteString -> Either String IntroInvitation
toIntroInv groupQInfo directQInfo = IntroInvitation <$> parseAll smpQueueInfoP groupQInfo <*> parseAll smpQueueInfoP directQInfo
toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
toContentInfo (rawType, size) = (,size) <$> toContentType rawType
getJSON :: FromJSON a => [MsgBodyContent] -> Either String a
getJSON :: FromJSON a => [MsgContentBody] -> Either String a
getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson
isContentType :: ContentType -> MsgBodyContent -> Bool
isContentType t MsgBodyContent {contentType = t'} = t == t'
isContentType :: ContentType -> MsgContentBody -> Bool
isContentType t MsgContentBody {contentType = t'} = t == t'
isSimplexContentType :: XContentType -> MsgBodyContent -> Bool
isSimplexContentType :: XContentType -> MsgContentBody -> Bool
isSimplexContentType = isContentType . SimplexContentType
getContentType :: ContentType -> [MsgBodyContent] -> Either String ByteString
getContentType :: ContentType -> [MsgContentBody] -> Either String ByteString
getContentType t body = case find (isContentType t) body of
Just MsgBodyContent {contentData} -> Right contentData
Just MsgContentBody {contentData} -> Right contentData
Nothing -> Left "no required content type"
getSimplexContentType :: XContentType -> [MsgBodyContent] -> Either String ByteString
getSimplexContentType :: XContentType -> [MsgContentBody] -> Either String ByteString
getSimplexContentType = getContentType . SimplexContentType
rawChatMessage :: ChatMessage -> RawChatMessage
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
case chatMsgEvent of
XMsgNew {messageType = t, files, content} ->
XMsgNew MsgContent {messageType = t, files, content} ->
let rawFiles = map (serializeContentInfo . rawContentInfo) files
chatMsgParams = rawMsgType t : rawFiles
chatMsgBody = rawWithDAG content
in RawChatMessage {chatMsgId, chatMsgEvent = "x.msg.new", chatMsgParams, chatMsgBody}
in rawMsg "x.msg.new" (rawMsgType t : rawFiles) content
XInfo profile ->
let chatMsgBody = rawWithDAG [jsonBody profile]
in RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody}
rawMsg "x.info" [] [jsonBody profile]
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) qInfo groupProfile) ->
let chatMsgParams =
let params =
[ B64.encode fromMemId,
serializeMemberRole fromRole,
B64.encode memId,
serializeMemberRole role,
serializeSmpQueueInfo qInfo
]
chatMsgBody = rawWithDAG [jsonBody groupProfile]
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.inv", chatMsgParams, chatMsgBody}
in rawMsg "x.grp.inv" params [jsonBody groupProfile]
XGrpAcpt memId ->
let chatMsgParams = [B64.encode memId]
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.acpt", chatMsgParams, chatMsgBody = []}
XGrpMemNew memId role profile ->
let chatMsgParams = [B64.encode memId, serializeMemberRole role]
chatMsgBody = rawWithDAG [jsonBody profile]
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.mem.new", chatMsgParams, chatMsgBody}
XGrpMemIntro memId role profile ->
let chatMsgParams = [B64.encode memId, serializeMemberRole role]
chatMsgBody = rawWithDAG [jsonBody profile]
in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.mem.intro", chatMsgParams, chatMsgBody}
rawMsg "x.grp.acpt" [B64.encode memId] []
XGrpMemNew (MemberInfo memId role profile) ->
let params = [B64.encode memId, serializeMemberRole role]
in rawMsg "x.grp.mem.new" params [jsonBody profile]
XGrpMemIntro (MemberInfo memId role profile) ->
rawMsg "x.grp.mem.intro" [B64.encode memId, serializeMemberRole role] [jsonBody profile]
XGrpMemInv memId IntroInvitation {groupQInfo, directQInfo} ->
let params = [B64.encode memId, serializeSmpQueueInfo groupQInfo, serializeSmpQueueInfo directQInfo]
in rawMsg "x.grp.mem.inv" params []
XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupQInfo, directQInfo} ->
let params =
[ B64.encode memId,
serializeMemberRole role,
serializeSmpQueueInfo groupQInfo,
serializeSmpQueueInfo directQInfo
]
in rawMsg "x.grp.mem.fwd" params [jsonBody profile]
XGrpMemInfo memId profile ->
rawMsg "x.grp.mem.info" [B64.encode memId] [jsonBody profile]
XGrpMemCon memId ->
rawMsg "x.grp.mem.con" [B64.encode memId] []
XGrpMemConAll memId ->
rawMsg "x.grp.mem.con.all" [B64.encode memId] []
XInfoProbe probe ->
rawMsg "x.info.probe" [B64.encode probe] []
XInfoProbeCheck memId probeHash ->
rawMsg "x.info.probe.check" [B64.encode memId, B64.encode probeHash] []
XInfoProbeOk memId probe ->
rawMsg "x.info.probe.ok" [B64.encode memId, B64.encode probe] []
XOk ->
rawMsg "x.ok" [] []
where
rawMsg :: ByteString -> [ByteString] -> [MsgContentBody] -> RawChatMessage
rawMsg event chatMsgParams body =
RawChatMessage {chatMsgId, chatMsgEvent = event, chatMsgParams, chatMsgBody = rawWithDAG body}
rawContentInfo :: (ContentType, Int) -> (RawContentType, Int)
rawContentInfo (t, size) = (rawContentType t, size)
jsonBody :: ToJSON a => a -> MsgBodyContent
jsonBody :: ToJSON a => a -> MsgContentBody
jsonBody x =
let json = LB.toStrict $ J.encode x
in MsgBodyContent {contentType = SimplexContentType XCJson, contentData = json}
rawWithDAG :: [MsgBodyContent] -> [RawMsgBodyContent]
in MsgContentBody {contentType = SimplexContentType XCJson, contentData = json}
rawWithDAG :: [MsgContentBody] -> [RawMsgBodyContent]
rawWithDAG body = map rawMsgBodyContent $ case chatDAG of
Nothing -> body
Just dag -> MsgBodyContent {contentType = SimplexDAG, contentData = dag} : body
Just dag -> MsgContentBody {contentType = SimplexDAG, contentData = dag} : body
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgBodyContent
toMsgBodyContent :: RawMsgBodyContent -> Either String MsgContentBody
toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do
cType <- toContentType contentType
pure MsgBodyContent {contentType = cType, contentData}
pure MsgContentBody {contentType = cType, contentData}
rawMsgBodyContent :: MsgBodyContent -> RawMsgBodyContent
rawMsgBodyContent MsgBodyContent {contentType = t, contentData} =
rawMsgBodyContent :: MsgContentBody -> RawMsgBodyContent
rawMsgBodyContent MsgContentBody {contentType = t, contentData} =
RawMsgBodyContent {contentType = rawContentType t, contentData}
data MsgBodyContent = MsgBodyContent
data MsgContentBody = MsgContentBody
{ contentType :: ContentType,
contentData :: ByteString
}

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

@ -25,13 +25,23 @@ module Simplex.Chat.Store
getContact,
getContactConnections,
getConnectionChatDirection,
updateConnectionStatus,
createNewGroup,
createGroupInvitation,
getGroup,
getGroupInvitation,
createGroupMember,
createContactGroupMember,
createMemberConnection,
updateGroupMemberStatus,
createNewGroupMember,
createIntroductions,
updateIntroStatus,
saveIntroInvitation,
createIntroReMember,
createIntroToMemberContact,
saveMemberInvitation,
getViaGroupMember,
getViaGroupContact,
)
where
@ -51,7 +61,7 @@ import Data.Maybe (listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), SQLError, (:.) (..))
import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
@ -129,23 +139,36 @@ setActiveUser st userId = do
createDirectConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> m ()
createDirectConnection st userId agentConnId =
liftIO . withTransaction st $ \db ->
DB.execute
db
[sql|
INSERT INTO connections
(user_id, agent_conn_id, conn_status, conn_type) VALUES (?,?,?,?);
|]
(userId, agentConnId, ConnNew, ConnContact)
void $ createConnection_ db userId agentConnId Nothing 0
createConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> IO Connection
createConnection_ db userId agentConnId viaContact connLevel = do
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO connections
(user_id, agent_conn_id, conn_status, conn_type, via_contact, conn_level, created_at) VALUES (?,?,?,?,?,?,?);
|]
(userId, agentConnId, ConnNew, ConnContact, viaContact, connLevel, createdAt)
connId <- insertedRowId db
pure Connection {connId, agentConnId, connType = ConnContact, entityId = Nothing, viaContact, connLevel, connStatus = ConnNew, createdAt}
createDirectContact :: StoreMonad m => SQLiteStore -> UserId -> Connection -> Profile -> m ()
createDirectContact st userId Connection {connId} Profile {displayName, fullName} =
liftIOEither . withTransaction st $ \db ->
withLocalDisplayName db userId displayName $ \localDisplayName' -> do
DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
profileId <- insertedRowId db
DB.execute db "INSERT INTO contacts (contact_profile_id, local_display_name, user_id) VALUES (?, ?, ?)" (profileId, localDisplayName', userId)
contactId <- insertedRowId db
DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId)
createDirectContact st userId Connection {connId} profile =
void $
liftIOEither . withTransaction st $ \db ->
createContact_ db userId connId profile Nothing
createContact_ :: DB.Connection -> UserId -> Int64 -> Profile -> Maybe Int64 -> IO (Either StoreError (Text, Int64, Int64))
createContact_ db userId connId Profile {displayName, fullName} viaGroup =
withLocalDisplayName db userId displayName $ \ldn -> do
DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
profileId <- insertedRowId db
DB.execute db "INSERT INTO contacts (contact_profile_id, local_display_name, user_id, via_group) VALUES (?,?,?,?)" (profileId, ldn, userId, viaGroup)
contactId <- insertedRowId db
DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId)
pure (ldn, contactId, profileId)
deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactName -> m ()
deleteContact st userId displayName =
@ -178,25 +201,27 @@ deleteContact st userId displayName =
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
getContact ::
StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
getContact :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
-- TODO merge contact and connection?
getContact st userId localDisplayName =
liftIOEither . withTransaction st $ \db -> runExceptT $ do
c@Contact {contactId} <- getContact_ db
activeConn <- getConnection_ db contactId
pure $ (c :: Contact) {activeConn}
where
getContact_ :: DB.Connection -> ExceptT StoreError IO Contact
getContact_ db = ExceptT $ do
toContact
<$> DB.queryNamed
db
[sql|
SELECT c.contact_id, p.display_name, p.full_name
SELECT c.contact_id, p.display_name, p.full_name, c.via_group
FROM contacts c
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
WHERE c.user_id = :user_id AND c.local_display_name = :local_display_name AND c.is_user = :is_user
|]
[":user_id" := userId, ":local_display_name" := localDisplayName, ":is_user" := False]
getConnection_ :: DB.Connection -> Int64 -> ExceptT StoreError IO Connection
getConnection_ db contactId = ExceptT $ do
connection
<$> DB.queryNamed
@ -210,10 +235,12 @@ getContact st userId localDisplayName =
LIMIT 1
|]
[":user_id" := userId, ":contact_id" := contactId]
toContact [(contactId, displayName, fullName)] =
toContact :: [(Int64, Text, Text, Maybe Int64)] -> Either StoreError Contact
toContact [(contactId, displayName, fullName, viaGroup)] =
let profile = Profile {displayName, fullName}
in Right Contact {contactId, localDisplayName, profile, activeConn = undefined}
in Right Contact {contactId, localDisplayName, profile, activeConn = undefined, viaGroup}
toContact _ = Left $ SEContactNotFound localDisplayName
connection :: [ConnectionRow] -> Either StoreError Connection
connection (connRow : _) = Right $ toConnection connRow
connection _ = Left $ SEContactNotReady localDisplayName
@ -263,11 +290,11 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
ConnMember ->
case entityId of
Nothing -> throwError $ SEInternal "group member without connection"
Just groupMemberId -> uncurry ReceivedGroupMessage <$> getGroupAndMember_ db groupMemberId
Just groupMemberId -> uncurry (ReceivedGroupMessage c) <$> getGroupAndMember_ db groupMemberId c
ConnContact ->
ReceivedDirectMessage <$> case entityId of
Nothing -> pure $ CConnection c
Just contactId -> getContact_ db contactId c
case entityId of
Nothing -> pure $ ReceivedDMConnection c
Just contactId -> ReceivedDMContact <$> getContact_ db contactId c
where
getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection
getConnection_ db = ExceptT $ do
@ -284,42 +311,49 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
connection :: [ConnectionRow] -> Either StoreError Connection
connection (connRow : _) = Right $ toConnection connRow
connection _ = Left $ SEConnectionNotFound agentConnId
getContact_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO ConnContact
getContact_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO Contact
getContact_ db contactId c = ExceptT $ do
toContact contactId c
<$> DB.query
db
[sql|
SELECT c.local_display_name, p.display_name, p.full_name
SELECT c.local_display_name, p.display_name, p.full_name, c.via_group
FROM contacts c
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
WHERE c.user_id = ? AND c.contact_id = ?
|]
(userId, contactId)
toContact :: Int64 -> Connection -> [(ContactName, Text, Text)] -> Either StoreError ConnContact
toContact contactId c [(localDisplayName, displayName, fullName)] =
toContact :: Int64 -> Connection -> [(ContactName, Text, Text, Maybe Int64)] -> Either StoreError Contact
toContact contactId activeConn [(localDisplayName, displayName, fullName, viaGroup)] =
let profile = Profile {displayName, fullName}
in Right $ CContact Contact {contactId, localDisplayName, profile, activeConn = c}
in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup}
toContact _ _ _ = Left $ SEInternal "referenced contact not found"
getGroupAndMember_ :: DB.Connection -> Int64 -> ExceptT StoreError IO (GroupName, GroupMember)
getGroupAndMember_ db groupMemberId = ExceptT $ do
toGroupAndMember
getGroupAndMember_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO (GroupName, GroupMember)
getGroupAndMember_ db groupMemberId c = ExceptT $ do
toGroupAndMember c
<$> DB.query
db
[sql|
SELECT
g.local_display_name,
m.group_member_id, m.member_id, m.member_role, m.member_status,
m.invited_by, m.contact_id, p.display_name, p.full_name
m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
JOIN groups g ON g.group_id = m.group_id
WHERE m.group_member_id = ?
|]
(Only groupMemberId)
toGroupAndMember :: [Only GroupName :. GroupMemberRow] -> Either StoreError (GroupName, GroupMember)
toGroupAndMember [Only groupName :. memberRow] = Right (groupName, toGroupMember userContactId memberRow)
toGroupAndMember _ = Left $ SEInternal "referenced group member not found"
toGroupAndMember :: Connection -> [Only GroupName :. GroupMemberRow] -> Either StoreError (GroupName, GroupMember)
toGroupAndMember c [Only groupName :. memberRow] =
let member = toGroupMember userContactId memberRow
in Right (groupName, (member :: GroupMember) {activeConn = Just c})
toGroupAndMember _ _ = Left $ SEInternal "referenced group member not found"
updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m ()
updateConnectionStatus st Connection {connId} connStatus =
liftIO . withTransaction st $ \db ->
DB.execute db "UPDATE connections SET conn_status = ? WHERE connection_id = ?" (connStatus, connId)
-- | creates completely new group with a single member - the current user
createNewGroup :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> GroupProfile -> m Group
@ -333,7 +367,7 @@ createNewGroup st gVar user groupProfile =
DB.execute db "INSERT INTO groups (local_display_name, user_id, group_profile_id) VALUES (?, ?, ?)" (displayName, uId, profileId)
groupId <- insertedRowId db
memberId <- randomId gVar 12
membership <- createContactMember_ db user groupId user (memberId, GROwner) GSMemFull IBUser
membership <- createContactMember_ db user groupId user (memberId, GROwner) GCUserMember GSMemCreator IBUser
pure $ Right Group {groupId, localDisplayName = displayName, groupProfile, members = [], membership}
-- | creates a new group record for the group the current user was invited to
@ -348,9 +382,9 @@ createGroupInvitation st user contact GroupInvitation {fromMember, invitedMember
profileId <- insertedRowId db
DB.execute db "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, user_id) VALUES (?, ?, ?, ?)" (profileId, localDisplayName, queueInfo, uId)
groupId <- insertedRowId db
member <- createContactMember_ db user groupId contact fromMember GSMemFull IBUnknown
membership <- createContactMember_ db user groupId user invitedMember GSMemInvited (IBContact $ contactId contact)
pure Group {groupId, localDisplayName, groupProfile, members = [(member, Nothing)], membership}
member <- createContactMember_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown
membership <- createContactMember_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact $ contactId contact)
pure Group {groupId, localDisplayName, groupProfile, members = [member], membership}
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
@ -382,15 +416,15 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
let groupProfile = GroupProfile {displayName, fullName}
in Right (Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined}, qInfo)
toGroup _ = Left $ SEGroupNotFound localDisplayName
getMembers_ :: Int64 -> ExceptT StoreError IO [(GroupMember, Maybe Connection)]
getMembers_ :: Int64 -> ExceptT StoreError IO [GroupMember]
getMembers_ groupId = ExceptT $ do
Right . map toContactMember
<$> DB.query
db
[sql|
SELECT
m.group_member_id, m.member_id, m.member_role, m.member_status,
m.invited_by, m.contact_id, p.display_name, p.full_name,
m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at
FROM group_members m
@ -398,19 +432,20 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.group_member_id = c.group_member_id
where cc.group_member_id = m.group_member_id
)
WHERE m.group_id = ?
WHERE m.group_id = ? AND m.user_id = ?
|]
(Only groupId)
toContactMember :: (GroupMemberRow :. MaybeConnectionRow) -> (GroupMember, Maybe Connection)
toContactMember (memberRow :. connRow) = (toGroupMember userContactId memberRow, toMaybeConnection connRow)
splitUserMember_ :: [(GroupMember, Maybe Connection)] -> Either StoreError ([(GroupMember, Maybe Connection)], GroupMember)
(groupId, userId)
toContactMember :: (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember (memberRow :. connRow) =
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow}
splitUserMember_ :: [GroupMember] -> Either StoreError ([GroupMember], GroupMember)
splitUserMember_ allMembers =
let (b, a) = break ((== Just userContactId) . memberContactId . fst) allMembers
let (b, a) = break ((== Just userContactId) . memberContactId) allMembers
in case a of
[] -> Left SEGroupWithoutUser
u : ms -> Right (b <> ms, fst u)
u : ms -> Right (b <> ms, u)
getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation
getGroupInvitation st user localDisplayName =
@ -418,76 +453,364 @@ getGroupInvitation st user localDisplayName =
(Group {membership, members, groupProfile}, qInfo) <- getGroup_ db user localDisplayName
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
case (qInfo, findFromContact (invitedBy membership) members) of
(Just queueInfo, Just (fromMember, Nothing)) ->
pure ReceivedGroupInvitation {fromMember, invitedMember = membership, queueInfo, groupProfile}
_ -> throwError SENoGroupInvitation
(Just queueInfo, Just fromMember) ->
pure ReceivedGroupInvitation {fromMember, userMember = membership, queueInfo, groupProfile}
_ -> throwError SEGroupInvitationNotFound
where
findFromContact :: InvitedBy -> [(GroupMember, Maybe Connection)] -> Maybe (GroupMember, Maybe Connection)
findFromContact (IBContact contactId) = find (\(m, _) -> memberContactId m == Just contactId)
findFromContact :: InvitedBy -> [GroupMember] -> Maybe GroupMember
findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId)
findFromContact _ = const Nothing
type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberStatus, Maybe Int64, Maybe Int64, ContactName, Text)
type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text)
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
toGroupMember userContactId (groupMemberId, memberId, memberRole, memberStatus, invitedById, memberContactId, displayName, fullName) =
toGroupMember userContactId (groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName) =
let memberProfile = Profile {displayName, fullName}
invitedBy = toInvitedBy userContactId invitedById
in GroupMember {groupMemberId, memberId, memberRole, memberStatus, invitedBy, memberProfile, memberContactId}
in GroupMember {groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile, memberContactId, activeConn = Nothing}
createGroupMember :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> m GroupMember
createGroupMember st gVar user groupId contact memberRole agentConnId =
createContactGroupMember :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> m GroupMember
createContactGroupMember st gVar user groupId contact memberRole agentConnId =
liftIOEither . withTransaction st $ \db ->
createWithRandomId gVar $ \memId -> do
member <- createContactMember_ db user groupId contact (memId, memberRole) GSMemInvited IBUser
member <- createContactMember_ db user groupId contact (memId, memberRole) GCInviteeMember GSMemInvited IBUser
groupMemberId <- insertedRowId db
createMemberConnection_ db (userId user) groupMemberId 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 =
liftIO . withTransaction st $ \db -> createMemberConnection_ db userId 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 = pure ()
updateGroupMemberStatus st userId groupMemberId memberStatus =
liftIO . withTransaction st $ \db ->
DB.executeNamed
db
[sql|
UPDATE group_members
SET member_status = :member_status
WHERE user_id = :user_id AND group_member_id = :group_member_id
|]
[ ":user_id" := userId,
":group_member_id" := groupMemberId,
":member_status" := memberStatus
]
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO ()
createMemberConnection_ db userId groupMemberId agentConnId =
-- | add new member with profile
createNewGroupMember :: StoreMonad m => SQLiteStore -> User -> Group -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> m GroupMember
createNewGroupMember st user@User {userId} group memInfo@(MemberInfo _ _ Profile {displayName, fullName}) memCategory memStatus =
liftIOEither . withTransaction st $ \db ->
withLocalDisplayName db userId displayName $ \localDisplayName -> do
DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
memProfileId <- insertedRowId db
let newMember =
NewGroupMember
{ memInfo,
memCategory,
memStatus,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Nothing,
memProfileId
}
createNewMember_ db user group newMember
createNewMember_ :: DB.Connection -> User -> Group -> NewGroupMember -> IO GroupMember
createNewMember_
db
User {userId, userContactId}
Group {groupId}
NewGroupMember
{ memInfo = MemberInfo memberId memberRole memberProfile,
memCategory = memberCategory,
memStatus = memberStatus,
memInvitedBy = invitedBy,
localDisplayName,
memContactId = memberContactId,
memProfileId
} = do
let invitedById = fromInvitedBy userContactId invitedBy
DB.execute
db
[sql|
INSERT INTO group_members
(group_id, member_id, member_role, member_category, member_status,
invited_by, user_id, local_display_name, contact_profile_id, contact_id) VALUES (?,?,?,?,?,?,?,?,?,?)
|]
(groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memProfileId, memberContactId)
groupMemberId <- insertedRowId db
pure $
GroupMember
{ groupMemberId,
memberId,
memberRole,
memberStatus,
memberCategory,
invitedBy,
memberProfile,
localDisplayName,
memberContactId,
activeConn = Nothing
}
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
if null reMembers
then pure []
else liftIO . withTransaction st $ \db ->
mapM (insertIntro_ db) reMembers
where
insertIntro_ :: DB.Connection -> GroupMember -> IO GroupMemberIntro
insertIntro_ db reMember = do
DB.execute
db
[sql|
INSERT INTO group_member_intros
(re_group_member_id, to_group_member_id, intro_status) VALUES (?,?,?)
|]
(groupMemberId reMember, groupMemberId toMember, GMIntroPending)
introId <- insertedRowId db
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
updateIntroStatus :: MonadUnliftIO m => SQLiteStore -> GroupMemberIntro -> GroupMemberIntroStatus -> m ()
updateIntroStatus st GroupMemberIntro {introId} introStatus' =
liftIO . withTransaction st $ \db ->
DB.executeNamed
db
[sql|
UPDATE group_member_intros
SET intro_status = :intro_status
WHERE group_member_intro_id = :intro_id
|]
[":intro_status" := introStatus', ":intro_id" := introId]
saveIntroInvitation :: StoreMonad m => SQLiteStore -> GroupMember -> GroupMember -> IntroInvitation -> m GroupMemberIntro
saveIntroInvitation st reMember toMember introInv = do
liftIOEither . withTransaction st $ \db -> runExceptT $ do
intro <- getIntroduction_ db reMember toMember
liftIO $
DB.executeNamed
db
[sql|
UPDATE group_member_intros
SET intro_status = :intro_status,
group_queue_info = :group_queue_info,
direct_queue_info = :direct_queue_info
WHERE group_member_intro_id = :intro_id
|]
[ ":intro_status" := GMIntroInvReceived,
":group_queue_info" := groupQInfo introInv,
":direct_queue_info" := directQInfo introInv,
":intro_id" := introId intro
]
pure intro {introInvitation = Just introInv, introStatus = GMIntroInvReceived}
saveMemberInvitation :: StoreMonad m => SQLiteStore -> GroupMember -> IntroInvitation -> m ()
saveMemberInvitation st GroupMember {groupMemberId} IntroInvitation {groupQInfo, directQInfo} =
liftIO . withTransaction st $ \db ->
DB.executeNamed
db
[sql|
UPDATE group_members
SET member_status = :member_status,
group_queue_info = :group_queue_info,
direct_queue_info = :direct_queue_info
WHERE group_member_id = :group_member_id
|]
[ ":member_status" := GSMemIntroInvited,
":group_queue_info" := groupQInfo,
":direct_queue_info" := directQInfo,
":group_member_id" := groupMemberId
]
getIntroduction_ :: DB.Connection -> GroupMember -> GroupMember -> ExceptT StoreError IO GroupMemberIntro
getIntroduction_ db reMember toMember = ExceptT $ do
toIntro
<$> DB.query
db
[sql|
SELECT group_member_intro_id, group_queue_info, direct_queue_info, intro_status
FROM group_member_intros
WHERE re_group_member_id = ? AND to_group_member_id = ?
|]
(groupMemberId reMember, groupMemberId toMember)
where
toIntro :: [(Int64, Maybe SMPQueueInfo, Maybe SMPQueueInfo, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
toIntro [(introId, groupQInfo, directQInfo, introStatus)] =
let introInvitation = IntroInvitation <$> groupQInfo <*> directQInfo
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
toIntro _ = Left SEIntroNotFound
createIntroReMember :: StoreMonad m => SQLiteStore -> User -> Group -> GroupMember -> MemberInfo -> ConnId -> ConnId -> m GroupMember
createIntroReMember st user@User {userId} group _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId =
liftIOEither . withTransaction st $ \db -> runExceptT $ do
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId directAgentConnId memberContactId cLevel
(localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just $ groupId group)
liftIO $ do
let newMember =
NewGroupMember
{ memInfo,
memCategory = GCPreMember,
memStatus = GSMemIntroduced,
memInvitedBy = IBUnknown,
localDisplayName,
memContactId = Just contactId,
memProfileId
}
member <- createNewMember_ db user group newMember
conn <- createMemberConnection_ db userId (groupMemberId member) groupAgentConnId memberContactId cLevel
pure (member :: GroupMember) {activeConn = Just conn}
createIntroToMemberContact :: StoreMonad m => SQLiteStore -> UserId -> GroupMember -> GroupMember -> ConnId -> ConnId -> m ()
createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId, activeConn} _to@GroupMember {groupMemberId, localDisplayName} groupAgentConnId directAgentConnId =
liftIO . withTransaction st $ \db -> do
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
void $ createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel
Connection {connId = directConnId} <- createConnection_ db userId directAgentConnId viaContactId cLevel
contactId <- createMemberContact_ db directConnId
updateMember_ db contactId
where
createMemberContact_ :: DB.Connection -> Int64 -> IO Int64
createMemberContact_ db connId = do
DB.executeNamed
db
[sql|
INSERT INTO contacts (contact_profile_id, via_group, local_display_name, user_id)
SELECT contact_profile_id, group_id, :local_display_name, :user_id
FROM group_members
WHERE group_member_id = :group_member_id
|]
[ ":group_member_id" := groupMemberId,
":local_display_name" := localDisplayName,
":user_id" := userId
]
contactId <- insertedRowId db
DB.execute db "UPDATE connections SET contact_id = ? WHERE connection_id = ?" (contactId, connId)
pure contactId
updateMember_ :: DB.Connection -> Int64 -> IO ()
updateMember_ db contactId =
DB.executeNamed
db
[sql|
UPDATE group_members
SET contact_id = :contact_id
WHERE group_member_id = :group_member_id
|]
[":contact_id" := contactId, ":group_member_id" := groupMemberId]
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> IO Connection
createMemberConnection_ db userId groupMemberId agentConnId viaContact connLevel = do
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO connections
(user_id, agent_conn_id, conn_status, conn_type, group_member_id) VALUES (?,?,?,?,?);
(user_id, agent_conn_id, conn_status, conn_type, group_member_id, via_contact, conn_level, created_at) VALUES (?,?,?,?,?,?,?,?);
|]
(userId, agentConnId, ConnNew, ConnMember, groupMemberId)
(userId, agentConnId, ConnNew, ConnMember, groupMemberId, viaContact, connLevel, createdAt)
connId <- insertedRowId db
pure Connection {connId, agentConnId, connType = ConnMember, entityId = Just groupMemberId, viaContact, connLevel, connStatus = ConnNew, createdAt}
createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberInfo -> GroupMemberStatus -> InvitedBy -> IO GroupMember
createContactMember_ db User {userContactId} groupId userOrContact (memberId, memberRole) memberStatus invitedBy = do
createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> (MemberId, GroupMemberRole) -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> IO GroupMember
createContactMember_ db User {userId, userContactId} groupId userOrContact (memberId, memberRole) memberCategory memberStatus invitedBy = do
insertMember_
groupMemberId <- insertedRowId db
let memberProfile = profile' userOrContact
memberContactId = Just $ contactId' userOrContact
pure GroupMember {groupMemberId, memberId, memberRole, memberStatus, invitedBy, memberProfile, memberContactId}
localDisplayName = localDisplayName' userOrContact
pure GroupMember {groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile, memberContactId, activeConn = Nothing}
where
insertMember_ =
DB.executeNamed
db
[sql|
INSERT INTO group_members
( group_id, member_id, member_role, member_status, invited_by,
contact_profile_id, contact_id)
( group_id, member_id, member_role, member_category, member_status, invited_by,
user_id, local_display_name, contact_profile_id, contact_id)
VALUES
(:group_id,:member_id,:member_role,:member_status,:invited_by,
(:group_id,:member_id,:member_role,:member_category,:member_status,:invited_by,
:user_id,:local_display_name,
(SELECT contact_profile_id FROM contacts WHERE contact_id = :contact_id),
:contact_id)
|]
[ ":group_id" := groupId,
":member_id" := memberId,
":member_role" := memberRole,
":member_category" := memberCategory,
":member_status" := memberStatus,
":invited_by" := fromInvitedBy userContactId invitedBy,
":user_id" := userId,
":local_display_name" := localDisplayName' userOrContact,
":contact_id" := contactId' userOrContact
]
getViaGroupMember :: MonadUnliftIO m => SQLiteStore -> User -> Contact -> m (Maybe (GroupName, GroupMember))
getViaGroupMember st User {userId, userContactId} Contact {contactId} =
liftIO . withTransaction st $ \db ->
toGroupAndMember
<$> DB.query
db
[sql|
SELECT
g.local_display_name,
m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at
FROM group_members m
JOIN contacts ct ON ct.contact_id = m.contact_id
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.group_member_id = m.group_member_id
)
WHERE ct.user_id = ? AND ct.contact_id = ?
|]
(userId, contactId)
where
toGroupAndMember :: [Only GroupName :. GroupMemberRow :. MaybeConnectionRow] -> Maybe (GroupName, GroupMember)
toGroupAndMember [Only groupName :. memberRow :. connRow] =
let member = toGroupMember userContactId memberRow
in Just (groupName, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
toGroupAndMember _ = Nothing
getViaGroupContact :: MonadUnliftIO m => SQLiteStore -> User -> GroupMember -> m (Maybe Contact)
getViaGroupContact st User {userId} GroupMember {groupMemberId} =
liftIO . withTransaction st $ \db ->
toContact
<$> DB.query
db
[sql|
SELECT
ct.contact_id, ct.local_display_name, p.display_name, p.full_name, ct.via_group,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.created_at
FROM contacts ct
JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.contact_id = ct.contact_id
)
JOIN groups g ON g.group_id = ct.via_group
JOIN group_members m ON m.group_id = g.group_id AND m.contact_id = ct.contact_id
WHERE ct.user_id = ? AND m.group_member_id = ?
|]
(userId, groupMemberId)
where
toContact :: [(Int64, ContactName, Text, Text, Maybe Int64) :. ConnectionRow] -> Maybe Contact
toContact [(contactId, localDisplayName, displayName, fullName, viaGroup) :. connRow] =
let profile = Profile {displayName, fullName}
activeConn = toConnection connRow
in Just Contact {contactId, localDisplayName, profile, activeConn, viaGroup}
toContact _ = Nothing
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
-- This function should be called inside transaction.
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)
@ -548,8 +871,9 @@ data StoreError
| SEGroupWithoutUser
| SEDuplicateGroupMember
| SEGroupAlreadyJoined
| SENoGroupInvitation
| SEGroupInvitationNotFound
| SEConnectionNotFound ConnId
| SEIntroNotFound
| SEUniqueID
| SEInternal ByteString
deriving (Show, Exception)

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

@ -15,7 +15,7 @@ import System.Terminal
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
import UnliftIO.STM
data ActiveTo = ActiveNone | ActiveC ContactName
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
deriving (Eq)
data ChatTerminal = ChatTerminal

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

@ -26,14 +26,17 @@ import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
class IsContact a where
contactId' :: a -> Int64
profile' :: a -> Profile
localDisplayName' :: a -> ContactName
instance IsContact User where
contactId' = userContactId
profile' = profile
localDisplayName' = localDisplayName
instance IsContact Contact where
contactId' = contactId
profile' = profile
localDisplayName' = localDisplayName
data User = User
{ userId :: UserId,
@ -49,7 +52,8 @@ data Contact = Contact
{ contactId :: Int64,
localDisplayName :: ContactName,
profile :: Profile,
activeConn :: Connection
activeConn :: Connection,
viaGroup :: Maybe Int64
}
deriving (Eq, Show)
@ -64,7 +68,7 @@ data Group = Group
{ groupId :: Int64,
localDisplayName :: GroupName,
groupProfile :: GroupProfile,
members :: [(GroupMember, Maybe Connection)],
members :: [GroupMember],
membership :: GroupMember
}
deriving (Eq, Show)
@ -90,34 +94,62 @@ instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOpt
instance FromJSON GroupProfile
data GroupInvitation = GroupInvitation
{ fromMember :: MemberInfo,
invitedMember :: MemberInfo,
{ fromMember :: (MemberId, GroupMemberRole),
invitedMember :: (MemberId, GroupMemberRole),
queueInfo :: SMPQueueInfo,
groupProfile :: GroupProfile
}
deriving (Eq, Show)
data IntroInvitation = IntroInvitation
{ groupQInfo :: SMPQueueInfo,
directQInfo :: SMPQueueInfo
}
deriving (Eq, Show)
data MemberInfo = MemberInfo MemberId GroupMemberRole Profile
deriving (Eq, Show)
memberInfo :: GroupMember -> MemberInfo
memberInfo m = MemberInfo (memberId m) (memberRole m) (memberProfile m)
data ReceivedGroupInvitation = ReceivedGroupInvitation
{ fromMember :: GroupMember,
invitedMember :: GroupMember,
userMember :: GroupMember,
queueInfo :: SMPQueueInfo,
groupProfile :: GroupProfile
}
deriving (Eq, Show)
type MemberInfo = (MemberId, GroupMemberRole)
data GroupMember = GroupMember
{ groupMemberId :: Int64,
memberId :: MemberId,
memberRole :: GroupMemberRole,
memberCategory :: GroupMemberCategory,
memberStatus :: GroupMemberStatus,
invitedBy :: InvitedBy,
localDisplayName :: ContactName,
memberProfile :: Profile,
memberContactId :: Maybe Int64
memberContactId :: Maybe Int64,
activeConn :: Maybe Connection
}
deriving (Eq, Show)
memberConnId :: GroupMember -> Maybe ConnId
memberConnId GroupMember {activeConn} = case activeConn of
Just Connection {agentConnId} -> Just agentConnId
Nothing -> Nothing
data NewGroupMember = NewGroupMember
{ memInfo :: MemberInfo,
memCategory :: GroupMemberCategory,
memStatus :: GroupMemberStatus,
memInvitedBy :: InvitedBy,
localDisplayName :: ContactName,
memProfileId :: Int64,
memContactId :: Maybe Int64
}
type MemberId = ByteString
data InvitedBy = IBContact Int64 | IBUser | IBUnknown
@ -160,37 +192,107 @@ fromBlobField_ p = \case
f@(Field (SQLBlob b) _) ->
case p b of
Right k -> Ok k
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
Left e -> returnError ConversionFailed f ("could not parse field: " ++ e)
f -> returnError ConversionFailed f "expecting SQLBlob column type"
data GroupMemberCategory
= GCUserMember
| GCInviteeMember -- member invited by the user
| GCHostMember -- member who invited the user
| GCPreMember -- member who joined before the user and was introduced to the user (user receives x.grp.mem.intro about such members)
| GCPostMember -- member who joined after the user to whom the user was introduced (user receives x.grp.mem.new announcing these members and then x.grp.mem.fwd with invitation from these members)
deriving (Eq, Show)
instance FromField GroupMemberCategory where fromField = fromTextField_ memberCategoryT
instance ToField GroupMemberCategory where toField = toField . serializeMemberCategory
memberCategoryT :: Text -> Maybe GroupMemberCategory
memberCategoryT = \case
"user" -> Just GCUserMember
"invitee" -> Just GCInviteeMember
"host" -> Just GCHostMember
"pre" -> Just GCPreMember
"post" -> Just GCPostMember
_ -> Nothing
serializeMemberCategory :: GroupMemberCategory -> Text
serializeMemberCategory = \case
GCUserMember -> "user"
GCInviteeMember -> "invitee"
GCHostMember -> "host"
GCPreMember -> "pre"
GCPostMember -> "post"
data GroupMemberStatus
= GSMemInvited -- member received (or sent to) invitation
| GSMemAccepted -- member accepted invitation
= GSMemRemoved -- member who was removed from the group
| GSMemLeft -- member who left the 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
| GSMemAccepted -- member accepted invitation (only User and Invitee)
| GSMemAnnounced -- host announced (x.grp.mem.new) a member (Invitee and PostMember) to the group - at this point this member can send messages and invite other members (if they have sufficient permissions)
| GSMemConnected -- member created the group connection with the inviting member
| GSMemReady -- member connections are forwarded to all previous members
| GSMemFull -- member created group connections with all previous members
| GSMemComplete -- host confirmed (x.grp.mem.all) that a member (User, Invitee and PostMember) created group connections with all previous members
| GSMemCreator -- user member that created the group (only GCUserMember)
deriving (Eq, Show, Ord)
instance FromField GroupMemberStatus where fromField = fromTextField_ memberStatusT
instance ToField GroupMemberStatus where toField = toField . serializeMemberStatus
memberActive :: GroupMember -> Bool
memberActive m = case memberStatus m of
GSMemRemoved -> False
GSMemLeft -> False
GSMemInvited -> False
GSMemIntroduced -> False
GSMemIntroInvited -> False
GSMemAccepted -> False
GSMemAnnounced -> False
GSMemConnected -> True
GSMemComplete -> True
GSMemCreator -> True
memberCurrent :: GroupMember -> Bool
memberCurrent m = case memberStatus m of
GSMemRemoved -> False
GSMemLeft -> False
GSMemInvited -> False
GSMemIntroduced -> True
GSMemIntroInvited -> True
GSMemAccepted -> True
GSMemAnnounced -> True
GSMemConnected -> True
GSMemComplete -> True
GSMemCreator -> True
memberStatusT :: Text -> Maybe GroupMemberStatus
memberStatusT = \case
"removed" -> Just GSMemRemoved
"left" -> Just GSMemLeft
"invited" -> Just GSMemInvited
"introduced" -> Just GSMemIntroduced
"intro-inv" -> Just GSMemIntroInvited
"accepted" -> Just GSMemAccepted
"announced" -> Just GSMemAnnounced
"connected" -> Just GSMemConnected
"ready" -> Just GSMemReady
"full" -> Just GSMemFull
"complete" -> Just GSMemComplete
"creator" -> Just GSMemCreator
_ -> Nothing
serializeMemberStatus :: GroupMemberStatus -> Text
serializeMemberStatus = \case
GSMemRemoved -> "removed"
GSMemLeft -> "left"
GSMemInvited -> "invited"
GSMemIntroduced -> "introduced"
GSMemIntroInvited -> "intro-inv"
GSMemAccepted -> "accepted"
GSMemAnnounced -> "announced"
GSMemConnected -> "connected"
GSMemReady -> "ready"
GSMemFull -> "full"
GSMemComplete -> "complete"
GSMemCreator -> "creator"
data Connection = Connection
{ connId :: Int64,
@ -204,7 +306,19 @@ data Connection = Connection
}
deriving (Eq, Show)
data ConnStatus = ConnNew | ConnConfirmed | ConnAccepted | ConnReady
data ConnStatus
= -- | connection is created by initiating party with agent NEW command (createConnection)
ConnNew
| -- | connection is joined by joining party with agent JOIN command (joinConnection)
ConnJoined
| -- | initiating party received CONF notification (to be renamed to REQ)
ConnRequested
| -- | initiating party accepted connection with agent LET command (to be renamed to ACPT) (allowConnection)
ConnAccepted
| -- | connection can be sent messages to (after joining party received INFO notification)
ConnSndReady
| -- | connection is ready for both parties to send and receive messages
ConnReady
deriving (Eq, Show)
instance FromField ConnStatus where fromField = fromTextField_ connStatusT
@ -214,16 +328,20 @@ instance ToField ConnStatus where toField = toField . serializeConnStatus
connStatusT :: Text -> Maybe ConnStatus
connStatusT = \case
"new" -> Just ConnNew
"confirmed" -> Just ConnConfirmed
"joined" -> Just ConnJoined
"requested" -> Just ConnRequested
"accepted" -> Just ConnAccepted
"snd-ready" -> Just ConnSndReady
"ready" -> Just ConnReady
_ -> Nothing
serializeConnStatus :: ConnStatus -> Text
serializeConnStatus = \case
ConnNew -> "new"
ConnConfirmed -> "confirmed"
ConnJoined -> "joined"
ConnRequested -> "requested"
ConnAccepted -> "accepted"
ConnSndReady -> "snd-ready"
ConnReady -> "ready"
data ConnType = ConnContact | ConnMember
@ -249,3 +367,45 @@ data NewConnection = NewConnection
connLevel :: Int,
viaConn :: Maybe Int64
}
data GroupMemberIntro = GroupMemberIntro
{ introId :: Int64,
reMember :: GroupMember,
toMember :: GroupMember,
introStatus :: GroupMemberIntroStatus,
introInvitation :: Maybe IntroInvitation
}
data GroupMemberIntroStatus
= GMIntroPending
| GMIntroSent
| GMIntroInvReceived
| GMIntroInvForwarded
| GMIntroReConnected
| GMIntroToConnected
| GMIntroConnected
instance FromField GroupMemberIntroStatus where fromField = fromTextField_ introStatusT
instance ToField GroupMemberIntroStatus where toField = toField . serializeIntroStatus
introStatusT :: Text -> Maybe GroupMemberIntroStatus
introStatusT = \case
"new" -> Just GMIntroPending
"sent" -> Just GMIntroSent
"rcv" -> Just GMIntroInvReceived
"fwd" -> Just GMIntroInvForwarded
"re-con" -> Just GMIntroReConnected
"to-con" -> Just GMIntroToConnected
"con" -> Just GMIntroConnected
_ -> Nothing
serializeIntroStatus :: GroupMemberIntroStatus -> Text
serializeIntroStatus = \case
GMIntroPending -> "new"
GMIntroSent -> "sent"
GMIntroInvReceived -> "rcv"
GMIntroInvForwarded -> "fwd"
GMIntroReConnected -> "re-con"
GMIntroToConnected -> "to-con"
GMIntroConnected -> "con"

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

@ -13,12 +13,16 @@ module Simplex.Chat.View
showContactConnected,
showContactDisconnected,
showReceivedMessage,
showReceivedGroupMessage,
showSentMessage,
showSentGroupMessage,
showGroupCreated,
showSentGroupInvitation,
showReceivedGroupInvitation,
showConnectedGroupMember,
showUserConnectedToGroup,
showJoinedGroupMember,
showUserJoinedGroup,
showJoinedGroupMemberConnecting,
showConnectedToGroupMember,
safeDecodeUtf8,
)
where
@ -26,7 +30,7 @@ where
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.ByteString.Char8 (ByteString)
import Data.Composition ((.:))
import Data.Composition ((.:), (.:.))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (DiffTime, UTCTime)
@ -60,10 +64,22 @@ showContactDisconnected :: ChatReader m => ContactName -> m ()
showContactDisconnected = printToView . contactDisconnected
showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> Text -> MsgIntegrity -> m ()
showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage c utcTime msg mOk)
showReceivedMessage = showReceivedMessage_ . ttyFromContact
showReceivedGroupMessage :: ChatReader m => GroupName -> ContactName -> UTCTime -> Text -> MsgIntegrity -> m ()
showReceivedGroupMessage = showReceivedMessage_ .: ttyFromGroup
showReceivedMessage_ :: ChatReader m => StyledString -> UTCTime -> Text -> MsgIntegrity -> m ()
showReceivedMessage_ from utcTime msg mOk = printToView =<< liftIO (receivedMessage from utcTime msg mOk)
showSentMessage :: ChatReader m => ContactName -> ByteString -> m ()
showSentMessage c msg = printToView =<< liftIO (sentMessage c msg)
showSentMessage = showSentMessage_ . ttyToContact
showSentGroupMessage :: ChatReader m => GroupName -> ByteString -> m ()
showSentGroupMessage = showSentMessage_ . ttyToGroup
showSentMessage_ :: ChatReader m => StyledString -> ByteString -> m ()
showSentMessage_ to msg = printToView =<< liftIO (sentMessage to msg)
showGroupCreated :: ChatReader m => Group -> m ()
showGroupCreated = printToView . groupCreated
@ -71,14 +87,20 @@ showGroupCreated = printToView . groupCreated
showSentGroupInvitation :: ChatReader m => Group -> ContactName -> m ()
showSentGroupInvitation = printToView .: sentGroupInvitation
showReceivedGroupInvitation :: ChatReader m => Group -> ContactName -> m ()
showReceivedGroupInvitation = printToView .: receivedGroupInvitation
showReceivedGroupInvitation :: ChatReader m => Group -> ContactName -> GroupMemberRole -> m ()
showReceivedGroupInvitation = printToView .:. receivedGroupInvitation
showConnectedGroupMember :: ChatReader m => GroupName -> ContactName -> m ()
showConnectedGroupMember = printToView .: connectedGroupMember
showJoinedGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
showJoinedGroupMember = printToView .: joinedGroupMember
showUserConnectedToGroup :: ChatReader m => GroupName -> m ()
showUserConnectedToGroup = printToView . userConnectedToGroup
showUserJoinedGroup :: ChatReader m => GroupName -> m ()
showUserJoinedGroup = printToView . userJoinedGroup
showJoinedGroupMemberConnecting :: ChatReader m => GroupName -> GroupMember -> GroupMember -> m ()
showJoinedGroupMemberConnecting = printToView .:. joinedGroupMemberConnecting
showConnectedToGroupMember :: ChatReader m => GroupName -> GroupMember -> m ()
showConnectedToGroupMember = printToView .: connectedToGroupMember
invitation :: SMPQueueInfo -> [StyledString]
invitation qInfo =
@ -101,28 +123,40 @@ contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart cha
groupCreated :: Group -> [StyledString]
groupCreated g@Group {localDisplayName} =
[ "group " <> ttyFullGroup g <> " is created",
"use " <> highlight ("/a #" <> localDisplayName <> " <name>") <> " to add members"
"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]
receivedGroupInvitation :: Group -> ContactName -> [StyledString]
receivedGroupInvitation g@Group {localDisplayName} c =
[ ttyContact c <> " invites you to join the group " <> ttyFullGroup g,
"use " <> highlight ("/j #" <> localDisplayName) <> " to accept"
receivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString]
receivedGroupInvitation g@Group {localDisplayName} c role =
[ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (serializeMemberRole role),
"use " <> highlight ("/j " <> localDisplayName) <> " to accept"
]
connectedGroupMember :: GroupName -> ContactName -> [StyledString]
connectedGroupMember g c = [ttyContact c <> " joined the group " <> ttyGroup g]
joinedGroupMember :: GroupName -> GroupMember -> [StyledString]
joinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
userConnectedToGroup :: GroupName -> [StyledString]
userConnectedToGroup g = ["you joined the group " <> ttyGroup g]
userJoinedGroup :: GroupName -> [StyledString]
userJoinedGroup g = [ttyGroup g <> ": you joined the group"]
receivedMessage :: ContactName -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
receivedMessage c utcTime msg mOk = do
joinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString]
joinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
connectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
connectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
connectedMember :: GroupMember -> StyledString
connectedMember m = case memberCategory m of
GCPreMember -> "member " <> ttyFullMember m
GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting
_ -> "member " <> ttyMember m -- these case is not used
receivedMessage :: StyledString -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
receivedMessage from utcTime msg mOk = do
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
pure $ prependFirst (t <> " " <> ttyFromContact c) (msgPlain msg) ++ showIntegrity mOk
pure $ prependFirst (t <> " " <> from) (msgPlain msg) ++ showIntegrity mOk
where
formatUTCTime :: TimeZone -> ZonedTime -> StyledString
formatUTCTime localTz currentTime =
@ -145,10 +179,10 @@ receivedMessage c utcTime msg mOk = do
msgError :: String -> [StyledString]
msgError s = [styled (Colored Red) s]
sentMessage :: ContactName -> ByteString -> IO [StyledString]
sentMessage c msg = do
sentMessage :: StyledString -> ByteString -> IO [StyledString]
sentMessage to msg = do
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
pure $ prependFirst (styleTime time <> " " <> ttyToContact c) (msgPlain $ safeDecodeUtf8 msg)
pure $ prependFirst (styleTime time <> " " <> to) (msgPlain $ safeDecodeUtf8 msg)
prependFirst :: StyledString -> [StyledString] -> [StyledString]
prependFirst s [] = [s]
@ -162,9 +196,10 @@ chatError = \case
ChatError err -> case err of
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
CEGroupRole -> ["insufficient role for this group command"]
CEGroupUserRole -> ["you have insufficient permissions for this group command"]
CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]
CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> g)]
CEGroupMemberNotReady -> ["you cannot invite other members yet, try later"]
CEGroupMemberNotActive -> ["you cannot invite other members yet, try later"]
CEGroupInternal s -> ["chat group bug: " <> plain s]
-- e -> ["chat error: " <> plain (show e)]
ChatErrorStore err -> case err of
@ -191,7 +226,17 @@ ttyContact = styled (Colored Green)
ttyFullContact :: Contact -> StyledString
ttyFullContact Contact {localDisplayName, profile = Profile {fullName}} =
ttyContact localDisplayName <> optFullName localDisplayName fullName
ttyFullName localDisplayName fullName
ttyMember :: GroupMember -> StyledString
ttyMember GroupMember {localDisplayName} = ttyContact localDisplayName
ttyFullMember :: GroupMember -> StyledString
ttyFullMember GroupMember {localDisplayName, memberProfile = Profile {fullName}} =
ttyFullName localDisplayName fullName
ttyFullName :: ContactName -> Text -> StyledString
ttyFullName c fullName = ttyContact c <> optFullName c fullName
ttyToContact :: ContactName -> StyledString
ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " "
@ -206,9 +251,15 @@ ttyFullGroup :: Group -> StyledString
ttyFullGroup Group {localDisplayName, groupProfile = GroupProfile {fullName}} =
ttyGroup localDisplayName <> optFullName localDisplayName fullName
optFullName :: Text -> Text -> StyledString
ttyFromGroup :: GroupName -> ContactName -> StyledString
ttyFromGroup g c = styled (Colored Yellow) $ "#" <> g <> " " <> c <> "> "
ttyToGroup :: GroupName -> StyledString
ttyToGroup g = styled (Colored Cyan) $ "#" <> g <> " "
optFullName :: ContactName -> Text -> StyledString
optFullName localDisplayName fullName
| localDisplayName == fullName = ""
| T.null fullName || localDisplayName == fullName = ""
| otherwise = plain (" (" <> fullName <> ")")
highlight :: StyledFormat a => a -> StyledString
@ -217,8 +268,5 @@ highlight = styled (Colored Cyan)
highlight' :: String -> StyledString
highlight' = highlight
-- ttyFromGroup :: Group -> Contact -> StyledString
-- ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> "
styleTime :: String -> StyledString
styleTime = Styled [SetColor Foreground Vivid Black]

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

@ -75,7 +75,12 @@ A -> B: invite to group - `MSG: x.grp.inv G_MEM_ID_A,G_MEM_ROLE_A,G_MEM_ID_B,G_M
user B confirms
B -> A: establish group connection (B: JOIN, A: LET)
B -> Ag: join group - `in SMP confirmation: x.grp.acpt G_MEM_ID_B`
A -> group (including B)): announce group member: `MSG: N x.grp.mem.new G_MEM_ID_B,G_MEM_ROLE_B x.json:NNN <B_profile>`
A -> group (including B)): announce group member: `MSG: N x.grp.mem.new G_MEM_ID_B,G_MEM_ROLE_B,G_MEM_ID_M,... x.json:NNN <B_profile>`
In the message `x.grp.mem.new` A sends the sorted list of all members to whom A is connected followed by the new member ID, role and profile. The following introductions will be sent about/to all members A "knows about" (includes members introduced to A and members who accepted group invitation but not connected yet), once they are connected, so it can be a bigger list than sent in `x.grp.mem.new`.
All members who received `x.grp.mem.new` from A should check the list of connected members and if any connected members that recipients invited to the group are not in this list, they should introduce them to this new member (the last ID, role and profile in `x.grp.mem.new`). That might lead to double introductions that would provide a stronger consistency of group membership at a cost of extra connection between some members that will be unused.
subsequent messages between A and B are via group connection
A -> Bg: intro member - `MSG: x.grp.mem.intro G_MEM_ID_M,G_MEM_ROLE_M x.json:NNN <M_profile>`
B -> Ag: inv for mem - `MSG: x.grp.mem.inv G_MEM_ID_M,<gr_invitation>,<dm_invitation>,<probe>`
@ -83,16 +88,17 @@ M is an existing member, messages are via group connection
A -> Mg: fwd inv - `MSG: x.grp.mem.fwd G_MEM_ID_B,<gr_invitation>,<dm_invitation>,<probe>`
M -> Bg: establish group connection (M: JOIN, B: LET)
M -> B: establish direct connection (M: JOIN, B: LET)
M -> Bg: confirm profile and role - `MSG: x.grp.mem.info G_MEM_ID_M,G_MEM_ROLE x.json:NNN <M_profile>`
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.grp.mem.probe G_MEM_ID_B,<probe_hash>`
M -> B (via old DM conn): probe confirm: `MSG: x.grp.mem.probe.ok G_MEM_ID_M,<probe>`
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>`
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`
once all members connected
A -> group: `MSG: N x.grp.mem.ok G_MEM_ID_B`
A -> group: `MSG: N x.grp.mem.con.all G_MEM_ID_B`
#### Send group message

2
stack.yaml
View File

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

49
tests/ChatClient.hs
View File

@ -7,6 +7,7 @@ module ChatClient where
import Control.Concurrent.Async
import Control.Concurrent.STM (retry)
import Control.Exception (bracket_)
import Control.Monad.Except
import Simplex.Chat
import Simplex.Chat.Controller (ChatController (..))
@ -17,11 +18,8 @@ import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
import qualified System.Terminal as C
import System.Terminal.Internal (VirtualTerminal, VirtualTerminalSettings (..), withVirtualTerminal)
testDB1 :: FilePath
testDB1 = "tests/tmp/test1"
testDB2 :: FilePath
testDB2 = "tests/tmp/test2"
testDBPrefix :: FilePath
testDBPrefix = "tests/tmp/test"
opts :: ChatOpts
opts =
@ -50,10 +48,39 @@ virtualSimplexChat dbFile profile = do
a <- async $ runSimplexChat cc
pure (TestCC cc t a)
testChatN :: [Profile] -> ([TestCC] -> IO ()) -> IO ()
testChatN ps test =
bracket_
(createDirectoryIfMissing False "tests/tmp")
(removeDirectoryRecursive "tests/tmp")
$ do
let envs = zip ps $ map ((testDBPrefix <>) . show) [(1 :: Int) ..]
tcs <- getTestCCs envs []
test tcs
where
getTestCCs [] tcs = pure tcs
getTestCCs ((p, db) : envs') tcs = (:) <$> virtualSimplexChat db p <*> getTestCCs envs' tcs
testChat2 :: Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO ()
testChat2 p1 p2 test = do
createDirectoryIfMissing False "tests/tmp"
tc1 <- virtualSimplexChat testDB1 p1
tc2 <- virtualSimplexChat testDB2 p2
test tc1 tc2
removeDirectoryRecursive "tests/tmp"
testChat2 p1 p2 test = testChatN [p1, p2] test_
where
test_ :: [TestCC] -> IO ()
test_ [tc1, tc2] = test tc1 tc2
test_ _ = error "expected 2 chat clients"
testChat3 :: Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
testChat3 p1 p2 p3 test = testChatN [p1, p2, p3] test_
where
test_ :: [TestCC] -> IO ()
test_ [tc1, tc2, tc3] = test tc1 tc2 tc3
test_ _ = error "expected 3 chat clients"
testChat4 :: Profile -> Profile -> Profile -> Profile -> (TestCC -> TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
testChat4 p1 p2 p3 p4 test = testChatN [p1, p2, p3, p4] test_
where
test_ :: [TestCC] -> IO ()
test_ [tc1, tc2, tc3, tc4] = test tc1 tc2 tc3 tc4
test_ _ = error "expected 4 chat clients"
concurrentlyN_ :: [IO a] -> IO ()
concurrentlyN_ = mapConcurrently_ id

161
tests/ChatTests.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module ChatTests where
@ -7,8 +8,9 @@ import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Data.Char (isDigit)
import Data.List (dropWhileEnd, isPrefixOf)
import qualified Data.Text as T
import Simplex.Chat.Controller
import Simplex.Chat.Types (Profile (..))
import Simplex.Chat.Types (Profile (..), User (..))
import System.Terminal.Internal (VirtualTerminal (..))
import Test.Hspec
@ -18,12 +20,19 @@ aliceProfile = Profile {displayName = "alice", fullName = "Alice"}
bobProfile :: Profile
bobProfile = Profile {displayName = "bob", fullName = "Bob"}
cathProfile :: Profile
cathProfile = Profile {displayName = "cath", fullName = "Catherine"}
danProfile :: Profile
danProfile = Profile {displayName = "dan", fullName = "Daniel"}
chatTests :: Spec
chatTests = do
describe "direct messages" $
it "add contact and send/receive message" testAddContact
describe "chat groups" $
describe "chat groups" $ do
it "add contacts, create group and send/receive messages" testGroup
it "create and join group with 4 members" testGroup2
testAddContact :: IO ()
testAddContact =
@ -58,19 +67,133 @@ testAddContact =
testGroup :: IO ()
testGroup =
testChat2 aliceProfile bobProfile $
\alice bob -> do
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
connectUsers alice bob
alice #:> "/g #team"
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 ##> "/a #team bob admin"
alice <## "use /a team <name> to add members"
alice ##> "/a team bob"
alice <## "invitation to join the group #team sent to bob"
bob <## "use /j #team to accept"
bob ##> "/j #team"
bob <## "use /j team to accept"
bob ##> "/j team"
concurrently_
(alice <## "bob joined the group #team")
(bob <## "you joined the group #team")
(alice <## "#team: bob joined the group")
(bob <## "#team: you joined the group")
alice ##> "/a team cath"
alice <## "invitation to join the group #team sent to cath"
cath <## "use /j team to accept"
cath ##> "/j team"
concurrentlyN_
[ alice <## "#team: cath joined the group",
do
cath <## "#team: you joined the group"
cath <## "#team: member bob (Bob) is connected",
do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
alice #> "#team hello"
concurrently_
(bob <# "#team alice> hello")
(cath <# "#team alice> hello")
bob #> "#team hi there"
concurrently_
(alice <# "#team bob> hi there")
(cath <# "#team bob> hi there")
cath #> "#team hey"
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"
testGroup2 :: IO ()
testGroup2 =
testChat4 aliceProfile bobProfile cathProfile danProfile $
\alice bob cath dan -> do
connectUsers alice bob
connectUsers alice cath
connectUsers bob dan
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 ##> "/a club bob"
alice <## "invitation to join the group #club sent to bob"
bob <## "use /j club to accept"
alice ##> "/a club cath"
alice <## "invitation to join the group #club sent to cath"
cath <## "use /j club to accept"
bob ##> "/j club"
concurrently_
(alice <## "#club: bob joined the group")
(bob <## "#club: you joined the group")
cath ##> "/j club"
concurrentlyN_
[ alice <## "#club: cath joined the group",
do
cath <## "#club: you joined the group"
cath <## "#club: member bob (Bob) is connected",
do
bob <## "#club: alice added cath (Catherine) to the group (connecting...)"
bob <## "#club: new member cath is connected"
]
bob ##> "/a club dan"
bob <## "invitation to join the group #club sent to dan"
dan <## "use /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"],
do
alice <## "#club: bob added dan_1 (Daniel) to the group (connecting...)"
alice <## "#club: new member dan_1 is connected",
do
cath <## "#club: bob added dan (Daniel) to the group (connecting...)"
cath <## "#club: new member dan is connected"
]
alice #> "#club hello"
concurrentlyN_
[ bob <# "#club alice> hello",
cath <# "#club alice> hello",
dan <# "#club alice_1> hello"
]
bob #> "#club hi there"
concurrentlyN_
[ alice <# "#club bob> hi there",
cath <# "#club bob> hi there",
dan <# "#club bob> hi there"
]
cath #> "#club hey"
concurrentlyN_
[ alice <# "#club cath> hey",
bob <# "#club cath> hey",
dan <# "#club cath> hey"
]
dan #> "#club how is it going?"
concurrentlyN_
[ alice <# "#club dan_1> how is it going?",
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_1 hi alice"
alice <# "dan_1> hi alice"
alice #> "@dan_1 hello dan"
dan <# "alice_1> hello dan"
connectUsers :: TestCC -> TestCC -> IO ()
connectUsers cc1 cc2 = do
@ -78,8 +201,12 @@ connectUsers cc1 cc2 = do
Just inv <- invitation <$> getWindow cc1
cc2 ##> ("/c " <> inv)
concurrently_
(cc2 <## "alice (Alice) is connected")
(cc1 <## "bob (Bob) is connected")
(cc2 <## (showName cc1 <> " is connected"))
(cc1 <## (showName cc2 <> " is connected"))
where
showName :: TestCC -> String
showName (TestCC ChatController {currentUser = User {localDisplayName, profile = Profile {fullName}}} _ _) =
T.unpack $ localDisplayName <> " (" <> fullName <> ")"
(##>) :: TestCC -> String -> IO ()
(##>) cc cmd = do
@ -97,6 +224,14 @@ connectUsers cc1 cc2 = do
(<##) :: TestCC -> String -> Expectation
cc <## line = (lastOutput <$> getWindow cc) `shouldReturn` line
(<###) :: TestCC -> [String] -> Expectation
_ <### [] = pure ()
cc <### ls = do
line <- lastOutput <$> 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