diff --git a/migrations/20210612_initial.sql b/migrations/20210612_initial.sql index 26fdbb934..ed10094cb 100644 --- a/migrations/20210612_initial.sql +++ b/migrations/20210612_initial.sql @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 3cae43511..d5b4e3a2e 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 4517a1b73..813b3cf8e 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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) diff --git a/src/Simplex/Chat/Input.hs b/src/Simplex/Chat/Input.hs index 7623c40d4..5369c3db9 100644 --- a/src/Simplex/Chat/Input.hs +++ b/src/Simplex/Chat/Input.hs @@ -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) diff --git a/src/Simplex/Chat/Notification.hs b/src/Simplex/Chat/Notification.hs index 66d99137b..bd80041df 100644 --- a/src/Simplex/Chat/Notification.hs +++ b/src/Simplex/Chat/Notification.hs @@ -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 diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 1fe10b493..401120a6d 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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 } diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index d902cd42c..d8b183b1e 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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) diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index ea29e2b24..24d613f48 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -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 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 605f315a1..95257a94d 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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" diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index dee04bb32..16fbb3fca 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 <> " ") <> " to add members" + "use " <> highlight ("/a " <> localDisplayName <> " ") <> " 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] diff --git a/src/Simplex/Chat/protocol.md b/src/Simplex/Chat/protocol.md index adec3f48f..9e8629c90 100644 --- a/src/Simplex/Chat/protocol.md +++ b/src/Simplex/Chat/protocol.md @@ -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 ` +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 ` + +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 ` B -> Ag: inv for mem - `MSG: x.grp.mem.inv G_MEM_ID_M,,,` @@ -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,,,` 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 -> Bg: confirm profile and role - `CONF: x.grp.mem.info G_MEM_ID_M,G_MEM_ROLE x.json:NNN ` +B -> Mg: send profile probe - `MSG: x.info.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,` - M -> B (via old DM conn): probe confirm: `MSG: x.grp.mem.probe.ok G_MEM_ID_M,` + B -> M (via old DM conn): profile match probe: `MSG: x.info.probe.check G_MEM_ID_B,` + M -> B (via old DM conn): probe confirm: `MSG: x.info.probe.ok G_MEM_ID_M,` 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 diff --git a/stack.yaml b/stack.yaml index 732c3d6e2..b0136113d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: [] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index be249edbe..5b35ce3da 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 28c847621..b37ace879 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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 to add members" - alice ##> "/a #team bob admin" + alice <## "use /a team 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 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