diff --git a/migrations/20210612_initial.sql b/migrations/20210612_initial.sql index 1da08a17e..26fdbb934 100644 --- a/migrations/20210612_initial.sql +++ b/migrations/20210612_initial.sql @@ -61,6 +61,7 @@ CREATE TABLE groups ( user_id INTEGER NOT NULL REFERENCES users, local_display_name TEXT NOT NULL, -- local group name without spaces group_profile_id INTEGER REFERENCES group_profiles, -- shared group profile + inv_queue_info BLOB, FOREIGN KEY (user_id, local_display_name) REFERENCES display_names (user_id, local_display_name) ON DELETE RESTRICT, @@ -72,8 +73,8 @@ CREATE TABLE group_members ( -- group members, excluding the local user group_member_id INTEGER PRIMARY KEY, 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 DEFAULT '', -- owner, admin, member - member_status TEXT NOT NULL DEFAULT '', -- new, invited, accepted, connected, ready + member_role TEXT NOT NULL, -- owner, admin, member + member_status TEXT NOT NULL, -- new, invited, accepted, connected, ready 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 contact_profile_id INTEGER NOT NULL REFERENCES contact_profiles ON DELETE RESTRICT, contact_id INTEGER REFERENCES contacts ON DELETE RESTRICT, diff --git a/package.yaml b/package.yaml index ff3c72591..90dbff3df 100644 --- a/package.yaml +++ b/package.yaml @@ -18,6 +18,7 @@ dependencies: - base >= 4.7 && < 5 - base64-bytestring >= 1.0 && < 1.3 - bytestring == 0.10.* + - composition == 1.0.* - containers == 0.6.* - cryptonite >= 0.27 && < 0.30 - directory == 1.3.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c77c7cbff..3cae43511 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) +import Data.Maybe (isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -59,6 +59,7 @@ data ChatCommand | SendMessage ContactName ByteString | NewGroup GroupProfile | AddMember GroupName ContactName GroupMemberRole + | JoinGroup GroupName | RemoveMember GroupName ContactName | MemberRole GroupName ContactName GroupMemberRole | LeaveGroup GroupName @@ -138,40 +139,43 @@ processChatCommand user@User {userId, profile} = \case withStore $ \st -> createDirectConnection st userId connId showInvitation qInfo Connect qInfo -> do - connId <- withAgent $ \a -> joinConnection a qInfo $ encodeProfile profile + connId <- withAgent $ \a -> joinConnection a qInfo . directMessage $ XInfo profile withStore $ \st -> createDirectConnection st userId connId - DeleteContact cRef -> do - conns <- withStore $ \st -> getContactConnections st userId cRef + DeleteContact cName -> do + conns <- withStore $ \st -> getContactConnections st userId cName withAgent $ \a -> forM_ conns $ \Connection {agentConnId} -> deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure () - withStore $ \st -> deleteContact st userId cRef - unsetActive $ ActiveC cRef - showContactDeleted cRef - SendMessage cRef msg -> do - contact <- withStore $ \st -> getContact st userId cRef - let body = MsgBodyContent {contentType = SimplexContentType XCText, contentData = msg} - rawMsg = rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent = XMsgNew MTText [] [body], chatDAG = Nothing} - connId = contactConnId contact - void . withAgent $ \a -> sendMessage a connId $ serializeRawChatMessage rawMsg - setActive $ ActiveC cRef + withStore $ \st -> deleteContact st userId cName + unsetActive $ ActiveC cName + showContactDeleted cName + SendMessage cName msg -> do + contact <- withStore $ \st -> getContact st userId cName + let msgEvent = XMsgNew MTText [] [MsgBodyContent {contentType = SimplexContentType XCText, contentData = msg}] + sendDirectMessage (contactConnId contact) msgEvent + setActive $ ActiveC cName NewGroup gProfile -> do gVar <- asks idsDrg - void $ withStore $ \st -> createNewGroup st gVar user gProfile - showGroupCreated gProfile - AddMember gRef cRef memRole -> do - (group, contact) <- withStore $ \st -> (,) <$> getGroup st user gRef <*> getContact st userId cRef + group <- withStore $ \st -> createNewGroup st gVar user gProfile + showGroupCreated group + AddMember gName cName memRole -> do + (group, contact) <- withStore $ \st -> (,) <$> getGroup st user gName <*> getContact st userId cName let Group {groupId, groupProfile, membership, members} = group userRole = memberRole membership userMemberId = memberId membership when (userRole < GRAdmin || userRole < memRole) $ throwError $ ChatError CEGroupRole - when (isMember contact members) $ throwError $ ChatError CEGroupDuplicateMember + when (isMember contact members) . throwError . ChatError $ CEGroupDuplicateMember cName + when (memberStatus membership == GSMemInvited) . throwError . ChatError $ CEGroupNotJoined gName + when (memberStatus membership < GSMemReady) . throwError . ChatError $ CEGroupMemberNotReady gVar <- asks idsDrg (agentConnId, qInfo) <- withAgent createConnection - memberId <- withStore $ \st -> createGroupMember st gVar user groupId (contactId contact) memRole IBUser agentConnId - let chatMsgEvent = XGrpInv (userMemberId, userRole) (memberId, memRole) qInfo groupProfile - rawMsg = rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent, chatDAG = Nothing} - connId = contactConnId contact - void . withAgent $ \a -> sendMessage a connId $ serializeRawChatMessage rawMsg + GroupMember {memberId} <- withStore $ \st -> createGroupMember st gVar user groupId contact memRole agentConnId + let msg = XGrpInv $ GroupInvitation (userMemberId, userRole) (memberId, memRole) qInfo groupProfile + sendDirectMessage (contactConnId contact) msg + showSentGroupInvitation group cName + 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 () @@ -179,7 +183,7 @@ processChatCommand user@User {userId, profile} = \case ListMembers _gRef -> pure () SendGroupMessage _gRef _msg -> pure () where - isMember :: Contact -> [(GroupMember, Connection)] -> Bool + isMember :: Contact -> [(GroupMember, Maybe Connection)] -> Bool isMember Contact {contactId} members = isJust $ find ((== Just contactId) . memberContactId . fst) members agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () @@ -192,8 +196,8 @@ agentSubscriber = do void . runExceptT $ processAgentMessage user connId msg `catchError` (liftIO . print) processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m () -processAgentMessage User {userId, profile} agentConnId agentMessage = do - chatDirection <- withStore $ \st -> getConnectionChatDirection st userId agentConnId +processAgentMessage user@User {userId, profile} agentConnId agentMessage = do + chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId case chatDirection of ReceivedDirectMessage (CContact ct@Contact {localDisplayName = c}) -> case agentMessage of @@ -202,11 +206,11 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do case chatMsgEvent of XMsgNew MTText [] body -> newTextMessage c meta $ find (isSimplexContentType XCText) body XInfo _ -> pure () -- TODO profile update - XGrpInv fromMem invMem qInfo groupProfile -> groupInvitation ct fromMem invMem qInfo groupProfile + XGrpInv gInv -> saveGroupInvitation ct gInv _ -> pure () CON -> do -- TODO update connection status - showContactConnected c + showContactConnected ct showToast ("@" <> c) "connected" setActive $ ActiveC c END -> do @@ -219,11 +223,52 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do CONF confId connInfo -> do -- TODO update connection status saveConnInfo conn connInfo - withAgent $ \a -> allowConnection a agentConnId confId $ encodeProfile profile + withAgent $ \a -> allowConnection a agentConnId confId . directMessage $ XInfo profile INFO connInfo -> saveConnInfo conn connInfo _ -> pure () - _ -> pure () + ReceivedGroupMessage gName m -> + case agentMessage of + CONF confId connInfo -> do + 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 + 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') + _ -> 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) + 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 () where newTextMessage :: ContactName -> MsgMeta -> Maybe MsgBodyContent -> m () newTextMessage c meta = \case @@ -234,10 +279,12 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do setActive $ ActiveC c _ -> pure () - groupInvitation :: Contact -> (MemberId, GroupMemberRole) -> (MemberId, GroupMemberRole) -> SMPQueueInfo -> GroupProfile -> m () - groupInvitation _ct (fromMemId, fromRole) (memId, memRole) _qInfo _groupProfile = do + saveGroupInvitation :: Contact -> GroupInvitation -> m () + saveGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (fromMemId, fromRole) (memId, memRole) _ _) = do when (fromRole < GRAdmin || fromRole < memRole) $ throwError $ ChatError CEGroupRole - when (fromMemId == memId) $ throwError $ ChatError CEGroupDuplicateMember + when (fromMemId == memId) $ throwError $ ChatError CEGroupDuplicateMemberId + group <- withStore $ \st -> createGroupInvitation st user ct inv + showReceivedGroupInvitation group localDisplayName parseChatMessage :: ByteString -> Either ChatError ChatMessage parseChatMessage msgBody = first ChatErrorMessage (parseAll rawChatMessageP msgBody >>= toChatMessage) @@ -250,10 +297,17 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do withStore $ \st -> createDirectContact st userId activeConn p _ -> pure () -- TODO show/log error, other events in SMP confirmation -encodeProfile :: Profile -> ByteString -encodeProfile profile = - let chatMsg = ChatMessage {chatMsgId = Nothing, chatMsgEvent = XInfo profile, chatDAG = Nothing} - in serializeRawChatMessage $ rawChatMessage chatMsg +sendDirectMessage :: ChatMonad m => ConnId -> ChatMsgEvent -> m () +sendDirectMessage agentConnId chatMsgEvent = + void . withAgent $ \a -> sendMessage a agentConnId $ directMessage chatMsgEvent + +directMessage :: ChatMsgEvent -> ByteString +directMessage chatMsgEvent = + serializeRawChatMessage $ + rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent, chatDAG = Nothing} + +sendGroupMessage :: ChatMonad m => [(GroupMember, Maybe Connection)] -> ChatMsgEvent -> m () +sendGroupMessage _members _chatMsgEvent = pure () getCreateActiveUser :: SQLiteStore -> IO User getCreateActiveUser st = do @@ -341,6 +395,7 @@ chatCommandP = ("/help" <|> "/h") $> ChatHelp <|> ("/group #" <|> "/g #") *> (NewGroup <$> groupProfile) <|> ("/add #" <|> "/a #") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole) + <|> ("/join #" <|> "/j #") *> (JoinGroup <$> displayName) <|> ("/remove #" <|> "/rm #") *> (RemoveMember <$> displayName <* A.space <*> displayName) <|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> displayName) <|> ("/members #" <|> "/ms #") *> (ListMembers <$> displayName) @@ -354,9 +409,9 @@ chatCommandP = displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ')) refChar c = c > ' ' && c /= '#' && c /= '@' groupProfile = do - gRef <- displayName - gName <- safeDecodeUtf8 <$> (A.space *> A.takeByteString) <|> pure "" - pure GroupProfile {displayName = gRef, fullName = if T.null gName then gRef else gName} + gName <- displayName + fullName' <- safeDecodeUtf8 <$> (A.space *> A.takeByteString) <|> pure "" + pure GroupProfile {displayName = gName, fullName = if T.null fullName' then gName else fullName'} memberRole = (" owner" $> GROwner) <|> (" admin" $> GRAdmin) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index fc6fa5082..4517a1b73 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -40,7 +40,14 @@ data ChatError | ChatErrorStore StoreError deriving (Show, Exception) -data ChatErrorType = CEGroupRole | CEGroupDuplicateMember deriving (Show, Exception) +data ChatErrorType + = CEGroupRole + | CEGroupDuplicateMember ContactName + | CEGroupDuplicateMemberId + | CEGroupNotJoined GroupName + | CEGroupMemberNotReady + | CEGroupInternal String + deriving (Show, Exception) type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m) diff --git a/src/Simplex/Chat/Help.hs b/src/Simplex/Chat/Help.hs index d3dbd9606..d120864c3 100644 --- a/src/Simplex/Chat/Help.hs +++ b/src/Simplex/Chat/Help.hs @@ -11,27 +11,26 @@ chatHelpInfo :: [StyledString] chatHelpInfo = map styleMarkdown - [ Markdown (Colored Cyan) "Using Simplex chat prototype.", + [ highlight "Using Simplex chat prototype.", "Follow these steps to set up a connection:", "", - Markdown (Colored Green) "Step 1: " <> Markdown (Colored Cyan) "/add bob" <> " -- Alice adds her contact, Bob (she can use any name).", + Markdown (Colored Green) "Step 1: " <> highlight "/add" <> " -- Alice adds a contact.", indent <> "Alice should send the invitation printed by the /add command", indent <> "to her contact, Bob, out-of-band, via any trusted channel.", "", - Markdown (Colored Green) "Step 2: " <> Markdown (Colored Cyan) "/connect alice " <> " -- Bob accepts the invitation.", - indent <> "Bob also can use any name for his contact, Alice,", - indent <> "followed by the invitation he received out-of-band.", + Markdown (Colored Green) "Step 2: " <> highlight "/connect " <> " -- Bob accepts the invitation.", + indent <> "Bob should use the invitation he received out-of-band.", "", Markdown (Colored Green) "Step 3: " <> "Bob and Alice are notified that the connection is set up,", indent <> "both can now send messages:", - indent <> Markdown (Colored Cyan) "@bob Hello, Bob!" <> " -- Alice messages Bob.", - indent <> Markdown (Colored Cyan) "@alice Hey, Alice!" <> " -- Bob replies to Alice.", + indent <> highlight "@bob Hello, Bob!" <> " -- Alice messages Bob (assuming Bob has display name 'bob').", + indent <> highlight "@alice Hey, Alice!" <> " -- Bob replies to Alice.", "", Markdown (Colored Green) "Other commands:", - indent <> Markdown (Colored Cyan) "/delete" <> " -- deletes contact and all messages with them.", - indent <> Markdown (Colored Cyan) "/markdown" <> " -- prints the supported markdown syntax.", + indent <> highlight "/delete " <> " -- deletes contact and all messages with them.", + indent <> highlight "/markdown" <> " -- prints the supported markdown syntax.", "", - "The commands may be abbreviated to a single letter: " <> listCommands ["/a", "/c", "/d", "/m"] + "The commands may be abbreviated to a single letter: " <> listCommands ["/a", "/c", "/d", "/h", "/m"] ] where listCommands = mconcat . intersperse ", " . map highlight diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 6fba8f3b7..1fe10b493 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -30,9 +30,9 @@ import Simplex.Messaging.Util (bshow) data ChatDirection (p :: AParty) where ReceivedDirectMessage :: ConnContact -> ChatDirection 'Agent - SentDirectMessage :: ConnContact -> ChatDirection 'Client - ReceivedGroupMessage :: Group -> ConnContact -> ChatDirection 'Agent - SentGroupMessage :: Group -> ChatDirection 'Client + SentDirectMessage :: Contact -> ChatDirection 'Client + ReceivedGroupMessage :: GroupName -> GroupMember -> ChatDirection 'Agent + SentGroupMessage :: GroupName -> ChatDirection 'Client deriving instance Eq (ChatDirection p) @@ -48,12 +48,7 @@ data ChatMsgEvent content :: [MsgBodyContent] } | XInfo Profile - | XGrpInv - { fromMember :: (MemberId, GroupMemberRole), - invitedMember :: (MemberId, GroupMemberRole), - queueInfo :: SMPQueueInfo, - groupProfile :: GroupProfile - } + | XGrpInv GroupInvitation | XGrpAcpt MemberId | XGrpMemNew MemberId GroupMemberRole Profile | XGrpMemIntro MemberId GroupMemberRole Profile @@ -99,8 +94,8 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod [fromMemId, fromRole, memId, role, qInfo] -> do fromMember <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole invitedMember <- (,) <$> B64.decode memId <*> toMemberRole role - msg <- XGrpInv fromMember invitedMember <$> parseAll smpQueueInfoP qInfo <*> getJSON body - pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG} + 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 @@ -151,7 +146,7 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} = XInfo profile -> let chatMsgBody = rawWithDAG [jsonBody profile] in RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody} - XGrpInv (fromMemId, fromRole) (memId, role) qInfo groupProfile -> + XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) qInfo groupProfile) -> let chatMsgParams = [ B64.encode fromMemId, serializeMemberRole fromRole, diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 86e8ffb5f..d902cd42c 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -25,9 +26,12 @@ module Simplex.Chat.Store getContactConnections, getConnectionChatDirection, createNewGroup, - createGroup, + createGroupInvitation, getGroup, + getGroupInvitation, createGroupMember, + createMemberConnection, + updateGroupMemberStatus, ) where @@ -42,7 +46,7 @@ import Data.ByteString.Char8 (ByteString) import Data.FileEmbed (embedDir, makeRelativeToProject) import Data.Function (on) import Data.Int (Int64) -import Data.List (sortBy) +import Data.List (find, sortBy) import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -53,10 +57,10 @@ import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Protocol import Simplex.Chat.Types -import Simplex.Messaging.Agent.Protocol (AParty (..), ConnId) +import Simplex.Messaging.Agent.Protocol (AParty (..), ConnId, SMPQueueInfo) import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction) import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) -import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>)) +import Simplex.Messaging.Util (bshow, liftIOEither) import System.FilePath (takeBaseName, takeExtension) import UnliftIO.STM @@ -83,7 +87,9 @@ handleSQLError err e insertedRowId :: DB.Connection -> IO Int64 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" -createUser :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> Profile -> Bool -> m User +type StoreMonad m = (MonadUnliftIO m, MonadError StoreError m) + +createUser :: StoreMonad m => SQLiteStore -> Profile -> Bool -> m User createUser st Profile {displayName, fullName} activeUser = liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do DB.execute db "INSERT INTO users (local_display_name, active_user, contact_id) VALUES (?, ?, 0)" (displayName, activeUser) @@ -131,8 +137,7 @@ createDirectConnection st userId agentConnId = |] (userId, agentConnId, ConnNew, ConnContact) -createDirectContact :: - (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> Connection -> Profile -> m () +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 @@ -174,7 +179,7 @@ deleteContact st userId displayName = -- TODO return the last connection that is ready, not any last connection -- requires updating connection status getContact :: - (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactName -> m Contact + StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact getContact st userId localDisplayName = liftIOEither . withTransaction st $ \db -> runExceptT $ do c@Contact {contactId} <- getContact_ db @@ -212,7 +217,7 @@ getContact st userId localDisplayName = connection (connRow : _) = Right $ toConnection connRow connection _ = Left $ SEContactNotReady localDisplayName -getContactConnections :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactName -> m [Connection] +getContactConnections :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m [Connection] getContactConnections st userId displayName = liftIOEither . withTransaction st $ \db -> connections @@ -234,6 +239,8 @@ getContactConnections st userId displayName = type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, UTCTime) +type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe UTCTime) + toConnection :: ConnectionRow -> Connection toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt) = let entityId = entityId_ connType @@ -243,20 +250,27 @@ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId_ ConnContact = contactId entityId_ ConnMember = groupMemberId -getConnectionChatDirection :: - (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ConnId -> m (ChatDirection 'Agent) -getConnectionChatDirection st userId agentConnId = - liftIOEither . withTransaction st $ \db -> do - getConnection_ db >>= \case - Left e -> pure $ Left e - Right c@Connection {connType, entityId} -> case connType of - ConnMember -> pure . Left $ SEInternal "group members not supported yet" - ConnContact -> - ReceivedDirectMessage <$$> case entityId of - Nothing -> pure . Right $ CConnection c - Just cId -> getContact_ db cId c +toMaybeConnection :: MaybeConnectionRow -> Maybe Connection +toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, Just createdAt) = + Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt) +toMaybeConnection _ = Nothing + +getConnectionChatDirection :: StoreMonad m => SQLiteStore -> User -> ConnId -> m (ChatDirection 'Agent) +getConnectionChatDirection st User {userId, userContactId} agentConnId = + liftIOEither . withTransaction st $ \db -> runExceptT $ do + c@Connection {connType, entityId} <- getConnection_ db + case connType of + ConnMember -> + case entityId of + Nothing -> throwError $ SEInternal "group member without connection" + Just groupMemberId -> uncurry ReceivedGroupMessage <$> getGroupAndMember_ db groupMemberId + ConnContact -> + ReceivedDirectMessage <$> case entityId of + Nothing -> pure $ CConnection c + Just contactId -> getContact_ db contactId c where - getConnection_ db = + getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection + getConnection_ db = ExceptT $ do connection <$> DB.query db @@ -267,9 +281,11 @@ getConnectionChatDirection st userId agentConnId = WHERE user_id = ? AND agent_conn_id = ? |] (userId, agentConnId) + connection :: [ConnectionRow] -> Either StoreError Connection connection (connRow : _) = Right $ toConnection connRow connection _ = Left $ SEConnectionNotFound agentConnId - getContact_ db contactId c = + getContact_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO ConnContact + getContact_ db contactId c = ExceptT $ do toContact contactId c <$> DB.query db @@ -280,96 +296,94 @@ getConnectionChatDirection st userId agentConnId = 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)] = let profile = Profile {displayName, fullName} in Right $ CContact Contact {contactId, localDisplayName, profile, activeConn = c} toContact _ _ _ = Left $ SEInternal "referenced contact not found" + getGroupAndMember_ :: DB.Connection -> Int64 -> ExceptT StoreError IO (GroupName, GroupMember) + getGroupAndMember_ db groupMemberId = ExceptT $ do + toGroupAndMember + <$> 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 + 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" -- | creates completely new group with a single member - the current user -createNewGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> TVar ChaChaDRG -> User -> GroupProfile -> m Group -createNewGroup st gVar User {userId, userContactId, profile} p@GroupProfile {displayName, fullName} = +createNewGroup :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> GroupProfile -> m Group +createNewGroup st gVar user groupProfile = liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do - DB.execute db "INSERT INTO display_names (local_display_name, ldn_base, user_id) VALUES (?, ?, ?)" (displayName, displayName, userId) + let GroupProfile {displayName, fullName} = groupProfile + uId = userId user + DB.execute db "INSERT INTO display_names (local_display_name, ldn_base, user_id) VALUES (?, ?, ?)" (displayName, displayName, uId) DB.execute db "INSERT INTO group_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName) profileId <- insertedRowId db - DB.execute db "INSERT INTO groups (local_display_name, user_id, group_profile_id) VALUES (?, ?, ?)" (displayName, userId, profileId) + 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 - createMember_ db groupId userContactId GROwner GSMemReady (Just userContactId) memberId - groupMemberId <- insertedRowId db - let membership = - GroupMember - { groupMemberId, - memberId, - memberRole = GROwner, - memberStatus = GSMemReady, - invitedBy = IBUser, - memberProfile = profile, - memberContactId = Just userContactId - } - pure $ Right Group {groupId, localDisplayName = displayName, groupProfile = p, members = [], membership} + membership <- createContactMember_ db user groupId user (memberId, GROwner) GSMemFull IBUser + pure $ Right Group {groupId, localDisplayName = displayName, groupProfile, members = [], membership} -- | creates a new group record for the group the current user was invited to -createGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> TVar ChaChaDRG -> User -> Contact -> GroupProfile -> m Group -createGroup st gVar User {userId, userContactId, profile} contact p@GroupProfile {displayName, fullName} = - liftIOEither . withTransaction st $ \db -> - withLocalDisplayName db userId displayName $ \localDisplayName -> do +createGroupInvitation :: + StoreMonad m => SQLiteStore -> User -> Contact -> GroupInvitation -> m Group +createGroupInvitation st user contact GroupInvitation {fromMember, invitedMember, queueInfo, groupProfile} = + liftIOEither . withTransaction st $ \db -> do + let GroupProfile {displayName, fullName} = groupProfile + uId = userId user + withLocalDisplayName db uId displayName $ \localDisplayName -> do DB.execute db "INSERT INTO group_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName) profileId <- insertedRowId db - DB.execute - db - [sql| - INSERT INTO groups - (group_profile_id, local_display_name, user_id) VALUES (?, ?, ?) - |] - (profileId, localDisplayName, userId) + 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 - pure Group {groupId, localDisplayName, groupProfile = p, members = undefined, membership = undefined} - --- where --- createMember_ db groupId userContactId GROwner GSMemReady (Just userContactId) memberId --- groupMemberId <- insertedRowId db --- let membership = --- GroupMember --- { groupMemberId, --- memberId, --- memberRole = GROwner, --- memberStatus = GSMemReady, --- invitedBy = IBUser, --- memberProfile = profile, --- memberContactId = Just userContactId --- } --- pure $ Right Group {groupId, localDisplayName = displayName, groupProfile = p, members = [], membership} + 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} -- TODO return the last connection that is ready, not any last connection -- requires updating connection status -getGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> User -> GroupName -> m Group -getGroup st User {userId, userContactId} localDisplayName = - liftIOEither . withTransaction st $ \db -> runExceptT $ do - g@Group {groupId} <- getGroup_ db - members <- getMembers_ db groupId - membership <- getUserMember_ db groupId - pure g {members, membership} +getGroup :: StoreMonad m => SQLiteStore -> User -> GroupName -> m Group +getGroup st user localDisplayName = + liftIOEither . withTransaction st $ \db -> runExceptT $ fst <$> getGroup_ db user localDisplayName + +getGroup_ :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO (Group, Maybe SMPQueueInfo) +getGroup_ db User {userId, userContactId} localDisplayName = do + (g@Group {groupId}, qInfo) <- getGroupRec_ + allMembers <- getMembers_ groupId + (members, membership) <- liftEither $ splitUserMember_ allMembers + pure (g {members, membership}, qInfo) where - getGroup_ :: DB.Connection -> ExceptT StoreError IO Group - getGroup_ db = ExceptT $ do + getGroupRec_ :: ExceptT StoreError IO (Group, Maybe SMPQueueInfo) + getGroupRec_ = ExceptT $ do toGroup <$> DB.query db [sql| - SELECT g.group_id, p.display_name, p.full_name + SELECT g.group_id, p.display_name, p.full_name, g.inv_queue_info FROM groups g JOIN group_profiles p ON p.group_profile_id = g.group_profile_id WHERE g.local_display_name = ? AND g.user_id = ? |] (localDisplayName, userId) - toGroup :: [(Int64, GroupName, Text)] -> Either StoreError Group - toGroup [(groupId, displayName, fullName)] = + toGroup :: [(Int64, GroupName, Text, Maybe SMPQueueInfo)] -> Either StoreError (Group, Maybe SMPQueueInfo) + toGroup [(groupId, displayName, fullName, qInfo)] = let groupProfile = GroupProfile {displayName, fullName} - in Right Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined} + in Right (Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined}, qInfo) toGroup _ = Left $ SEGroupNotFound localDisplayName - getMembers_ :: DB.Connection -> Int64 -> ExceptT StoreError IO [(GroupMember, Connection)] - getMembers_ db groupId = ExceptT $ do + getMembers_ :: Int64 -> ExceptT StoreError IO [(GroupMember, Maybe Connection)] + getMembers_ groupId = ExceptT $ do Right . map toContactMember <$> DB.query db @@ -380,81 +394,99 @@ getGroup st User {userId, userContactId} localDisplayName = 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 groups g ON g.group_id = m.group_id JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id - JOIN connections c ON c.group_member_id = m.group_member_id - WHERE g.group_id = ? - ORDER BY c.connection_id DESC - LIMIT 1 + 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 m.group_id = ? |] (Only groupId) - getUserMember_ :: DB.Connection -> Int64 -> ExceptT StoreError IO GroupMember - getUserMember_ db groupId = ExceptT $ do - userMember - <$> 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 - FROM group_members m - JOIN groups g ON g.group_id = m.group_id - JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id - WHERE g.group_id = ? AND m.contact_id = ? - |] - (groupId, userContactId) - toContactMember :: (GroupMemberRow :. ConnectionRow) -> (GroupMember, Connection) - toContactMember (memberRow :. connRow) = (toGroupMember memberRow, toConnection connRow) - toGroupMember :: GroupMemberRow -> GroupMember - toGroupMember (groupMemberId, memberId, memberRole, memberStatus, invitedById, memberContactId, displayName, fullName) = - let memberProfile = Profile {displayName, fullName} - invitedBy = toInvitedBy userContactId invitedById - in GroupMember {groupMemberId, memberId, memberRole, memberStatus, invitedBy, memberProfile, memberContactId} - userMember :: [GroupMemberRow] -> Either StoreError GroupMember - userMember [memberRow] = Right $ toGroupMember memberRow - userMember _ = Left SEGroupWithoutUser + toContactMember :: (GroupMemberRow :. MaybeConnectionRow) -> (GroupMember, Maybe Connection) + toContactMember (memberRow :. connRow) = (toGroupMember userContactId memberRow, toMaybeConnection connRow) + splitUserMember_ :: [(GroupMember, Maybe Connection)] -> Either StoreError ([(GroupMember, Maybe Connection)], GroupMember) + splitUserMember_ allMembers = + let (b, a) = break ((== Just userContactId) . memberContactId . fst) allMembers + in case a of + [] -> Left SEGroupWithoutUser + u : ms -> Right (b <> ms, fst u) + +getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation +getGroupInvitation st user localDisplayName = + liftIOEither . withTransaction st $ \db -> runExceptT $ do + (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 + where + findFromContact :: InvitedBy -> [(GroupMember, Maybe Connection)] -> Maybe (GroupMember, Maybe Connection) + findFromContact (IBContact contactId) = find (\(m, _) -> memberContactId m == Just contactId) + findFromContact _ = const Nothing type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberStatus, Maybe Int64, Maybe Int64, ContactName, Text) -createGroupMember :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Int64 -> GroupMemberRole -> InvitedBy -> ConnId -> m MemberId -createGroupMember st gVar User {userId, userContactId} groupId contactId memberRole invitedBy agentConnId = - liftIOEither . withTransaction st $ \db -> do - let invitedById = fromInvitedBy userContactId invitedBy - memberId <- createWithRandomId gVar $ createMember_ db groupId contactId memberRole GSMemInvited invitedById - groupMemberId <- insertedRowId db - liftIO $ createMemberConnection_ db groupMemberId - pure memberId - where - createMemberConnection_ :: DB.Connection -> Int64 -> IO () - createMemberConnection_ db groupMemberId = - DB.execute - db - [sql| - INSERT INTO connections - (user_id, agent_conn_id, conn_status, conn_type, group_member_id) VALUES (?,?,?,?,?); - |] - (userId, agentConnId, ConnNew, ConnMember, groupMemberId) +toGroupMember :: Int64 -> GroupMemberRow -> GroupMember +toGroupMember userContactId (groupMemberId, memberId, memberRole, memberStatus, invitedById, memberContactId, displayName, fullName) = + let memberProfile = Profile {displayName, fullName} + invitedBy = toInvitedBy userContactId invitedById + in GroupMember {groupMemberId, memberId, memberRole, memberStatus, invitedBy, memberProfile, memberContactId} -createMember_ :: DB.Connection -> Int64 -> Int64 -> GroupMemberRole -> GroupMemberStatus -> Maybe Int64 -> ByteString -> IO () -createMember_ db groupId contactId memberRole memberStatus invitedBy memberId = - DB.executeNamed +createGroupMember :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> m GroupMember +createGroupMember 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 + groupMemberId <- insertedRowId db + createMemberConnection_ db (userId user) groupMemberId agentConnId + pure member + +createMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> m () +createMemberConnection st userId groupMemberId agentConnId = + liftIO . withTransaction st $ \db -> createMemberConnection_ db userId groupMemberId agentConnId + +updateGroupMemberStatus :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> GroupMemberStatus -> m () +updateGroupMemberStatus _st _userId _groupMemberId _memberStatus = pure () + +createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO () +createMemberConnection_ db userId groupMemberId agentConnId = + DB.execute db [sql| - INSERT INTO group_members - ( group_id, member_id, member_role, member_status, invited_by, - contact_profile_id, contact_id) - VALUES - (:group_id,:member_id,:member_role,:member_status,:invited_by, - (SELECT contact_profile_id FROM contacts WHERE contact_id = :contact_id), - :contact_id) + INSERT INTO connections + (user_id, agent_conn_id, conn_status, conn_type, group_member_id) VALUES (?,?,?,?,?); |] - [ ":group_id" := groupId, - ":member_id" := memberId, - ":member_role" := memberRole, - ":member_status" := memberStatus, - ":invited_by" := invitedBy, - ":contact_id" := contactId - ] + (userId, agentConnId, ConnNew, ConnMember, groupMemberId) + +createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberInfo -> GroupMemberStatus -> InvitedBy -> IO GroupMember +createContactMember_ db User {userContactId} groupId userOrContact (memberId, memberRole) memberStatus invitedBy = do + insertMember_ + groupMemberId <- insertedRowId db + let memberProfile = profile' userOrContact + memberContactId = Just $ contactId' userOrContact + pure GroupMember {groupMemberId, memberId, memberRole, memberStatus, invitedBy, memberProfile, memberContactId} + 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) + VALUES + (:group_id,:member_id,:member_role,:member_status,:invited_by, + (SELECT contact_profile_id FROM contacts WHERE contact_id = :contact_id), + :contact_id) + |] + [ ":group_id" := groupId, + ":member_id" := memberId, + ":member_role" := memberRole, + ":member_status" := memberStatus, + ":invited_by" := fromInvitedBy userContactId invitedBy, + ":contact_id" := contactId' userOrContact + ] -- | Saves unique local display name based on passed displayName, suffixed with _N if required. -- This function should be called inside transaction. @@ -492,15 +524,15 @@ withLocalDisplayName db userId displayName action = getLdnSuffix >>= (`tryCreate |] (ldn, displayName, ldnSuffix, userId) -createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString) +createWithRandomId :: forall a. TVar ChaChaDRG -> (ByteString -> IO a) -> IO (Either StoreError a) createWithRandomId gVar create = tryCreate 3 where - tryCreate :: Int -> IO (Either StoreError ByteString) + tryCreate :: Int -> IO (Either StoreError a) tryCreate 0 = pure $ Left SEUniqueID tryCreate n = do id' <- randomId gVar 12 E.try (create id') >>= \case - Right _ -> pure $ Right id' + Right x -> pure $ Right x Left e | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) | otherwise -> pure . Left . SEInternal $ bshow e @@ -515,6 +547,8 @@ data StoreError | SEGroupNotFound GroupName | SEGroupWithoutUser | SEDuplicateGroupMember + | SEGroupAlreadyJoined + | SENoGroupInvitation | SEConnectionNotFound ConnId | SEUniqueID | SEInternal ByteString diff --git a/src/Simplex/Chat/Styled.hs b/src/Simplex/Chat/Styled.hs index c344ddf4f..9bbb88d27 100644 --- a/src/Simplex/Chat/Styled.hs +++ b/src/Simplex/Chat/Styled.hs @@ -3,10 +3,9 @@ module Simplex.Chat.Styled ( StyledString (..), - plain, + StyledFormat (..), styleMarkdown, styleMarkdownText, - styled, sLength, ) where diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 7d7e61602..605f315a1 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -20,9 +20,21 @@ import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok (Ok (Ok)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics -import Simplex.Messaging.Agent.Protocol (ConnId) +import Simplex.Messaging.Agent.Protocol (ConnId, SMPQueueInfo) import Simplex.Messaging.Agent.Store.SQLite (fromTextField_) +class IsContact a where + contactId' :: a -> Int64 + profile' :: a -> Profile + +instance IsContact User where + contactId' = userContactId + profile' = profile + +instance IsContact Contact where + contactId' = contactId + profile' = profile + data User = User { userId :: UserId, userContactId :: Int64, @@ -52,7 +64,7 @@ data Group = Group { groupId :: Int64, localDisplayName :: GroupName, groupProfile :: GroupProfile, - members :: [(GroupMember, Connection)], + members :: [(GroupMember, Maybe Connection)], membership :: GroupMember } deriving (Eq, Show) @@ -77,6 +89,24 @@ instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOpt instance FromJSON GroupProfile +data GroupInvitation = GroupInvitation + { fromMember :: MemberInfo, + invitedMember :: MemberInfo, + queueInfo :: SMPQueueInfo, + groupProfile :: GroupProfile + } + deriving (Eq, Show) + +data ReceivedGroupInvitation = ReceivedGroupInvitation + { fromMember :: GroupMember, + invitedMember :: GroupMember, + queueInfo :: SMPQueueInfo, + groupProfile :: GroupProfile + } + deriving (Eq, Show) + +type MemberInfo = (MemberId, GroupMemberRole) + data GroupMember = GroupMember { groupMemberId :: Int64, memberId :: MemberId, @@ -133,8 +163,13 @@ fromBlobField_ p = \case Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e) f -> returnError ConversionFailed f "expecting SQLBlob column type" -data GroupMemberStatus = GSMemInvited | GSMemAccepted | GSMemConnected | GSMemReady - deriving (Eq, Show) +data GroupMemberStatus + = GSMemInvited -- member received (or sent to) invitation + | GSMemAccepted -- member accepted invitation + | 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 + deriving (Eq, Show, Ord) instance FromField GroupMemberStatus where fromField = fromTextField_ memberStatusT @@ -146,6 +181,7 @@ memberStatusT = \case "accepted" -> Just GSMemAccepted "connected" -> Just GSMemConnected "ready" -> Just GSMemReady + "full" -> Just GSMemFull _ -> Nothing serializeMemberStatus :: GroupMemberStatus -> Text @@ -154,6 +190,7 @@ serializeMemberStatus = \case GSMemAccepted -> "accepted" GSMemConnected -> "connected" GSMemReady -> "ready" + GSMemFull -> "full" data Connection = Connection { connId :: Int64, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 226f1888f..dee04bb32 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -15,6 +15,10 @@ module Simplex.Chat.View showReceivedMessage, showSentMessage, showGroupCreated, + showSentGroupInvitation, + showReceivedGroupInvitation, + showConnectedGroupMember, + showUserConnectedToGroup, safeDecodeUtf8, ) where @@ -22,6 +26,7 @@ where import Control.Monad.IO.Unlift import Control.Monad.Reader import Data.ByteString.Char8 (ByteString) +import Data.Composition ((.:)) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (DiffTime, UTCTime) @@ -48,7 +53,7 @@ showChatError = printToView . chatError showContactDeleted :: ChatReader m => ContactName -> m () showContactDeleted = printToView . contactDeleted -showContactConnected :: ChatReader m => ContactName -> m () +showContactConnected :: ChatReader m => Contact -> m () showContactConnected = printToView . contactConnected showContactDisconnected :: ChatReader m => ContactName -> m () @@ -60,29 +65,59 @@ showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage showSentMessage :: ChatReader m => ContactName -> ByteString -> m () showSentMessage c msg = printToView =<< liftIO (sentMessage c msg) -showGroupCreated :: ChatReader m => GroupProfile -> m () +showGroupCreated :: ChatReader m => Group -> m () showGroupCreated = printToView . groupCreated +showSentGroupInvitation :: ChatReader m => Group -> ContactName -> m () +showSentGroupInvitation = printToView .: sentGroupInvitation + +showReceivedGroupInvitation :: ChatReader m => Group -> ContactName -> m () +showReceivedGroupInvitation = printToView .: receivedGroupInvitation + +showConnectedGroupMember :: ChatReader m => GroupName -> ContactName -> m () +showConnectedGroupMember = printToView .: connectedGroupMember + +showUserConnectedToGroup :: ChatReader m => GroupName -> m () +showUserConnectedToGroup = printToView . userConnectedToGroup + invitation :: SMPQueueInfo -> [StyledString] invitation qInfo = [ "pass this invitation to your contact (via another channel): ", "", (plain . serializeSmpQueueInfo) qInfo, "", - "and ask them to connect: /c " + "and ask them to connect: " <> highlight' "/c " ] contactDeleted :: ContactName -> [StyledString] contactDeleted c = [ttyContact c <> " is deleted"] -contactConnected :: ContactName -> [StyledString] -contactConnected c = [ttyContact c <> " is connected"] +contactConnected :: Contact -> [StyledString] +contactConnected ct = [ttyFullContact ct <> " is connected"] contactDisconnected :: ContactName -> [StyledString] contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"] -groupCreated :: GroupProfile -> [StyledString] -groupCreated GroupProfile {displayName, fullName} = ["group " <> ttyGroup displayName <> " (" <> plain fullName <> ") is created"] +groupCreated :: Group -> [StyledString] +groupCreated g@Group {localDisplayName} = + [ "group " <> ttyFullGroup g <> " is created", + "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" + ] + +connectedGroupMember :: GroupName -> ContactName -> [StyledString] +connectedGroupMember g c = [ttyContact c <> " joined the group " <> ttyGroup g] + +userConnectedToGroup :: GroupName -> [StyledString] +userConnectedToGroup g = ["you joined the group " <> ttyGroup g] receivedMessage :: ContactName -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString] receivedMessage c utcTime msg mOk = do @@ -124,10 +159,20 @@ msgPlain = map styleMarkdownText . T.lines chatError :: ChatError -> [StyledString] 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"] + CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> g)] + CEGroupMemberNotReady -> ["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 SEDuplicateName -> ["this display name is already used by user, contact or group"] SEContactNotFound c -> ["no contact " <> ttyContact c] SEContactNotReady c -> ["contact " <> ttyContact c <> " is not active yet"] + SEGroupNotFound g -> ["no group " <> ttyGroup g] + SEGroupAlreadyJoined -> ["you already joined this group"] e -> ["chat db error: " <> plain (show e)] ChatErrorAgent err -> case err of -- CONN e -> case e of @@ -136,7 +181,7 @@ chatError = \case -- DUPLICATE -> ["contact " <> ttyContact c <> " already exists"] -- SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"] e -> ["smp agent error: " <> plain (show e)] - e -> ["chat error: " <> plain (show e)] + ChatErrorMessage e -> ["chat message error: " <> plain (show e)] printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m () printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s) @@ -144,6 +189,10 @@ printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s) ttyContact :: ContactName -> StyledString ttyContact = styled (Colored Green) +ttyFullContact :: Contact -> StyledString +ttyFullContact Contact {localDisplayName, profile = Profile {fullName}} = + ttyContact localDisplayName <> optFullName localDisplayName fullName + ttyToContact :: ContactName -> StyledString ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " " @@ -153,6 +202,21 @@ ttyFromContact c = styled (Colored Yellow) $ c <> "> " ttyGroup :: GroupName -> StyledString ttyGroup g = styled (Colored Blue) $ "#" <> g +ttyFullGroup :: Group -> StyledString +ttyFullGroup Group {localDisplayName, groupProfile = GroupProfile {fullName}} = + ttyGroup localDisplayName <> optFullName localDisplayName fullName + +optFullName :: Text -> Text -> StyledString +optFullName localDisplayName fullName + | localDisplayName == fullName = "" + | otherwise = plain (" (" <> fullName <> ")") + +highlight :: StyledFormat a => a -> StyledString +highlight = styled (Colored Cyan) + +highlight' :: String -> StyledString +highlight' = highlight + -- ttyFromGroup :: Group -> Contact -> StyledString -- ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> " diff --git a/src/Simplex/Chat/protocol.md b/src/Simplex/Chat/protocol.md index d363800b4..adec3f48f 100644 --- a/src/Simplex/Chat/protocol.md +++ b/src/Simplex/Chat/protocol.md @@ -97,3 +97,63 @@ A -> group: `MSG: N x.grp.mem.ok G_MEM_ID_B` #### Send group message `MSG: N x.msg.new G_MEM_ROLE, x.json:NNN ` + +#### Group member statuses + +1. Me + - invited + - accepted + - connected to member who invited me + - announced to group + - x.grp.mem.new to group + - confirmed as connected to group + - this happens once member who invited me sends x.grp.mem.ok to group +1. Member that I invited: + - invited + - accepted + - connected to me + - announced to group + - this happens after x.grp.mem.new but before introductions are sent. + This message is used to determine which members should be additionally introduced if they were announced before (or in "parallel"). + - confirmed as connected to group +2. Member who invited me + - invited_me + - connected to me + - I won't know whether this member was announced or confirmed to group - with the correctly functioning clients it must have happened. +3. Prior member introduced to me after I joined (x.grp.mem.intro) + - introduced + - sent invitation + - connected + - connected directly (or confirmed existing contact) +4. Member I was introduced to after that member joined (via x.grp.mem.fwd) + - announced via x.grp.mem.new + - received invitation + - connected + - connected directly (or confirmed existing contact) + +#### Introductions + +1. Introductions I sent to members I invited + - the time of joining is determined by the time of creating the connection and sending the x.grp.mem.new message to the group. + - introductions of the members who were connected before the new member should be sent - how to determine which members were connected before? + - use time stamp of creating connection, possibly in the member record - not very reliable, as time can change. + - use record ID - requires changing the schema, as currently members are added as invited, not as connected. So possibly invited members should be tracked in a separate table, and all members should still be tracked together to ensure that memberId is unique. + - record ID is also not 100% sufficient, as there can be forks in message history and I may need to intro the member I invited to the member that was announced after my member in my chronology, but in another graph branch. + - some other mechanism that allows to establish who should be connected to whom and whether I should introduce or another member (in case of forks - although maybe we both can introduce and eventually two group connections will be created between these members and they would just ignore the first one - although in cases of multiple branches in the graph it can be N connections). + - introductions/member connection statuses: + - created introduction + - sent to the member I invited + - received the invitation from the member I invited + - forwarded this invitation to previously connected member + - received confirmation from member I invited + - received confirmation from member I forwarded to + - completed introduction and recorded that these members are now fully connected to each other +2. Introductions I received from the member who invited me + - if somebody else sends such introduction - this is an error (can be logged or ignored) + - duplicate memberId is an error (e.g. it is a member that was announced in the group broadcast - I should be introduced to this member, and not the other way around? Although it can happen in case of fork and maybe I should establish the connection anyway). + - member connection status in this case is just a member status from part 3, so maybe no need to track invitations separately and just put SMPQueueInfo on member record. +3. Invitation forwarded to me by any prior member + - any admin/owner can add members, so they can forward their queue invitations - I should just check forwarding member permission + - duplicate memberId is an error + - unannounced memberId is an error - I should have seen member announcement prior to receiving this forwarded invitation. Fork would not happen here as it is the same member that announces and forwards the invitation, so they should be in order. + - member connection status in this case is just a member status from part 4, so maybe no need to track invitations separately and just put SMPQueueInfo on member record. diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 4b5907ee7..be249edbe 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -13,6 +13,7 @@ import Simplex.Chat.Controller (ChatController (..)) import Simplex.Chat.Options import Simplex.Chat.Store import Simplex.Chat.Types (Profile) +import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import qualified System.Terminal as C import System.Terminal.Internal (VirtualTerminal, VirtualTerminalSettings (..), withVirtualTerminal) @@ -51,6 +52,8 @@ virtualSimplexChat dbFile profile = do 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" diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index a13c591d0..28c847621 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -18,16 +18,23 @@ aliceProfile = Profile {displayName = "alice", fullName = "Alice"} bobProfile :: Profile bobProfile = Profile {displayName = "bob", fullName = "Bob"} -testAddContact :: Spec -testAddContact = describe "add chat contact" $ - it "add contact and send/receive message" $ - testChat2 aliceProfile bobProfile $ \alice bob -> do +chatTests :: Spec +chatTests = do + describe "direct messages" $ + it "add contact and send/receive message" testAddContact + describe "chat groups" $ + it "add contacts, create group and send/receive messages" testGroup + +testAddContact :: IO () +testAddContact = + testChat2 aliceProfile bobProfile $ + \alice bob -> do alice ##> "/a" Just inv <- invitation <$> getWindow alice bob ##> ("/c " <> inv) concurrently_ - (bob <## "alice is connected") - (alice <## "bob is connected") + (bob <## "alice (Alice) is connected") + (alice <## "bob (Bob) is connected") alice #> "@bob hello" bob <# "alice> hello" bob #> "@alice hi" @@ -37,8 +44,8 @@ testAddContact = describe "add chat contact" $ Just inv' <- invitation <$> getWindow alice bob ##> ("/c " <> inv') concurrently_ - (bob <## "alice_1 is connected") - (alice <## "bob_1 is connected") + (bob <## "alice_1 (Alice) is connected") + (alice <## "bob_1 (Bob) is connected") alice #> "@bob_1 hello" bob <# "alice_1> hello" bob #> "@alice_1 hi" @@ -46,21 +53,46 @@ testAddContact = describe "add chat contact" $ -- test deleting contact alice ##> "/d bob_1" alice <## "bob_1 is deleted" - chatCommand alice "@bob_1 hey" + alice #:> "@bob_1 hey" alice <## "no contact bob_1" +testGroup :: IO () +testGroup = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + 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 <## "invitation to join the group #team sent to bob" + bob <## "use /j #team to accept" + bob ##> "/j #team" + concurrently_ + (alice <## "bob joined the group #team") + (bob <## "you joined the group #team") + +connectUsers :: TestCC -> TestCC -> IO () +connectUsers cc1 cc2 = do + cc1 ##> "/a" + Just inv <- invitation <$> getWindow cc1 + cc2 ##> ("/c " <> inv) + concurrently_ + (cc2 <## "alice (Alice) is connected") + (cc1 <## "bob (Bob) is connected") + (##>) :: TestCC -> String -> IO () (##>) cc cmd = do - chatCommand cc cmd + cc #:> cmd cc <## cmd (#>) :: TestCC -> String -> IO () (#>) cc cmd = do - chatCommand cc cmd + cc #:> cmd cc <# cmd -chatCommand :: TestCC -> String -> IO () -chatCommand (TestCC cc _ _) cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd +(#:>) :: TestCC -> String -> IO () +(#:>) (TestCC cc _ _) cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd (<##) :: TestCC -> String -> Expectation cc <## line = (lastOutput <$> getWindow cc) `shouldReturn` line diff --git a/tests/Test.hs b/tests/Test.hs index 990d86ca0..ef5368a7e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,14 +1,11 @@ import ChatTests import MarkdownTests import ProtocolTests -import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import Test.Hspec main :: IO () main = do - createDirectoryIfMissing False "tests/tmp" hspec $ do describe "SimpleX chat markdown" markdownTests describe "SimpleX chat protocol" protocolTests - xdescribe "SimpleX chat client" testAddContact - removeDirectoryRecursive "tests/tmp" + xdescribe "SimpleX chat client" chatTests