mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
started chat groups protocol (#75)
* create group * add user as member, store methods to get group and to create group member * add group member and send member invitation * fix ci: use simplexmq from github * chat protocol: create SMP agent connection when inviting member * update protocol, started group invitation receiving
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
24c62584fc
commit
e99c4bda1e
+58
-38
@@ -15,7 +15,8 @@ import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
|
||||
import Crypto.Random (drgNew)
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -42,12 +43,11 @@ import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Client (smpDefaultConfig)
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow, raceAny_)
|
||||
import Simplex.Messaging.Util (raceAny_)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (hFlush, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
import UnliftIO.Async (race_)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
|
||||
data ChatCommand
|
||||
@@ -57,7 +57,7 @@ data ChatCommand
|
||||
| Connect SMPQueueInfo
|
||||
| DeleteContact ContactRef
|
||||
| SendMessage ContactRef ByteString
|
||||
| NewGroup GroupRef
|
||||
| NewGroup GroupProfile
|
||||
| AddMember GroupRef ContactRef GroupMemberRole
|
||||
| RemoveMember GroupRef ContactRef
|
||||
| MemberRole GroupRef ContactRef GroupMemberRole
|
||||
@@ -97,9 +97,10 @@ newChatController ChatOpts {dbFile, smpServers} t sendNotification = do
|
||||
currentUser <- getCreateActiveUser chatStore
|
||||
chatTerminal <- newChatTerminal t
|
||||
smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
|
||||
idsDrg <- newTVarIO =<< drgNew
|
||||
inputQ <- newTBQueueIO $ tbqSize cfg
|
||||
notifyQ <- newTBQueueIO $ tbqSize cfg
|
||||
pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, inputQ, notifyQ, sendNotification}
|
||||
pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, idsDrg, inputQ, notifyQ, sendNotification}
|
||||
|
||||
runSimplexChat :: ChatController -> IO ()
|
||||
runSimplexChat = runReaderT (race_ runTerminalInput runChatController)
|
||||
@@ -129,7 +130,7 @@ inputSubscriber = do
|
||||
void . runExceptT $ processChatCommand user cmd `catchError` showChatError
|
||||
|
||||
processChatCommand :: ChatMonad m => User -> ChatCommand -> m ()
|
||||
processChatCommand User {userId, profile} = \case
|
||||
processChatCommand user@User {userId, profile} = \case
|
||||
ChatHelp -> printToView chatHelpInfo
|
||||
MarkdownHelp -> printToView markdownInfo
|
||||
AddContact -> do
|
||||
@@ -137,30 +138,49 @@ processChatCommand User {userId, profile} = \case
|
||||
withStore $ \st -> createDirectConnection st userId connId
|
||||
showInvitation qInfo
|
||||
Connect qInfo -> do
|
||||
connId <- withAgent $ \agent -> joinConnection agent qInfo $ encodeProfile profile
|
||||
connId <- withAgent $ \a -> joinConnection a qInfo $ encodeProfile profile
|
||||
withStore $ \st -> createDirectConnection st userId connId
|
||||
DeleteContact cRef -> do
|
||||
conns <- withStore $ \st -> getContactConnections st userId cRef
|
||||
withAgent $ \smp -> forM_ conns $ \Connection {agentConnId} ->
|
||||
deleteConnection smp agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
|
||||
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
|
||||
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
|
||||
withStore $ \st -> deleteContact st userId cRef
|
||||
unsetActive $ ActiveC cRef
|
||||
when (null conns) . throwError . ChatErrorContact $ CENotFound cRef
|
||||
showContactDeleted cRef
|
||||
SendMessage cRef msg -> do
|
||||
Connection {agentConnId} <- withStore $ \st -> getContactConnection st userId cRef
|
||||
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}
|
||||
void . withAgent $ \smp -> sendMessage smp agentConnId $ serializeRawChatMessage rawMsg
|
||||
connId = contactConnId contact
|
||||
void . withAgent $ \a -> sendMessage a connId $ serializeRawChatMessage rawMsg
|
||||
setActive $ ActiveC cRef
|
||||
NewGroup _gRef -> pure ()
|
||||
AddMember _gRef _cRef _mRole -> pure ()
|
||||
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
|
||||
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
|
||||
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
|
||||
MemberRole _gRef _cRef _mRole -> pure ()
|
||||
RemoveMember _gRef _cRef -> pure ()
|
||||
LeaveGroup _gRef -> pure ()
|
||||
DeleteGroup _gRef -> pure ()
|
||||
ListMembers _gRef -> pure ()
|
||||
SendGroupMessage _gRef _msg -> pure ()
|
||||
where
|
||||
isMember :: Contact -> [(GroupMember, Connection)] -> Bool
|
||||
isMember Contact {contactId} members = isJust $ find ((== Just contactId) . memberContactId . fst) members
|
||||
|
||||
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
agentSubscriber = do
|
||||
@@ -175,13 +195,14 @@ processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agen
|
||||
processAgentMessage User {userId, profile} agentConnId agentMessage = do
|
||||
chatDirection <- withStore $ \st -> getConnectionChatDirection st userId agentConnId
|
||||
case chatDirection of
|
||||
ReceivedDirectMessage Contact {localContactRef = c} ->
|
||||
ReceivedDirectMessage (CContact ct@Contact {localContactRef = c}) ->
|
||||
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
|
||||
XInfo _ -> pure () -- TODO profile update
|
||||
XGrpInv fromMem invMem qInfo groupProfile -> groupInvitation ct fromMem invMem qInfo groupProfile
|
||||
_ -> pure ()
|
||||
CON -> do
|
||||
-- TODO update connection status
|
||||
@@ -193,14 +214,14 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do
|
||||
showToast ("@" <> c) "disconnected"
|
||||
unsetActive $ ActiveC c
|
||||
_ -> pure ()
|
||||
ReceivedDirectMessage NewContact {activeConn} ->
|
||||
ReceivedDirectMessage (CConnection conn) ->
|
||||
case agentMessage of
|
||||
CONF confId connInfo -> do
|
||||
-- TODO update connection status
|
||||
saveConnInfo activeConn connInfo
|
||||
saveConnInfo conn connInfo
|
||||
withAgent $ \a -> allowConnection a agentConnId confId $ encodeProfile profile
|
||||
INFO connInfo ->
|
||||
saveConnInfo activeConn connInfo
|
||||
saveConnInfo conn connInfo
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
where
|
||||
@@ -213,6 +234,11 @@ 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
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwError $ ChatError CEGroupRole
|
||||
when (fromMemId == memId) $ throwError $ ChatError CEGroupDuplicateMember
|
||||
|
||||
parseChatMessage :: ByteString -> Either ChatError ChatMessage
|
||||
parseChatMessage msgBody = first ChatErrorMessage (parseAll rawChatMessageP msgBody >>= toChatMessage)
|
||||
|
||||
@@ -305,26 +331,16 @@ withStore ::
|
||||
ChatMonad m =>
|
||||
(forall m'. (MonadUnliftIO m', MonadError StoreError m') => SQLiteStore -> m' a) ->
|
||||
m a
|
||||
withStore action = do
|
||||
st <- asks chatStore
|
||||
runExceptT (action st `E.catch` handleInternal) >>= \case
|
||||
Right c -> pure c
|
||||
Left e -> throwError $ storeError e
|
||||
where
|
||||
-- TODO when parsing exception happens in store, the agent hangs;
|
||||
-- changing SQLError to SomeException does not help
|
||||
handleInternal :: (MonadError StoreError m') => E.SomeException -> m' a
|
||||
handleInternal e = throwError . SEInternal $ bshow e
|
||||
storeError :: StoreError -> ChatError
|
||||
storeError = \case
|
||||
SEContactNotFound c -> ChatErrorContact $ CENotFound c
|
||||
e -> ChatErrorStore e
|
||||
withStore action =
|
||||
asks chatStore
|
||||
>>= runExceptT . action
|
||||
>>= liftEither . first ChatErrorStore
|
||||
|
||||
chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
("/help" <|> "/h") $> ChatHelp
|
||||
<|> ("/group #" <|> "/g #") *> (NewGroup <$> groupRef)
|
||||
<|> ("/add #" <|> "/a #") *> (AddMember <$> groupRef <* A.space <*> contactRef <* A.space <*> memberRole)
|
||||
<|> ("/group #" <|> "/g #") *> (NewGroup <$> groupProfile)
|
||||
<|> ("/add #" <|> "/a #") *> (AddMember <$> groupRef <* A.space <*> contactRef <*> memberRole)
|
||||
<|> ("/remove #" <|> "/rm #") *> (RemoveMember <$> groupRef <* A.space <*> contactRef)
|
||||
<|> ("/delete #" <|> "/d #") *> (DeleteGroup <$> groupRef)
|
||||
<|> ("/members #" <|> "/ms #") *> (ListMembers <$> groupRef)
|
||||
@@ -338,8 +354,12 @@ chatCommandP =
|
||||
contactRef = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' '))
|
||||
refChar c = c > ' ' && c /= '#' && c /= '@'
|
||||
groupRef = contactRef
|
||||
groupProfile = do
|
||||
gRef <- groupRef
|
||||
gName <- safeDecodeUtf8 <$> (A.space *> A.takeByteString) <|> pure ""
|
||||
pure GroupProfile {groupRef = gRef, displayName = if T.null gName then gRef else gName}
|
||||
memberRole =
|
||||
("owner" $> GROwner)
|
||||
<|> ("admin" $> GRAdmin)
|
||||
<|> ("normal" $> GRMember)
|
||||
<?> "memberRole"
|
||||
(" owner" $> GROwner)
|
||||
<|> (" admin" $> GRAdmin)
|
||||
<|> (" normal" $> GRMember)
|
||||
<|> pure GRMember
|
||||
|
||||
@@ -10,6 +10,7 @@ import Control.Exception
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Simplex.Chat.Notification
|
||||
import Simplex.Chat.Store (StoreError)
|
||||
import Simplex.Chat.Terminal
|
||||
@@ -24,6 +25,7 @@ data ChatController = ChatController
|
||||
smpAgent :: AgentClient,
|
||||
chatTerminal :: ChatTerminal,
|
||||
chatStore :: SQLiteStore,
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
inputQ :: TBQueue InputEvent,
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO ()
|
||||
@@ -32,14 +34,13 @@ data ChatController = ChatController
|
||||
data InputEvent = InputCommand String | InputControl Char
|
||||
|
||||
data ChatError
|
||||
= ChatErrorContact ContactError
|
||||
= ChatError ChatErrorType
|
||||
| ChatErrorMessage String
|
||||
| ChatErrorAgent AgentErrorType
|
||||
| ChatErrorStore StoreError
|
||||
deriving (Show, Exception)
|
||||
|
||||
data ContactError = CENotFound ContactRef | CEProfile String
|
||||
deriving (Show, Exception)
|
||||
data ChatErrorType = CEGroupRole | CEGroupDuplicateMember deriving (Show, Exception)
|
||||
|
||||
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
|
||||
|
||||
|
||||
@@ -12,7 +12,6 @@ module Simplex.Chat.Protocol where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import Control.Monad ((<=<))
|
||||
import Control.Monad.Except (throwError)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
@@ -30,44 +29,38 @@ import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
|
||||
data ChatDirection (p :: AParty) where
|
||||
ReceivedDirectMessage :: Contact -> ChatDirection 'Agent
|
||||
SentDirectMessage :: Contact -> ChatDirection 'Client
|
||||
ReceivedGroupMessage :: Group -> Contact -> ChatDirection 'Agent
|
||||
ReceivedDirectMessage :: ConnContact -> ChatDirection 'Agent
|
||||
SentDirectMessage :: ConnContact -> ChatDirection 'Client
|
||||
ReceivedGroupMessage :: Group -> ConnContact -> ChatDirection 'Agent
|
||||
SentGroupMessage :: Group -> 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
|
||||
{ messageType :: MessageType,
|
||||
files :: [(ContentType, Int)],
|
||||
content :: [MsgBodyContent]
|
||||
}
|
||||
| XInfo Profile
|
||||
| XGrpInv InvitationId MemberId GroupMemberRole GroupProfile
|
||||
| XGrpAcpt InvitationId SMPQueueInfo
|
||||
| XGrpInv
|
||||
{ fromMember :: (MemberId, GroupMemberRole),
|
||||
invitedMember :: (MemberId, GroupMemberRole),
|
||||
queueInfo :: SMPQueueInfo,
|
||||
groupProfile :: GroupProfile
|
||||
}
|
||||
| XGrpAcpt MemberId
|
||||
| XGrpMemNew MemberId GroupMemberRole Profile
|
||||
| XGrpMemIntro MemberId GroupMemberRole Profile
|
||||
deriving (Eq, Show)
|
||||
|
||||
type MemberId = ByteString
|
||||
|
||||
data MessageType = MTText | MTImage deriving (Eq, Show)
|
||||
|
||||
data GroupMemberRole = GROwner | GRAdmin | GRMember
|
||||
deriving (Eq, Show)
|
||||
|
||||
toMemberRole :: ByteString -> Either String GroupMemberRole
|
||||
toMemberRole = \case
|
||||
"owner" -> Right GROwner
|
||||
"admin" -> Right GRAdmin
|
||||
"member" -> Right GRMember
|
||||
r -> Left $ "invalid group member role " <> B.unpack r
|
||||
|
||||
serializeMemberRole :: GroupMemberRole -> ByteString
|
||||
serializeMemberRole = \case
|
||||
GROwner -> "owner"
|
||||
GRAdmin -> "admin"
|
||||
GRMember -> "member"
|
||||
|
||||
toMsgType :: ByteString -> Either String MessageType
|
||||
toMsgType = \case
|
||||
"c.text" -> Right MTText
|
||||
@@ -96,41 +89,38 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod
|
||||
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
|
||||
let msg = XMsgNew {messageType = t, files, content = body}
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
[] -> throwError "x.msg.new expects at least one parameter"
|
||||
[] -> 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}
|
||||
_ -> throwError "x.info expects no parameters"
|
||||
_ -> Left "x.info expects no parameters"
|
||||
"x.grp.inv" -> case chatMsgParams of
|
||||
[invId', memId', role'] -> do
|
||||
invId <- B64.decode invId'
|
||||
memId <- B64.decode memId'
|
||||
role <- toMemberRole role'
|
||||
groupProfile <- getJSON body
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = XGrpInv invId memId role groupProfile, chatDAG}
|
||||
_ -> throwError "x.grp.inv expects 3 parameters"
|
||||
[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}
|
||||
_ -> Left "x.grp.inv expects 5 parameters"
|
||||
"x.grp.acpt" -> case chatMsgParams of
|
||||
[invId, qInfo] -> do
|
||||
msg <- XGrpAcpt <$> B64.decode invId <*> parseAll smpQueueInfoP qInfo
|
||||
[memId] -> do
|
||||
msg <- XGrpAcpt <$> B64.decode memId
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
_ -> throwError "x.grp.acpt expects 2 parameters"
|
||||
"x.grp.mem.new" -> case chatMsgParams of
|
||||
[memId, role] -> do
|
||||
msg <- XGrpMemNew <$> B64.decode memId <*> toMemberRole role <*> getJSON body
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
_ -> throwError "x.grp.acpt expects 2 parameters"
|
||||
"x.grp.mem.intro" -> case chatMsgParams of
|
||||
[memId, role] -> do
|
||||
msg <- XGrpMemIntro <$> B64.decode memId <*> toMemberRole role <*> getJSON body
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
|
||||
_ -> throwError "x.grp.acpt expects 2 parameters"
|
||||
_ -> throwError $ "unsupported event " <> B.unpack chatMsgEvent
|
||||
_ -> 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
|
||||
where
|
||||
getDAG :: [MsgBodyContent] -> (Maybe ByteString, [MsgBodyContent])
|
||||
getDAG body = case break (isContentType SimplexDAG) body of
|
||||
(b, MsgBodyContent 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"
|
||||
toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
|
||||
toContentInfo (rawType, size) = (,size) <$> toContentType rawType
|
||||
getJSON :: FromJSON a => [MsgBodyContent] -> Either String a
|
||||
@@ -161,12 +151,18 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
XInfo profile ->
|
||||
let chatMsgBody = rawWithDAG [jsonBody profile]
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody}
|
||||
XGrpInv invId memId role groupProfile ->
|
||||
let chatMsgParams = [B64.encode invId, B64.encode memId, serializeMemberRole role]
|
||||
XGrpInv (fromMemId, fromRole) (memId, role) qInfo groupProfile ->
|
||||
let chatMsgParams =
|
||||
[ 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}
|
||||
XGrpAcpt invId qInfo ->
|
||||
let chatMsgParams = [B64.encode invId, serializeSmpQueueInfo qInfo]
|
||||
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]
|
||||
|
||||
+302
-52
@@ -8,6 +8,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Simplex.Chat.Store
|
||||
( SQLiteStore,
|
||||
@@ -19,16 +20,23 @@ module Simplex.Chat.Store
|
||||
createDirectConnection,
|
||||
createDirectContact,
|
||||
deleteContact,
|
||||
getContactConnection,
|
||||
getContact,
|
||||
getContactConnections,
|
||||
getConnectionChatDirection,
|
||||
createNewGroup,
|
||||
createGroup,
|
||||
getGroup,
|
||||
createGroupMember,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM (stateTVar)
|
||||
import Control.Exception (Exception)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Crypto.Random (ChaChaDRG, randomBytesGenerate)
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.FileEmbed (embedDir, makeRelativeToProject)
|
||||
import Data.Function (on)
|
||||
@@ -39,7 +47,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), SQLError)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), SQLError, (:.) (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Protocol
|
||||
@@ -49,6 +57,7 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>))
|
||||
import System.FilePath (takeBaseName, takeExtension)
|
||||
import UnliftIO.STM
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
migrations :: [Migration]
|
||||
@@ -71,22 +80,22 @@ handleSQLError err e
|
||||
| otherwise = SEInternal $ bshow e
|
||||
|
||||
insertedRowId :: DB.Connection -> IO Int64
|
||||
insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid();"
|
||||
insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()"
|
||||
|
||||
createUser :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> Profile -> Bool -> m User
|
||||
createUser st Profile {contactRef, displayName} activeUser =
|
||||
liftIOEither . checkConstraint SEDuplicateContactRef . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?);" (contactRef, displayName)
|
||||
DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?)" (contactRef, displayName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO users (contact_id, active_user) VALUES (0, ?);" (Only activeUser)
|
||||
DB.execute db "INSERT INTO users (contact_id, active_user) VALUES (0, ?)" (Only activeUser)
|
||||
userId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO contacts (contact_profile_id, local_contact_ref, lcr_base, user_id, user) VALUES (?, ?, ?, ?, 1);"
|
||||
(profileId, contactRef, contactRef, userId)
|
||||
"INSERT INTO contacts (contact_profile_id, local_contact_ref, lcr_base, user_id, is_user) VALUES (?, ?, ?, ?, ?)"
|
||||
(profileId, contactRef, contactRef, userId, True)
|
||||
contactId <- insertedRowId db
|
||||
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?;" (contactId, userId)
|
||||
pure . Right $ toUser (userId, activeUser, contactRef, displayName)
|
||||
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
|
||||
pure . Right $ toUser (userId, contactId, activeUser, contactRef, displayName)
|
||||
|
||||
getUsers :: SQLiteStore -> IO [User]
|
||||
getUsers st =
|
||||
@@ -95,22 +104,22 @@ getUsers st =
|
||||
<$> DB.query_
|
||||
db
|
||||
[sql|
|
||||
SELECT u.user_id, u.active_user, c.local_contact_ref, p.display_name
|
||||
SELECT u.user_id, u.contact_id, u.active_user, c.local_contact_ref, p.display_name
|
||||
FROM users u
|
||||
JOIN contacts c ON u.contact_id = c.contact_id
|
||||
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
|
||||
|]
|
||||
|
||||
toUser :: (UserId, Bool, ContactRef, Text) -> User
|
||||
toUser (userId, activeUser, contactRef, displayName) =
|
||||
toUser :: (UserId, Int64, Bool, ContactRef, Text) -> User
|
||||
toUser (userId, userContactId, activeUser, contactRef, displayName) =
|
||||
let profile = Profile {contactRef, displayName}
|
||||
in User {userId, localContactRef = contactRef, profile, activeUser}
|
||||
in User {userId, userContactId, localContactRef = contactRef, profile, activeUser}
|
||||
|
||||
setActiveUser :: MonadUnliftIO m => SQLiteStore -> UserId -> m ()
|
||||
setActiveUser st userId = do
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute_ db "UPDATE users SET active_user = 0;"
|
||||
DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?;" (Only userId)
|
||||
DB.execute_ db "UPDATE users SET active_user = 0"
|
||||
DB.execute db "UPDATE users SET active_user = 1 WHERE user_id = ?" (Only userId)
|
||||
|
||||
createDirectConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> m ()
|
||||
createDirectConnection st userId agentConnId =
|
||||
@@ -127,7 +136,7 @@ createDirectContact ::
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> Connection -> Profile -> m ()
|
||||
createDirectContact st userId Connection {connId} Profile {contactRef, displayName} =
|
||||
liftIOEither . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?);" (contactRef, displayName)
|
||||
DB.execute db "INSERT INTO contact_profiles (contact_ref, display_name) VALUES (?, ?)" (contactRef, displayName)
|
||||
profileId <- insertedRowId db
|
||||
lcrSuffix <- getLcrSuffix db
|
||||
create db profileId lcrSuffix 20
|
||||
@@ -141,7 +150,7 @@ createDirectContact st userId Connection {connId} Profile {contactRef, displayNa
|
||||
SELECT lcr_suffix FROM contacts
|
||||
WHERE user_id = :user_id AND lcr_base = :contact_ref
|
||||
ORDER BY lcr_suffix DESC
|
||||
LIMIT 1;
|
||||
LIMIT 1
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
create :: DB.Connection -> Int64 -> Int -> Int -> IO (Either StoreError ())
|
||||
@@ -179,24 +188,62 @@ deleteContact st userId contactRef =
|
||||
FROM connections c
|
||||
JOIN contacts cs ON c.contact_id = cs.contact_id
|
||||
WHERE cs.user_id = :user_id AND cs.local_contact_ref = :contact_ref
|
||||
);
|
||||
)
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
DB.executeNamed
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM contacts
|
||||
WHERE user_id = :user_id AND local_contact_ref = :contact_ref;
|
||||
WHERE user_id = :user_id AND local_contact_ref = :contact_ref
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getContactConnection ::
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m Connection
|
||||
getContactConnection st userId contactRef =
|
||||
getContact ::
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m Contact
|
||||
getContact st userId localContactRef =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
c@Contact {contactId} <- getContact_ db
|
||||
activeConn <- getConnection_ db contactId
|
||||
pure $ (c :: Contact) {activeConn}
|
||||
where
|
||||
getContact_ db = ExceptT $ do
|
||||
toContact
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT c.contact_id, p.contact_ref, p.display_name
|
||||
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_contact_ref = :local_contact_ref AND c.is_user = :is_user
|
||||
|]
|
||||
[":user_id" := userId, ":local_contact_ref" := localContactRef, ":is_user" := False]
|
||||
getConnection_ db contactId = ExceptT $ do
|
||||
connection
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT 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 connections c
|
||||
WHERE c.user_id = :user_id AND c.contact_id == :contact_id
|
||||
ORDER BY c.connection_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
[":user_id" := userId, ":contact_id" := contactId]
|
||||
toContact [(contactId, contactRef, displayName)] =
|
||||
let profile = Profile {contactRef, displayName}
|
||||
in Right Contact {contactId, localContactRef, profile, activeConn = undefined}
|
||||
toContact _ = Left $ SEContactNotFound localContactRef
|
||||
connection (connRow : _) = Right $ toConnection connRow
|
||||
connection _ = Left $ SEContactNotReady localContactRef
|
||||
|
||||
getContactConnections :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m [Connection]
|
||||
getContactConnections st userId contactRef =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
connection
|
||||
connections
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
@@ -207,33 +254,15 @@ getContactConnection st userId contactRef =
|
||||
WHERE c.user_id = :user_id
|
||||
AND cs.user_id = :user_id
|
||||
AND cs.local_contact_ref == :contact_ref
|
||||
ORDER BY c.connection_id DESC
|
||||
LIMIT 1;
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
where
|
||||
connection (connRow : _) = Right $ toConnection connRow
|
||||
connection _ = Left $ SEContactNotFound contactRef
|
||||
connections [] = Left $ SEContactNotFound contactRef
|
||||
connections rows = Right $ map toConnection rows
|
||||
|
||||
getContactConnections :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m [Connection]
|
||||
getContactConnections st userId contactRef =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
map toConnection
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT 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 connections c
|
||||
JOIN contacts cs ON c.contact_id == cs.contact_id
|
||||
WHERE c.user_id = :user_id
|
||||
AND cs.user_id = :user_id
|
||||
AND cs.local_contact_ref == :contact_ref;
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, UTCTime)
|
||||
|
||||
toConnection ::
|
||||
(Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, UTCTime) -> Connection
|
||||
toConnection :: ConnectionRow -> Connection
|
||||
toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt) =
|
||||
let entityId = entityId_ connType
|
||||
in Connection {connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId, createdAt}
|
||||
@@ -246,16 +275,16 @@ getConnectionChatDirection ::
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ConnId -> m (ChatDirection 'Agent)
|
||||
getConnectionChatDirection st userId agentConnId =
|
||||
liftIOEither . withTransaction st $ \db -> do
|
||||
getConnection db >>= \case
|
||||
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 NewContact {activeConn = c}
|
||||
Just cId -> getContact db cId c
|
||||
Nothing -> pure . Right $ CConnection c
|
||||
Just cId -> getContact_ db cId c
|
||||
where
|
||||
getConnection db =
|
||||
getConnection_ db =
|
||||
connection
|
||||
<$> DB.query
|
||||
db
|
||||
@@ -263,12 +292,12 @@ getConnectionChatDirection st userId agentConnId =
|
||||
SELECT connection_id, agent_conn_id, conn_level, via_contact,
|
||||
conn_status, conn_type, contact_id, group_member_id, created_at
|
||||
FROM connections
|
||||
WHERE user_id = ? AND agent_conn_id = ?;
|
||||
WHERE user_id = ? AND agent_conn_id = ?
|
||||
|]
|
||||
(userId, agentConnId)
|
||||
connection (connRow : _) = Right $ toConnection connRow
|
||||
connection _ = Left $ SEConnectionNotFound agentConnId
|
||||
getContact db contactId c =
|
||||
getContact_ db contactId c =
|
||||
toContact contactId c
|
||||
<$> DB.query
|
||||
db
|
||||
@@ -281,12 +310,233 @@ getConnectionChatDirection st userId agentConnId =
|
||||
(userId, contactId)
|
||||
toContact contactId c [(localContactRef, contactRef, displayName)] =
|
||||
let profile = Profile {contactRef, displayName}
|
||||
in Right Contact {contactId, localContactRef, profile, activeConn = c}
|
||||
in Right $ CContact Contact {contactId, localContactRef, profile, activeConn = c}
|
||||
toContact _ _ _ = Left $ SEInternal "referenced contact 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 {groupRef, displayName} =
|
||||
liftIOEither . checkConstraint SEDuplicateGroupRef . withTransaction st $ \db -> do
|
||||
-- group inserted before profile to ensure its local_group_ref is unique
|
||||
DB.execute db "INSERT INTO groups (local_group_ref, lgr_base, user_id) VALUES (?, ?, ?)" (groupRef, groupRef, userId)
|
||||
groupId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO group_profiles (group_ref, display_name) VALUES (?, ?)" (groupRef, displayName)
|
||||
profileId <- insertedRowId db
|
||||
DB.execute db "UPDATE groups SET group_profile_id = ? WHERE group_id = ?" (profileId, groupId)
|
||||
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, localGroupRef = groupRef, groupProfile = p, 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 {groupRef, displayName} =
|
||||
liftIOEither . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO group_profiles (group_ref, display_name) VALUES (?, ?)" (groupRef, displayName)
|
||||
profileId <- insertedRowId db
|
||||
lgrSuffix <- getLgrSuffix db
|
||||
group <- create db profileId lgrSuffix 20
|
||||
pure group
|
||||
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, localGroupRef = groupRef, groupProfile = p, members = [], membership}
|
||||
|
||||
getLgrSuffix :: DB.Connection -> IO Int
|
||||
getLgrSuffix db =
|
||||
maybe 0 ((+ 1) . fromOnly) . listToMaybe
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT lgr_suffix FROM groups
|
||||
WHERE user_id = :user_id AND lgr_base = :group_ref
|
||||
ORDER BY lgr_suffix DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
[":user_id" := userId, ":group_ref" := groupRef]
|
||||
create :: DB.Connection -> Int64 -> Int -> Int -> IO (Either StoreError Group)
|
||||
create _ _ _ 0 = pure $ Left SEDuplicateGroupRef
|
||||
create db profileId lgrSuffix attempts = do
|
||||
let lgr = localGroupRef' lgrSuffix
|
||||
E.try (insertGroup lgr) >>= \case
|
||||
Right () -> do
|
||||
groupId <- insertedRowId db
|
||||
pure $ Right Group {groupId, localGroupRef = lgr, groupProfile = p, members = undefined, membership = undefined}
|
||||
Left e
|
||||
| DB.sqlError e == DB.ErrorConstraint -> create db profileId (lgrSuffix + 1) (attempts - 1)
|
||||
| otherwise -> E.throwIO e
|
||||
where
|
||||
localGroupRef' 0 = groupRef
|
||||
localGroupRef' n = groupRef <> T.pack ('_' : show n)
|
||||
insertGroup lgr =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO groups
|
||||
(group_profile_id, local_group_ref, lgr_base, lgr_suffix, user_id) VALUES (?, ?, ?, ?, ?)
|
||||
|]
|
||||
(profileId, lgr, groupRef, lgrSuffix, userId)
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getGroup :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> User -> GroupRef -> m Group
|
||||
getGroup st User {userId, userContactId} localGroupRef =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
g@Group {groupId} <- getGroup_ db
|
||||
members <- getMembers_ db groupId
|
||||
membership <- getUserMember_ db groupId
|
||||
pure g {members, membership}
|
||||
where
|
||||
getGroup_ :: DB.Connection -> ExceptT StoreError IO Group
|
||||
getGroup_ db = ExceptT $ do
|
||||
toGroup
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.group_id, p.group_ref, p.display_name
|
||||
FROM groups g
|
||||
JOIN group_profiles p ON p.group_profile_id = g.group_profile_id
|
||||
WHERE g.local_group_ref = ? AND g.user_id = ?
|
||||
|]
|
||||
(localGroupRef, userId)
|
||||
toGroup :: [(Int64, GroupRef, Text)] -> Either StoreError Group
|
||||
toGroup [(groupId, groupRef, displayName)] =
|
||||
let groupProfile = GroupProfile {groupRef, displayName}
|
||||
in Right Group {groupId, localGroupRef, groupProfile, members = undefined, membership = undefined}
|
||||
toGroup _ = Left $ SEGroupNotFound localGroupRef
|
||||
getMembers_ :: DB.Connection -> Int64 -> ExceptT StoreError IO [(GroupMember, Connection)]
|
||||
getMembers_ db 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.contact_ref, p.display_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 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
|
||||
|]
|
||||
(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.contact_ref, p.display_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, contactRef, displayName) =
|
||||
let memberProfile = Profile {contactRef, displayName}
|
||||
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
|
||||
|
||||
type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberStatus, Maybe Int64, Maybe Int64, ContactRef, 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)
|
||||
|
||||
createMember_ :: DB.Connection -> Int64 -> Int64 -> GroupMemberRole -> GroupMemberStatus -> Maybe Int64 -> ByteString -> IO ()
|
||||
createMember_ db groupId contactId memberRole memberStatus invitedBy memberId =
|
||||
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" := invitedBy,
|
||||
":contact_id" := contactId
|
||||
]
|
||||
|
||||
createWithRandomId :: TVar ChaChaDRG -> (ByteString -> IO ()) -> IO (Either StoreError ByteString)
|
||||
createWithRandomId gVar create = tryCreate 3
|
||||
where
|
||||
tryCreate :: Int -> IO (Either StoreError ByteString)
|
||||
tryCreate 0 = pure $ Left SEUniqueID
|
||||
tryCreate n = do
|
||||
id' <- randomId gVar 12
|
||||
E.try (create id') >>= \case
|
||||
Right _ -> pure $ Right id'
|
||||
Left e
|
||||
| DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1)
|
||||
| otherwise -> pure . Left . SEInternal $ bshow e
|
||||
|
||||
randomId :: TVar ChaChaDRG -> Int -> IO ByteString
|
||||
randomId gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n)
|
||||
|
||||
data StoreError
|
||||
= SEDuplicateContactRef
|
||||
| SEContactNotFound ContactRef
|
||||
| SEContactNotReady ContactRef
|
||||
| SEDuplicateGroupRef
|
||||
| SEGroupNotFound GroupRef
|
||||
| SEGroupWithoutUser
|
||||
| SEDuplicateGroupMember
|
||||
| SEConnectionNotFound ConnId
|
||||
| SEUniqueID
|
||||
| SEInternal ByteString
|
||||
deriving (Show, Exception)
|
||||
|
||||
+10
-10
@@ -3,7 +3,6 @@
|
||||
|
||||
module Simplex.Chat.Styled
|
||||
( StyledString (..),
|
||||
bPlain,
|
||||
plain,
|
||||
styleMarkdown,
|
||||
styleMarkdownText,
|
||||
@@ -28,12 +27,6 @@ instance Monoid StyledString where mempty = plain ""
|
||||
|
||||
instance IsString StyledString where fromString = plain
|
||||
|
||||
plain :: String -> StyledString
|
||||
plain = Styled []
|
||||
|
||||
bPlain :: ByteString -> StyledString
|
||||
bPlain = Styled [] . B.unpack
|
||||
|
||||
styleMarkdownText :: Text -> StyledString
|
||||
styleMarkdownText = styleMarkdown . parseMarkdown
|
||||
|
||||
@@ -48,12 +41,19 @@ wrap c s = plain [c] <> s <> plain [c]
|
||||
|
||||
class StyledFormat a where
|
||||
styled :: Format -> a -> StyledString
|
||||
plain :: a -> StyledString
|
||||
|
||||
instance StyledFormat String where styled = Styled . sgr
|
||||
instance StyledFormat String where
|
||||
styled = Styled . sgr
|
||||
plain = Styled []
|
||||
|
||||
instance StyledFormat ByteString where styled f = styled f . B.unpack
|
||||
instance StyledFormat ByteString where
|
||||
styled f = styled f . B.unpack
|
||||
plain = Styled [] . B.unpack
|
||||
|
||||
instance StyledFormat Text where styled f = styled f . T.unpack
|
||||
instance StyledFormat Text where
|
||||
styled f = styled f . T.unpack
|
||||
plain = Styled [] . T.unpack
|
||||
|
||||
sgr :: Format -> [SGR]
|
||||
sgr = \case
|
||||
|
||||
+99
-10
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Types where
|
||||
@@ -8,10 +9,15 @@ module Simplex.Chat.Types where
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError)
|
||||
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)
|
||||
@@ -19,6 +25,7 @@ import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
|
||||
data User = User
|
||||
{ userId :: UserId,
|
||||
userContactId :: Int64,
|
||||
localContactRef :: ContactRef,
|
||||
profile :: Profile,
|
||||
activeUser :: Bool
|
||||
@@ -26,23 +33,27 @@ data User = User
|
||||
|
||||
type UserId = Int64
|
||||
|
||||
data Contact
|
||||
= Contact
|
||||
{ contactId :: Int64,
|
||||
localContactRef :: ContactRef,
|
||||
profile :: Profile,
|
||||
activeConn :: Connection
|
||||
}
|
||||
| NewContact {activeConn :: Connection}
|
||||
data Contact = Contact
|
||||
{ contactId :: Int64,
|
||||
localContactRef :: ContactRef,
|
||||
profile :: Profile,
|
||||
activeConn :: Connection
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
contactConnId :: Contact -> ConnId
|
||||
contactConnId Contact {activeConn = Connection {agentConnId}} = agentConnId
|
||||
|
||||
type ContactRef = Text
|
||||
|
||||
type GroupRef = Text
|
||||
|
||||
data Group = Group
|
||||
{ groupId :: Int64,
|
||||
localGroupRef :: Text
|
||||
localGroupRef :: Text,
|
||||
groupProfile :: GroupProfile,
|
||||
members :: [(GroupMember, Connection)],
|
||||
membership :: GroupMember
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -66,6 +77,84 @@ instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOpt
|
||||
|
||||
instance FromJSON GroupProfile
|
||||
|
||||
data GroupMember = GroupMember
|
||||
{ groupMemberId :: Int64,
|
||||
memberId :: MemberId,
|
||||
memberRole :: GroupMemberRole,
|
||||
memberStatus :: GroupMemberStatus,
|
||||
invitedBy :: InvitedBy,
|
||||
memberProfile :: Profile,
|
||||
memberContactId :: Maybe Int64
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type MemberId = ByteString
|
||||
|
||||
data InvitedBy = IBContact Int64 | IBUser | IBUnknown
|
||||
deriving (Eq, Show)
|
||||
|
||||
toInvitedBy :: Int64 -> Maybe Int64 -> InvitedBy
|
||||
toInvitedBy userCtId (Just ctId)
|
||||
| userCtId == ctId = IBUser
|
||||
| otherwise = IBContact ctId
|
||||
toInvitedBy _ Nothing = IBUnknown
|
||||
|
||||
fromInvitedBy :: Int64 -> InvitedBy -> Maybe Int64
|
||||
fromInvitedBy userCtId = \case
|
||||
IBUnknown -> Nothing
|
||||
IBContact ctId -> Just ctId
|
||||
IBUser -> Just userCtId
|
||||
|
||||
data GroupMemberRole = GRMember | GRAdmin | GROwner
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField GroupMemberRole where fromField = fromBlobField_ toMemberRole
|
||||
|
||||
instance ToField GroupMemberRole where toField = toField . serializeMemberRole
|
||||
|
||||
toMemberRole :: ByteString -> Either String GroupMemberRole
|
||||
toMemberRole = \case
|
||||
"owner" -> Right GROwner
|
||||
"admin" -> Right GRAdmin
|
||||
"member" -> Right GRMember
|
||||
r -> Left $ "invalid group member role " <> B.unpack r
|
||||
|
||||
serializeMemberRole :: GroupMemberRole -> ByteString
|
||||
serializeMemberRole = \case
|
||||
GROwner -> "owner"
|
||||
GRAdmin -> "admin"
|
||||
GRMember -> "member"
|
||||
|
||||
fromBlobField_ :: Typeable k => (ByteString -> Either String k) -> FieldParser k
|
||||
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)
|
||||
f -> returnError ConversionFailed f "expecting SQLBlob column type"
|
||||
|
||||
data GroupMemberStatus = GSMemInvited | GSMemAccepted | GSMemConnected | GSMemReady
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromField GroupMemberStatus where fromField = fromTextField_ memberStatusT
|
||||
|
||||
instance ToField GroupMemberStatus where toField = toField . serializeMemberStatus
|
||||
|
||||
memberStatusT :: Text -> Maybe GroupMemberStatus
|
||||
memberStatusT = \case
|
||||
"invited" -> Just GSMemInvited
|
||||
"accepted" -> Just GSMemAccepted
|
||||
"connected" -> Just GSMemConnected
|
||||
"ready" -> Just GSMemReady
|
||||
_ -> Nothing
|
||||
|
||||
serializeMemberStatus :: GroupMemberStatus -> Text
|
||||
serializeMemberStatus = \case
|
||||
GSMemInvited -> "invited"
|
||||
GSMemAccepted -> "accepted"
|
||||
GSMemConnected -> "connected"
|
||||
GSMemReady -> "ready"
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
|
||||
@@ -1,6 +1,8 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.View
|
||||
@@ -12,6 +14,7 @@ module Simplex.Chat.View
|
||||
showContactDisconnected,
|
||||
showReceivedMessage,
|
||||
showSentMessage,
|
||||
showGroupCreated,
|
||||
safeDecodeUtf8,
|
||||
)
|
||||
where
|
||||
@@ -26,6 +29,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTime, localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, zonedTimeToLocalTime)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Store (StoreError (..))
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Terminal (printToTerminal)
|
||||
import Simplex.Chat.Types
|
||||
@@ -56,11 +60,14 @@ showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage
|
||||
showSentMessage :: ChatReader m => ContactRef -> ByteString -> m ()
|
||||
showSentMessage c msg = printToView =<< liftIO (sentMessage c msg)
|
||||
|
||||
showGroupCreated :: ChatReader m => GroupProfile -> m ()
|
||||
showGroupCreated = printToView . groupCreated
|
||||
|
||||
invitation :: SMPQueueInfo -> [StyledString]
|
||||
invitation qInfo =
|
||||
[ "pass this invitation to your contact (via another channel): ",
|
||||
"",
|
||||
(bPlain . serializeSmpQueueInfo) qInfo,
|
||||
(plain . serializeSmpQueueInfo) qInfo,
|
||||
"",
|
||||
"and ask them to connect: /c <name_for_you> <invitation_above>"
|
||||
]
|
||||
@@ -74,6 +81,9 @@ contactConnected c = [ttyContact c <> " is connected"]
|
||||
contactDisconnected :: ContactRef -> [StyledString]
|
||||
contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"]
|
||||
|
||||
groupCreated :: GroupProfile -> [StyledString]
|
||||
groupCreated GroupProfile {groupRef, displayName} = ["group " <> ttyGroup groupRef <> " (" <> plain displayName <> ") is created"]
|
||||
|
||||
receivedMessage :: ContactRef -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage c utcTime msg mOk = do
|
||||
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
|
||||
@@ -114,9 +124,11 @@ msgPlain = map styleMarkdownText . T.lines
|
||||
|
||||
chatError :: ChatError -> [StyledString]
|
||||
chatError = \case
|
||||
ChatErrorContact e -> case e of
|
||||
CENotFound c -> ["no contact " <> ttyContact c]
|
||||
CEProfile s -> ["invalid profile: " <> plain s]
|
||||
ChatErrorStore err -> case err of
|
||||
SEContactNotFound c -> ["no contact " <> ttyContact c]
|
||||
SEContactNotReady c -> ["contact " <> ttyContact c <> " is not active yet"]
|
||||
SEDuplicateGroupRef -> ["group with this alias already exists"]
|
||||
e -> ["chat db error: " <> plain (show e)]
|
||||
ChatErrorAgent err -> case err of
|
||||
-- CONN e -> case e of
|
||||
-- -- TODO replace with ChatErrorContact errors, these errors should never happen
|
||||
@@ -138,8 +150,8 @@ ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " "
|
||||
ttyFromContact :: ContactRef -> StyledString
|
||||
ttyFromContact c = styled (Colored Yellow) $ c <> "> "
|
||||
|
||||
-- ttyGroup :: Group -> StyledString
|
||||
-- ttyGroup (Group g) = styled (Colored Blue) $ "#" <> g
|
||||
ttyGroup :: GroupRef -> StyledString
|
||||
ttyGroup g = styled (Colored Blue) $ "#" <> g
|
||||
|
||||
-- ttyFromGroup :: Group -> Contact -> StyledString
|
||||
-- ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> "
|
||||
|
||||
@@ -69,13 +69,15 @@ refMsgHash = 16*16(OCTET) ; SHA256 of agent message body
|
||||
|
||||
### Group protocol
|
||||
|
||||
A -> B: invite to group - `MSG: x.grp.inv G_INV_ID,G_MEM_ID_B,G_MEM_ROLE x.json:NNN <group_profile>`
|
||||
#### Add group member
|
||||
|
||||
A -> B: invite to group - `MSG: x.grp.inv G_MEM_ID_A,G_MEM_ROLE_A,G_MEM_ID_B,G_MEM_ROLE_B,<invitation> x.json:NNN <group_profile>`
|
||||
user B confirms
|
||||
B -> A: join group - `MSG: x.grp.acpt G_INV_ID,<invitation>`
|
||||
A -> Bg: establish group connection (A: JOIN, B: LET)
|
||||
A -> group (including B)): announce group member: `MSG: N x.grp.mem.new G_MEM_ID_B,G_MEM_ROLE x.json:NNN <B_profile>`
|
||||
B -> A: establish group connection (B: JOIN, A: LET)
|
||||
B -> Ag: join group - `in SMP confirmation: x.grp.acpt G_MEM_ID_B`
|
||||
A -> group (including B)): announce group member: `MSG: N x.grp.mem.new G_MEM_ID_B,G_MEM_ROLE_B x.json:NNN <B_profile>`
|
||||
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 x.json:NNN <M_profile>`
|
||||
A -> Bg: intro member - `MSG: x.grp.mem.intro G_MEM_ID_M,G_MEM_ROLE_M x.json:NNN <M_profile>`
|
||||
B -> Ag: inv for mem - `MSG: x.grp.mem.inv G_MEM_ID_M,<gr_invitation>,<dm_invitation>,<probe>`
|
||||
M is an existing member, messages are via group connection
|
||||
A -> Mg: fwd inv - `MSG: x.grp.mem.fwd G_MEM_ID_B,<gr_invitation>,<dm_invitation>,<probe>`
|
||||
@@ -91,3 +93,7 @@ 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`
|
||||
|
||||
#### Send group message
|
||||
|
||||
`MSG: N x.msg.new G_MEM_ROLE,<invitation> x.json:NNN <group_profile>`
|
||||
|
||||
Reference in New Issue
Block a user