android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-28 20:29:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

chat items (#223)

Browse source 
* add chat items migration

* chat and chat items types

* queries draft

* ChatInfo with optional ChatItem

* schema adjustments

* flat schema and queries

* refactor ChatResponse using ChatItem types

* schema adjustments

* refactor GroupInfo to include GroupMember of the user

* remove Message

* createNewChatItem, sendDirectChatItem

* refactor to use GroupInfo in Chat type and all ChatResponses

* replace ContactName with Contact in some ChatResponse constructors

* remove Group selectors

* minor correction

* refactor

* refactor 2

* nullable created_by_msg_id

* remove normalized schema and queries

* ON DELETE CASCADE / SET NULL

* CIContent to Text

* files chat_item_id

* fix

* apply ciContentToText

* queries folder

* refactor

* moar refactor

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Efim Poberezkin 2022-01-26 16:18:27 +04:00 • committed by GitHub
parent b86f034c0b
commit 6cf23f1fd1
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
15 changed files with 1065 additions and 484 deletions
Download patch file Download diff file Expand all files Collapse all files

1
simplex-chat.cabal
View file

@ -26,6 +26,7 @@ library
Simplex.Chat.Messages
Simplex.Chat.Migrations.M20220101_initial
Simplex.Chat.Migrations.M20220122_pending_group_messages
Simplex.Chat.Migrations.M20220125_chat_items
Simplex.Chat.Mobile
Simplex.Chat.Options
Simplex.Chat.Protocol

425
src/Simplex/Chat.hs
View file

@ -31,11 +31,11 @@ import Data.Int (Int64)
import Data.List (find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (isJust, mapMaybe)
import Data.Maybe (fromJust, isJust, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.LocalTime (utcToLocalZonedTime)
import Data.Word (Word32)
import Simplex.Chat.Controller
@ -179,25 +179,26 @@ processChatCommand user@User {userId, profile} = \case
pure $ CRContactRequestRejected cName
SendMessage cName msg -> do
contact <- withStore $ \st -> getContact st userId cName
let msgContent = MCText $ safeDecodeUtf8 msg
meta <- liftIO . mkChatMsgMeta =<< sendDirectMessage (contactConn contact) (XMsgNew msgContent)
let mc = MCText $ safeDecodeUtf8 msg
ci <- sendDirectChatItem userId contact (XMsgNew mc) (CIMsgContent mc)
setActive $ ActiveC cName
pure $ CRSentMessage cName msgContent meta
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci
NewGroup gProfile -> do
gVar <- asks idsDrg
CRGroupCreated <$> withStore (\st -> createNewGroup st gVar user gProfile)
AddMember gName cName memRole -> do
-- TODO for large groups: no need to load all members to determine if contact is a member
(group, contact) <- withStore $ \st -> (,) <$> getGroup st user gName <*> getContact st userId cName
let Group {groupId, groupProfile, membership, members} = group
let Group gInfo@GroupInfo {groupId, groupProfile, membership} members = group
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
when (userRole < GRAdmin || userRole < memRole) $ chatError CEGroupUserRole
when (memberStatus membership == GSMemInvited) $ chatError (CEGroupNotJoined gName)
when (memberStatus membership == GSMemInvited) $ chatError (CEGroupNotJoined gInfo)
unless (memberActive membership) $ chatError CEGroupMemberNotActive
let sendInvitation memberId cReq = do
void . sendDirectMessage (contactConn contact) $
XGrpInv $ GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
setActive $ ActiveG gName
pure $ CRSentGroupInvitation gName cName
pure $ CRSentGroupInvitation gInfo contact
case contactMember contact members of
Nothing -> do
gVar <- asks idsDrg
@ -208,20 +209,20 @@ processChatCommand user@User {userId, profile} = \case
| memberStatus == GSMemInvited ->
withStore (\st -> getMemberInvitation st user groupMemberId) >>= \case
Just cReq -> sendInvitation memberId cReq
Nothing -> chatError $ CEGroupCantResendInvitation gName cName
Nothing -> chatError $ CEGroupCantResendInvitation gInfo cName
| otherwise -> chatError $ CEGroupDuplicateMember cName
JoinGroup gName -> do
ReceivedGroupInvitation {fromMember, userMember, connRequest} <- withStore $ \st -> getGroupInvitation st user gName
ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g} <- withStore $ \st -> getGroupInvitation st user gName
procCmd $ do
agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (userMember :: GroupMember)
agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (membership g :: GroupMember)
withStore $ \st -> do
createMemberConnection st userId fromMember agentConnId
updateGroupMemberStatus st userId fromMember GSMemAccepted
updateGroupMemberStatus st userId userMember GSMemAccepted
pure $ CRUserAcceptedGroupSent gName
updateGroupMemberStatus st userId (membership g) GSMemAccepted
pure $ CRUserAcceptedGroupSent g
MemberRole _gName _cName _mRole -> chatError $ CECommandError "unsupported"
RemoveMember gName cName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroup st user gName
case find ((== cName) . (localDisplayName :: GroupMember -> ContactName)) members of
Nothing -> chatError $ CEGroupMemberNotFound cName
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do
@ -231,16 +232,16 @@ processChatCommand user@User {userId, profile} = \case
when (mStatus /= GSMemInvited) . void . sendGroupMessage members $ XGrpMemDel mId
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved
pure $ CRUserDeletedMember gName m
pure $ CRUserDeletedMember gInfo m
LeaveGroup gName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroup st user gName
procCmd $ do
void $ sendGroupMessage members XGrpLeave
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft
pure $ CRLeftMemberUser gName
pure $ CRLeftMemberUser gInfo
DeleteGroup gName -> do
g@Group {membership, members} <- withStore $ \st -> getGroup st user gName
g@(Group gInfo@GroupInfo {membership} members) <- withStore $ \st -> getGroup st user gName
let s = memberStatus membership
canDelete =
memberRole (membership :: GroupMember) == GROwner
@ -250,17 +251,16 @@ processChatCommand user@User {userId, profile} = \case
when (memberActive membership) . void $ sendGroupMessage members XGrpDel
mapM_ deleteMemberConnection members
withStore $ \st -> deleteGroup st user g
pure $ CRGroupDeletedUser gName
pure $ CRGroupDeletedUser gInfo
ListMembers gName -> CRGroupMembers <$> withStore (\st -> getGroup st user gName)
ListGroups -> CRGroupsList <$> withStore (`getUserGroupDetails` userId)
ListGroups -> CRGroupsList <$> withStore (`getUserGroupDetails` user)
SendGroupMessage gName msg -> do
-- TODO save pending message delivery for members without connections
Group {members, membership} <- withStore $ \st -> getGroup st user gName
group@(Group gInfo@GroupInfo {membership} _) <- withStore $ \st -> getGroup st user gName
unless (memberActive membership) $ chatError CEGroupMemberUserRemoved
let msgContent = MCText $ safeDecodeUtf8 msg
meta <- liftIO . mkChatMsgMeta =<< sendGroupMessage members (XMsgNew msgContent)
let mc = MCText $ safeDecodeUtf8 msg
ci <- sendGroupChatItem userId group (XMsgNew mc) (CIMsgContent mc)
setActive $ ActiveG gName
pure $ CRSentGroupMessage gName msgContent meta
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
SendFile cName f -> do
(fileSize, chSize) <- checkSndFile f
contact <- withStore $ \st -> getContact st userId cName
@ -268,27 +268,28 @@ processChatCommand user@User {userId, profile} = \case
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq}
SndFileTransfer {fileId} <- withStore $ \st ->
createSndFileTransfer st userId contact f fileInv agentConnId chSize
meta <- liftIO . mkChatMsgMeta =<< sendDirectMessage (contactConn contact) (XFile fileInv)
ci <- sendDirectChatItem userId contact (XFile fileInv) (CISndFileInvitation fileId f)
withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci
setActive $ ActiveC cName
pure $ CRSentFileInvitation cName fileId f meta
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci
SendGroupFile gName f -> do
(fileSize, chSize) <- checkSndFile f
group@Group {members, membership} <- withStore $ \st -> getGroup st user gName
Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroup st user gName
unless (memberActive membership) $ chatError CEGroupMemberUserRemoved
let fileName = takeFileName f
ms <- forM (filter memberActive members) $ \m -> do
(connId, fileConnReq) <- withAgent (`createConnection` SCMInvitation)
pure (m, connId, FileInvitation {fileName, fileSize, fileConnReq})
fileId <- withStore $ \st -> createSndGroupFileTransfer st userId group ms f fileSize chSize
-- TODO sendGroupMessage - same file invitation to all
fileId <- withStore $ \st -> createSndGroupFileTransfer st userId gInfo ms f fileSize chSize
-- TODO sendGroupChatItem - same file invitation to all
forM_ ms $ \(m, _, fileInv) ->
traverse (`sendDirectMessage` XFile fileInv) $ memberConn m
setActive $ ActiveG gName
-- this is a hack as we have multiple direct messages instead of one per group
chatTs <- liftIO getCurrentTime
localChatTs <- liftIO $ utcToLocalZonedTime chatTs
let meta = ChatMsgMeta {msgId = 0, chatTs, localChatTs, createdAt = chatTs}
pure $ CRSentGroupFileInvitation gName fileId f meta
let ciContent = CISndFileInvitation fileId f
ciMeta@CIMetaProps{itemId} <- saveChatItem userId (CDSndGroup gInfo) Nothing ciContent
withStore $ \st -> updateFileTransferChatItemId st fileId itemId
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) $ SndGroupChatItem (CISndMeta ciMeta) ciContent
ReceiveFile fileId filePath_ -> do
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
unless (fileStatus == RFSNew) . chatError $ CEFileAlreadyReceiving fileName
@ -329,15 +330,15 @@ processChatCommand user@User {userId, profile} = \case
procCmd :: m ChatResponse -> m ChatResponse
procCmd a = do
a
-- ! below code would make command responses asynchronous where they can be slow
-- ! in View.hs `r'` should be defined as `id` in this case
-- gVar <- asks idsDrg
-- corrId <- liftIO $ CorrId <$> randomBytes gVar 8
-- q <- asks outputQ
-- void . forkIO $ atomically . writeTBQueue q =<<
-- (corrId,) <$> (a `catchError` (pure . CRChatError))
-- pure $ CRCommandAccepted corrId
-- a corrId
-- ! below code would make command responses asynchronous where they can be slow
-- ! in View.hs `r'` should be defined as `id` in this case
-- gVar <- asks idsDrg
-- corrId <- liftIO $ CorrId <$> randomBytes gVar 8
-- q <- asks outputQ
-- void . forkIO $ atomically . writeTBQueue q =<<
-- (corrId,) <$> (a `catchError` (pure . CRChatError))
-- pure $ CRCommandAccepted corrId
-- a corrId
connect :: ConnectionRequestUri c -> ChatMsgEvent -> m ()
connect cReq msg = do
connId <- withAgent $ \a -> joinConnection a cReq $ directMessage msg
@ -382,11 +383,6 @@ processChatCommand user@User {userId, profile} = \case
f = filePath `combine` (name <> suffix <> ext)
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
mkChatMsgMeta :: Message -> IO ChatMsgMeta
mkChatMsgMeta Message {msgId, chatTs, createdAt} = do
localChatTs <- utcToLocalZonedTime chatTs
pure ChatMsgMeta {msgId, chatTs, localChatTs, createdAt}
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
agentSubscriber = do
q <- asks $ subQ . smpAgent
@ -409,11 +405,11 @@ subscribeUserConnections = void . runExceptT $ do
where
subscribeContacts user = do
contacts <- withStore (`getUserContacts` user)
forM_ contacts $ \ct@Contact {localDisplayName = c} ->
(subscribe (contactConnId ct) >> toView (CRContactSubscribed c)) `catchError` (toView . CRContactSubError c)
forM_ contacts $ \ct ->
(subscribe (contactConnId ct) >> toView (CRContactSubscribed ct)) `catchError` (toView . CRContactSubError ct)
subscribeGroups user = do
groups <- withStore (`getUserGroups` user)
forM_ groups $ \g@Group {members, membership, localDisplayName = gn} -> do
forM_ groups $ \(Group g@GroupInfo {membership} members) -> do
let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members
if memberStatus membership == GSMemInvited
then toView $ CRGroupInvitation g
@ -425,14 +421,14 @@ subscribeUserConnections = void . runExceptT $ do
else toView $ CRGroupRemoved g
else do
forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
subscribe cId `catchError` (toView . CRMemberSubError gn c)
subscribe cId `catchError` (toView . CRMemberSubError g c)
toView $ CRGroupSubscribed g
subscribeFiles user = do
withStore (`getLiveSndFileTransfers` user) >>= mapM_ subscribeSndFile
withStore (`getLiveRcvFileTransfers` user) >>= mapM_ subscribeRcvFile
where
subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId} = do
subscribe agentConnId `catchError` (toView . CRSndFileSubError ft)
subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId cId} = do
subscribe cId `catchError` (toView . CRSndFileSubError ft)
void . forkIO $ do
threadDelay 1000000
l <- asks chatLock
@ -446,8 +442,8 @@ subscribeUserConnections = void . runExceptT $ do
RFSConnected fInfo -> resume fInfo
_ -> pure ()
where
resume RcvFileInfo {agentConnId} =
subscribe agentConnId `catchError` (toView . CRRcvFileSubError ft)
resume RcvFileInfo {agentConnId = AgentConnId cId} =
subscribe cId `catchError` (toView . CRRcvFileSubError ft)
subscribePendingConnections user = do
cs <- withStore (`getPendingConnections` user)
subscribeConns cs `catchError` \_ -> pure ()
@ -463,14 +459,14 @@ subscribeUserConnections = void . runExceptT $ do
processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m ()
processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId
acEntity <- withStore $ \st -> getConnectionEntity st user agentConnId
forM_ (agentMsgConnStatus agentMessage) $ \status ->
withStore $ \st -> updateConnectionStatus st (fromConnection chatDirection) status
case chatDirection of
ReceivedDirectMessage conn maybeContact ->
processDirectMessage agentMessage conn maybeContact
ReceivedGroupMessage conn gName m ->
processGroupMessage agentMessage conn gName m
withStore $ \st -> updateConnectionStatus st (fromConnection acEntity) status
case acEntity of
RcvDirectMsgConnection conn contact_ ->
processDirectMessage agentMessage conn contact_
RcvGroupMsgConnection conn gInfo m ->
processGroupMessage agentMessage conn gInfo m
RcvFileConnection conn ft ->
processRcvFileConn agentMessage conn ft
SndFileConnection conn ft ->
@ -478,8 +474,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
UserContactConnection conn uc ->
processUserContactRequest agentMessage conn uc
where
isMember :: MemberId -> Group -> Bool
isMember memId Group {membership, members} =
isMember :: MemberId -> GroupInfo -> [GroupMember] -> Bool
isMember memId GroupInfo {membership} members =
sameMemberId memId membership || isJust (find (sameMemberId memId) members)
contactIsReady :: Contact -> Bool
@ -515,19 +511,19 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO add debugging output
_ -> pure ()
Just ct@Contact {localDisplayName = c} -> case agentMsg of
MSG meta msgBody -> do
(chatMsgEvent, msg) <- saveRcvMSG conn meta msgBody
withAckMessage agentConnId meta $
MSG msgMeta msgBody -> do
(msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody
withAckMessage agentConnId msgMeta $
case chatMsgEvent of
XMsgNew mc -> newContentMessage c msg mc meta
XFile fInv -> processFileInvitation ct msg fInv meta
XMsgNew mc -> newContentMessage ct mc msgId msgMeta
XFile fInv -> processFileInvitation ct fInv msgId msgMeta
XInfo p -> xInfo ct p
XGrpInv gInv -> processGroupInvitation ct gInv
XInfoProbe probe -> xInfoProbe ct probe
XInfoProbeCheck probeHash -> xInfoProbeCheck ct probeHash
XInfoProbeOk probe -> xInfoProbeOk ct probe
_ -> pure ()
ackMsgDeliveryEvent conn meta
ackMsgDeliveryEvent conn msgMeta
CONF confId connInfo -> do
-- confirming direct connection with a member
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
@ -555,21 +551,21 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
toView $ CRContactConnected ct
setActive $ ActiveC c
showToast (c <> "> ") "connected"
Just (gName, m) ->
Just (gInfo, m) -> do
when (memberIsReady m) $ do
notifyMemberConnected gName m
notifyMemberConnected gInfo m
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct
SENT msgId ->
sentMsgDeliveryEvent conn msgId
END -> do
toView $ CRContactAnotherClient c
toView $ CRContactAnotherClient ct
showToast (c <> "> ") "connected to another client"
unsetActive $ ActiveC c
DOWN -> do
toView $ CRContactDisconnected c
toView $ CRContactDisconnected ct
showToast (c <> "> ") "disconnected"
UP -> do
toView $ CRContactSubscribed c
toView $ CRContactSubscribed ct
showToast (c <> "> ") "is active"
setActive $ ActiveC c
-- TODO print errors
@ -578,8 +574,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO add debugging output
_ -> pure ()
processGroupMessage :: ACommand 'Agent -> Connection -> GroupName -> GroupMember -> m ()
processGroupMessage agentMsg conn gName m = case agentMsg of
processGroupMessage :: ACommand 'Agent -> Connection -> GroupInfo -> GroupMember -> m ()
processGroupMessage agentMsg conn gInfo@GroupInfo {localDisplayName = gName, membership} m = case agentMsg of
CONF confId connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case memberCategory m of
@ -596,7 +592,6 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
XGrpMemInfo memId _memProfile
| sameMemberId memId m -> do
-- TODO update member profile
Group {membership} <- withStore $ \st -> getGroup st user gName
allowAgentConnection conn confId $ XGrpMemInfo (memberId (membership :: GroupMember)) profile
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
_ -> messageError "CONF from member must have x.grp.mem.info"
@ -612,7 +607,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
_ -> messageError "INFO from member must have x.grp.mem.info"
pure ()
CON -> do
group@Group {members, membership} <- withStore $ \st -> getGroup st user gName
members <- withStore $ \st -> getGroupMembers st user gInfo
withStore $ \st -> do
updateGroupMemberStatus st userId m GSMemConnected
unless (memberActive membership) $
@ -620,14 +615,14 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
sendPendingGroupMessages m conn
case memberCategory m of
GCHostMember -> do
toView $ CRUserJoinedGroup gName
toView $ CRUserJoinedGroup gInfo
setActive $ ActiveG gName
showToast ("#" <> gName) "you are connected to group"
GCInviteeMember -> do
toView $ CRJoinedGroupMember gName m
toView $ CRJoinedGroupMember gInfo m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
intros <- withStore $ \st -> createIntroductions st group m
intros <- withStore $ \st -> createIntroductions st members m
void . sendGroupMessage members . XGrpMemNew $ memberInfo m
forM_ intros $ \intro@GroupMemberIntro {introId} -> do
void . sendDirectMessage conn . XGrpMemIntro . memberInfo $ reMember intro
@ -637,27 +632,27 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO notify member who forwarded introduction - question - where it is stored? There is via_contact but probably there should be via_member in group_members table
withStore (\st -> getViaGroupContact st user m) >>= \case
Nothing -> do
notifyMemberConnected gName m
notifyMemberConnected gInfo m
messageError "implementation error: connected member does not have contact"
Just ct ->
when (contactIsReady ct) $ do
notifyMemberConnected gName m
notifyMemberConnected gInfo m
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct
MSG meta msgBody -> do
(chatMsgEvent, msg) <- saveRcvMSG conn meta msgBody
withAckMessage agentConnId meta $
MSG msgMeta msgBody -> do
(msgId, chatMsgEvent) <- saveRcvMSG conn msgMeta msgBody
withAckMessage agentConnId msgMeta $
case chatMsgEvent of
XMsgNew mc -> newGroupContentMessage gName m msg mc meta
XFile fInv -> processGroupFileInvitation gName m msg fInv meta
XGrpMemNew memInfo -> xGrpMemNew gName m memInfo
XGrpMemIntro memInfo -> xGrpMemIntro conn gName m memInfo
XGrpMemInv memId introInv -> xGrpMemInv gName m memId introInv
XGrpMemFwd memInfo introInv -> xGrpMemFwd gName m memInfo introInv
XGrpMemDel memId -> xGrpMemDel gName m memId
XGrpLeave -> xGrpLeave gName m
XGrpDel -> xGrpDel gName m
XMsgNew mc -> newGroupContentMessage gInfo m mc msgId msgMeta
XFile fInv -> processGroupFileInvitation gInfo m fInv msgId msgMeta
XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo
XGrpMemIntro memInfo -> xGrpMemIntro conn gInfo m memInfo
XGrpMemInv memId introInv -> xGrpMemInv gInfo m memId introInv
XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m memInfo introInv
XGrpMemDel memId -> xGrpMemDel gInfo m memId
XGrpLeave -> xGrpLeave gInfo m
XGrpDel -> xGrpDel gInfo m
_ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent)
ackMsgDeliveryEvent conn meta
ackMsgDeliveryEvent conn msgMeta
SENT msgId ->
sentMsgDeliveryEvent conn msgId
-- TODO print errors
@ -780,11 +775,12 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
cancelRcvFileTransfer ft
chatError $ CEFileRcvChunk err
notifyMemberConnected :: GroupName -> GroupMember -> m ()
notifyMemberConnected gName m@GroupMember {localDisplayName} = do
toView $ CRConnectedToGroupMember gName m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName <> " is connected"
notifyMemberConnected :: GroupInfo -> GroupMember -> m ()
notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} = do
toView $ CRConnectedToGroupMember gInfo m
let g = groupName gInfo
setActive $ ActiveG g
showToast ("#" <> g) $ "member " <> c <> " is connected"
probeMatchingContacts :: Contact -> m ()
probeMatchingContacts ct = do
@ -806,45 +802,49 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
messageError :: Text -> m ()
messageError = toView . CRMessageError "error"
newContentMessage :: ContactName -> Message -> MsgContent -> MsgMeta -> m ()
newContentMessage c msg mc MsgMeta {integrity} = do
meta <- liftIO $ mkChatMsgMeta msg
toView $ CRReceivedMessage c meta mc integrity
newContentMessage :: Contact -> MsgContent -> MessageId -> MsgMeta -> m ()
newContentMessage ct@Contact {localDisplayName = c} mc msgId msgMeta = do
ci <- saveRcvDirectChatItem userId ct msgId msgMeta (CIMsgContent mc)
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
showToast (c <> "> ") $ msgContentText mc
setActive $ ActiveC c
newGroupContentMessage :: GroupName -> GroupMember -> Message -> MsgContent -> MsgMeta -> m ()
newGroupContentMessage gName GroupMember {localDisplayName = c} msg mc MsgMeta {integrity} = do
meta <- liftIO $ mkChatMsgMeta msg
toView $ CRReceivedGroupMessage gName c meta mc integrity
showToast ("#" <> gName <> " " <> c <> "> ") $ msgContentText mc
setActive $ ActiveG gName
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContent -> MessageId -> MsgMeta -> m ()
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msgId msgMeta = do
ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIMsgContent mc)
toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
let g = groupName gInfo
showToast ("#" <> g <> " " <> c <> "> ") $ msgContentText mc
setActive $ ActiveG g
processFileInvitation :: Contact -> Message -> FileInvitation -> MsgMeta -> m ()
processFileInvitation contact@Contact {localDisplayName = c} msg fInv MsgMeta {integrity} = do
processFileInvitation :: Contact -> FileInvitation -> MessageId -> MsgMeta -> m ()
processFileInvitation ct@Contact {localDisplayName = c} fInv msgId msgMeta = do
-- TODO chunk size has to be sent as part of invitation
chSize <- asks $ fileChunkSize . config
ft <- withStore $ \st -> createRcvFileTransfer st userId contact fInv chSize
meta <- liftIO $ mkChatMsgMeta msg
toView $ CRReceivedFileInvitation c meta ft integrity
ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvFileTransfer st userId ct fInv chSize
ci <- saveRcvDirectChatItem userId ct msgId msgMeta (CIRcvFileInvitation ft)
withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
showToast (c <> "> ") "wants to send a file"
setActive $ ActiveC c
processGroupFileInvitation :: GroupName -> GroupMember -> Message -> FileInvitation -> MsgMeta -> m ()
processGroupFileInvitation gName m@GroupMember {localDisplayName = c} msg fInv MsgMeta {integrity} = do
processGroupFileInvitation :: GroupInfo -> GroupMember -> FileInvitation -> MessageId -> MsgMeta -> m ()
processGroupFileInvitation gInfo m@GroupMember {localDisplayName = c} fInv msgId msgMeta = do
chSize <- asks $ fileChunkSize . config
ft <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize
meta <- liftIO $ mkChatMsgMeta msg
toView $ CRReceivedGroupFileInvitation gName c meta ft integrity
showToast ("#" <> gName <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG gName
ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize
ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIRcvFileInvitation ft)
withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci
toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
let g = groupName gInfo
showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG g
processGroupInvitation :: Contact -> GroupInvitation -> m ()
processGroupInvitation ct@Contact {localDisplayName = c} inv@(GroupInvitation (MemberIdRole fromMemId fromRole) (MemberIdRole memId memRole) _ _) = do
when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole c)
when (fromMemId == memId) $ chatError CEGroupDuplicateMemberId
group@Group {localDisplayName = gName} <- withStore $ \st -> createGroupInvitation st user ct inv
toView $ CRReceivedGroupInvitation group c memRole
gInfo@GroupInfo {localDisplayName = gName} <- withStore $ \st -> createGroupInvitation st user ct inv
toView $ CRReceivedGroupInvitation gInfo ct memRole
showToast ("#" <> gName <> " " <> c <> "> ") "invited you to join the group"
xInfo :: Contact -> Profile -> m ()
@ -887,53 +887,53 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
-- TODO show/log error, other events in SMP confirmation
_ -> pure ()
xGrpMemNew :: GroupName -> GroupMember -> MemberInfo -> m ()
xGrpMemNew gName m memInfo@(MemberInfo memId _ _) = do
group@Group {membership} <- withStore $ \st -> getGroup st user gName
unless (sameMemberId memId membership) $
if isMember memId group
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> m ()
xGrpMemNew gInfo m memInfo@(MemberInfo memId _ _) = do
members <- withStore $ \st -> getGroupMembers st user gInfo
unless (sameMemberId memId $ membership gInfo) $
if isMember memId gInfo members
then messageError "x.grp.mem.new error: member already exists"
else do
newMember <- withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced
toView $ CRJoinedGroupMemberConnecting gName m newMember
newMember <- withStore $ \st -> createNewGroupMember st user gInfo memInfo GCPostMember GSMemAnnounced
toView $ CRJoinedGroupMemberConnecting gInfo m newMember
xGrpMemIntro :: Connection -> GroupName -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro conn gName m memInfo@(MemberInfo memId _ _) =
xGrpMemIntro :: Connection -> GroupInfo -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro conn gInfo m memInfo@(MemberInfo memId _ _) = do
case memberCategory m of
GCHostMember -> do
group <- withStore $ \st -> getGroup st user gName
if isMember memId group
members <- withStore $ \st -> getGroupMembers st user gInfo
if isMember memId gInfo members
then messageWarning "x.grp.mem.intro ignored: member already exists"
else do
(groupConnId, groupConnReq) <- withAgent (`createConnection` SCMInvitation)
(directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation)
newMember <- withStore $ \st -> createIntroReMember st user group m memInfo groupConnId directConnId
newMember <- withStore $ \st -> createIntroReMember st user gInfo m memInfo groupConnId directConnId
let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq}
void $ sendDirectMessage conn msg
withStore $ \st -> updateGroupMemberStatus st userId newMember GSMemIntroInvited
_ -> messageError "x.grp.mem.intro can be only sent by host member"
xGrpMemInv :: GroupName -> GroupMember -> MemberId -> IntroInvitation -> m ()
xGrpMemInv gName m memId introInv =
xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> m ()
xGrpMemInv gInfo m memId introInv = do
case memberCategory m of
GCInviteeMember -> do
group <- withStore $ \st -> getGroup st user gName
case find (sameMemberId memId) $ members group of
members <- withStore $ \st -> getGroupMembers st user gInfo
case find (sameMemberId memId) members of
Nothing -> messageError "x.grp.mem.inv error: referenced member does not exists"
Just reMember -> do
GroupMemberIntro {introId} <- withStore $ \st -> saveIntroInvitation st reMember m introInv
void $ sendXGrpMemInv reMember (XGrpMemFwd (memberInfo m) introInv) introId
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
xGrpMemFwd :: GroupName -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
xGrpMemFwd gName m memInfo@(MemberInfo memId _ _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
group@Group {membership} <- withStore $ \st -> getGroup st user gName
toMember <- case find (sameMemberId memId) $ members group of
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
xGrpMemFwd gInfo@GroupInfo {membership} m memInfo@(MemberInfo memId _ _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
members <- withStore $ \st -> getGroupMembers st user gInfo
toMember <- case find (sameMemberId memId) members of
-- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
-- the situation when member does not exist is an error
-- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
-- For now, this branch compensates for the lack of delayed message delivery.
Nothing -> withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced
Nothing -> withStore $ \st -> createNewGroupMember st user gInfo memInfo GCPostMember GSMemAnnounced
Just m' -> pure m'
withStore $ \st -> saveMemberInvitation st toMember introInv
let msg = XGrpMemInfo (memberId (membership :: GroupMember)) profile
@ -941,14 +941,14 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
directConnId <- withAgent $ \a -> joinConnection a directConnReq $ directMessage msg
withStore $ \st -> createIntroToMemberContact st userId m toMember groupConnId directConnId
xGrpMemDel :: GroupName -> GroupMember -> MemberId -> m ()
xGrpMemDel gName m memId = do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> m ()
xGrpMemDel gInfo@GroupInfo {membership} m memId = do
members <- withStore $ \st -> getGroupMembers st user gInfo
if memberId (membership :: GroupMember) == memId
then do
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved
toView $ CRDeletedMemberUser gName m
toView $ CRDeletedMemberUser gInfo m
else case find (sameMemberId memId) members of
Nothing -> messageError "x.grp.mem.del with unknown member ID"
Just member -> do
@ -958,32 +958,32 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
else do
deleteMemberConnection member
withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved
toView $ CRDeletedMember gName m member
toView $ CRDeletedMember gInfo m member
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
xGrpLeave :: GroupName -> GroupMember -> m ()
xGrpLeave gName m = do
xGrpLeave :: GroupInfo -> GroupMember -> m ()
xGrpLeave gInfo m = do
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemLeft
toView $ CRLeftMember gName m
toView $ CRLeftMember gInfo m
xGrpDel :: GroupName -> GroupMember -> m ()
xGrpDel gName m@GroupMember {memberRole} = do
xGrpDel :: GroupInfo -> GroupMember -> m ()
xGrpDel gInfo m@GroupMember {memberRole} = do
when (memberRole /= GROwner) $ chatError CEGroupUserRole
ms <- withStore $ \st -> do
Group {members, membership} <- getGroup st user gName
updateGroupMemberStatus st userId membership GSMemGroupDeleted
members <- getGroupMembers st user gInfo
updateGroupMemberStatus st userId (membership gInfo) GSMemGroupDeleted
pure members
mapM_ deleteMemberConnection ms
toView $ CRGroupDeleted gName m
toView $ CRGroupDeleted gInfo m
parseChatMessage :: ByteString -> Either ChatError ChatMessage
parseChatMessage = first ChatErrorMessage . strDecode
sendFileChunk :: ChatMonad m => SndFileTransfer -> m ()
sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} =
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
withStore (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo
@ -993,12 +993,12 @@ sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
deleteSndFileChunks st ft
toView $ CRSndFileComplete ft
closeFileHandle fileId sndFiles
withAgent (`deleteConnection` agentConnId)
withAgent (`deleteConnection` acId)
sendFileChunkNo :: ChatMonad m => SndFileTransfer -> Integer -> m ()
sendFileChunkNo ft@SndFileTransfer {agentConnId} chunkNo = do
sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do
chunkBytes <- readFileChunk ft chunkNo
msgId <- withAgent $ \a -> sendMessage a agentConnId $ smpEncode FileChunk {chunkNo, chunkBytes}
msgId <- withAgent $ \a -> sendMessage a acId $ smpEncode FileChunk {chunkNo, chunkBytes}
withStore $ \st -> updateSndFileChunkMsg st ft chunkNo msgId
readFileChunk :: ChatMonad m => SndFileTransfer -> Integer -> m ByteString
@ -1068,19 +1068,19 @@ cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do
updateRcvFileStatus st ft FSCancelled
deleteRcvFileChunks st ft
case fileStatus of
RFSAccepted RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId)
RFSConnected RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId)
RFSAccepted RcvFileInfo {agentConnId = AgentConnId acId} -> withAgent (`suspendConnection` acId)
RFSConnected RcvFileInfo {agentConnId = AgentConnId acId} -> withAgent (`suspendConnection` acId)
_ -> pure ()
cancelSndFileTransfer :: ChatMonad m => SndFileTransfer -> m ()
cancelSndFileTransfer ft@SndFileTransfer {agentConnId, fileStatus} =
cancelSndFileTransfer ft@SndFileTransfer {agentConnId = AgentConnId acId, fileStatus} =
unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do
withStore $ \st -> do
updateSndFileStatus st ft FSCancelled
deleteSndFileChunks st ft
withAgent $ \a -> do
void (sendMessage a agentConnId $ smpEncode FileChunkCancel) `catchError` \_ -> pure ()
suspendConnection a agentConnId
void (sendMessage a acId $ smpEncode FileChunkCancel) `catchError` \_ -> pure ()
suspendConnection a acId
closeFileHandle :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> m ()
closeFileHandle fileId files = do
@ -1098,18 +1098,18 @@ deleteMemberConnection m@GroupMember {activeConn} = do
-- withStore $ \st -> deleteGroupMemberConnection st userId m
forM_ activeConn $ \conn -> withStore $ \st -> updateConnectionStatus st conn ConnDeleted
sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> m Message
sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> m MessageId
sendDirectMessage conn chatMsgEvent = do
msg@Message {msgId, msgBody} <- createSndMessage chatMsgEvent
(msgId, msgBody) <- createSndMessage chatMsgEvent
deliverMessage conn msgBody msgId
pure msg
pure msgId
createSndMessage :: ChatMonad m => ChatMsgEvent -> m Message
createSndMessage :: ChatMonad m => ChatMsgEvent -> m (MessageId, MsgBody)
createSndMessage chatMsgEvent = do
chatTs <- liftIO getCurrentTime
let msgBody = directMessage chatMsgEvent
newMsg = NewMessage {direction = MDSnd, cmEventTag = toCMEventTag chatMsgEvent, msgBody, chatTs}
withStore $ \st -> createNewMessage st newMsg
newMsg = NewMessage {direction = MDSnd, cmEventTag = toCMEventTag chatMsgEvent, msgBody}
msgId <- withStore $ \st -> createNewMessage st newMsg
pure (msgId, msgBody)
directMessage :: ChatMsgEvent -> ByteString
directMessage chatMsgEvent = strEncode ChatMessage {chatMsgEvent}
@ -1120,23 +1120,23 @@ deliverMessage Connection {connId, agentConnId} msgBody msgId = do
let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
withStore $ \st -> createSndMsgDelivery st sndMsgDelivery msgId
sendGroupMessage :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> m Message
sendGroupMessage :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> m MessageId
sendGroupMessage members chatMsgEvent =
sendGroupMessage' members chatMsgEvent Nothing $ pure ()
sendXGrpMemInv :: ChatMonad m => GroupMember -> ChatMsgEvent -> Int64 -> m Message
sendXGrpMemInv :: ChatMonad m => GroupMember -> ChatMsgEvent -> Int64 -> m MessageId
sendXGrpMemInv reMember chatMsgEvent introId =
sendGroupMessage' [reMember] chatMsgEvent (Just introId) $
withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded)
sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Maybe Int64 -> m () -> m Message
sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Maybe Int64 -> m () -> m MessageId
sendGroupMessage' members chatMsgEvent introId_ postDeliver = do
msg@Message {msgId, msgBody} <- createSndMessage chatMsgEvent
(msgId, msgBody) <- createSndMessage chatMsgEvent
for_ (filter memberCurrent members) $ \m@GroupMember {groupMemberId} ->
case memberConn m of
Nothing -> withStore $ \st -> createPendingGroupMessage st groupMemberId msgId introId_
Just conn -> deliverMessage conn msgBody msgId >> postDeliver
pure msg
pure msgId
sendPendingGroupMessages :: ChatMonad m => GroupMember -> Connection -> m ()
sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do
@ -1149,16 +1149,67 @@ sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do
Nothing -> chatError $ CEGroupMemberIntroNotFound localDisplayName
Just introId -> withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded)
saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> m (ChatMsgEvent, Message)
saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> m (MessageId, ChatMsgEvent)
saveRcvMSG Connection {connId} agentMsgMeta msgBody = do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
let agentMsgId = fst $ recipient agentMsgMeta
chatTs = snd $ broker agentMsgMeta
cmEventTag = toCMEventTag chatMsgEvent
newMsg = NewMessage {direction = MDRcv, cmEventTag, chatTs, msgBody}
newMsg = NewMessage {direction = MDRcv, cmEventTag, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta}
msg <- withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery
pure (chatMsgEvent, msg)
msgId <- withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery
pure (msgId, chatMsgEvent)
sendDirectChatItem :: ChatMonad m => UserId -> Contact -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTDirect 'MDSnd)
sendDirectChatItem userId contact@Contact {activeConn} chatMsgEvent ciContent = do
msgId <- sendDirectMessage activeConn chatMsgEvent
ciMeta <- saveChatItem userId (CDDirect contact) (Just msgId) ciContent
pure $ DirectChatItem (CISndMeta ciMeta) ciContent
sendGroupChatItem :: ChatMonad m => UserId -> Group -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTGroup 'MDSnd)
sendGroupChatItem userId (Group g ms) chatMsgEvent ciContent = do
msgId <- sendGroupMessage ms chatMsgEvent
ciMeta <- saveChatItem userId (CDSndGroup g) (Just msgId) ciContent
pure $ SndGroupChatItem (CISndMeta ciMeta) ciContent
saveRcvDirectChatItem :: ChatMonad m => UserId -> Contact -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem 'CTDirect 'MDRcv)
saveRcvDirectChatItem userId ct msgId MsgMeta {integrity} ciContent = do
ciMeta <- saveChatItem userId (CDDirect ct) (Just msgId) ciContent
pure $ DirectChatItem (CIRcvMeta ciMeta integrity) ciContent
saveRcvGroupChatItem :: ChatMonad m => UserId -> GroupInfo -> GroupMember -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem 'CTGroup 'MDRcv)
saveRcvGroupChatItem userId g m msgId MsgMeta {integrity} ciContent = do
ciMeta <- saveChatItem userId (CDRcvGroup g m) (Just msgId) ciContent
pure $ RcvGroupChatItem m (CIRcvMeta ciMeta integrity) ciContent
saveChatItem :: ChatMonad m => UserId -> ChatDirection c d -> Maybe MessageId -> CIContent d -> m CIMetaProps
saveChatItem userId chatDirection msgId_ ciContent = do
ci@NewChatItem {itemTs, createdAt} <- mkNewChatItem msgId_ MDRcv Nothing ciContent
ciId <- withStore $ \st -> createNewChatItem st userId chatDirection ci
liftIO $ mkCIMetaProps ciId itemTs createdAt
mkNewChatItem :: ChatMonad m => Maybe MessageId -> MsgDirection -> Maybe UTCTime -> CIContent d -> m (NewChatItem d)
mkNewChatItem createdByMsgId_ itemSent brokerTs_ itemContent = do
(itemTs, createdAt) <- timestamps
pure
NewChatItem
{ createdByMsgId_,
itemSent,
itemTs,
itemContent,
itemText = ciContentToText itemContent,
createdAt
}
where
timestamps = do
createdAt <- liftIO getCurrentTime
if isJust brokerTs_
then pure (fromJust brokerTs_, createdAt) -- if rcv use brokerTs
else pure (createdAt, createdAt) -- if snd use createdAt
mkCIMetaProps :: ChatItemId -> ChatItemTs -> UTCTime -> IO CIMetaProps
mkCIMetaProps itemId itemTs createdAt = do
localItemTs <- utcToLocalZonedTime itemTs
pure CIMetaProps {itemId, itemTs, localItemTs, createdAt}
allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m ()
allowAgentConnection conn@Connection {agentConnId} confId msg = do

70
src/Simplex/Chat/Controller.hs
View file

@ -17,7 +17,6 @@ import Data.Map.Strict (Map)
import Data.Text (Text)
import Numeric.Natural
import Simplex.Chat.Messages
import Simplex.Chat.Protocol
import Simplex.Chat.Store (StoreError)
import Simplex.Chat.Types
import Simplex.Messaging.Agent (AgentClient)
@ -103,26 +102,19 @@ data ChatCommand
deriving (Show)
data ChatResponse
= CRSentMessage ContactName MsgContent ChatMsgMeta
| CRSentGroupMessage GroupName MsgContent ChatMsgMeta
| CRSentFileInvitation ContactName FileTransferId FilePath ChatMsgMeta
| CRSentGroupFileInvitation GroupName FileTransferId FilePath ChatMsgMeta
| CRReceivedMessage ContactName ChatMsgMeta MsgContent MsgIntegrity
| CRReceivedGroupMessage GroupName ContactName ChatMsgMeta MsgContent MsgIntegrity
| CRReceivedFileInvitation ContactName ChatMsgMeta RcvFileTransfer MsgIntegrity
| CRReceivedGroupFileInvitation GroupName ContactName ChatMsgMeta RcvFileTransfer MsgIntegrity
= CRNewChatItem AChatItem
| CRCommandAccepted CorrId
| CRChatHelp HelpSection
| CRWelcome User
| CRGroupCreated Group
| CRGroupCreated GroupInfo
| CRGroupMembers Group
| CRContactsList [Contact]
| CRUserContactLink ConnReqContact
| CRContactRequestRejected ContactName
| CRUserAcceptedGroupSent GroupName
| CRUserDeletedMember GroupName GroupMember
| CRContactRequestRejected ContactName -- TODO
| CRUserAcceptedGroupSent GroupInfo
| CRUserDeletedMember GroupInfo GroupMember
| CRGroupsList [GroupInfo]
| CRSentGroupInvitation GroupName ContactName
| CRSentGroupInvitation GroupInfo Contact
| CRFileTransferStatus (FileTransfer, [Integer])
| CRUserProfile Profile
| CRUserProfileNoChange
@ -132,13 +124,13 @@ data ChatResponse
| CRSentInvitation
| CRContactUpdated {fromContact :: Contact, toContact :: Contact}
| CRContactsMerged {intoContact :: Contact, mergedContact :: Contact}
| CRContactDeleted ContactName
| CRContactDeleted ContactName -- TODO
| CRUserContactLinkCreated ConnReqContact
| CRUserContactLinkDeleted
| CRReceivedContactRequest ContactName Profile
| CRAcceptingContactRequest ContactName
| CRLeftMemberUser GroupName
| CRGroupDeletedUser GroupName
| CRReceivedContactRequest ContactName Profile -- TODO what is the entity here?
| CRAcceptingContactRequest ContactName -- TODO
| CRLeftMemberUser GroupInfo
| CRGroupDeletedUser GroupInfo
| CRRcvFileAccepted RcvFileTransfer FilePath
| CRRcvFileAcceptedSndCancelled RcvFileTransfer
| CRRcvFileStart RcvFileTransfer
@ -152,24 +144,24 @@ data ChatResponse
| CRSndGroupFileCancelled [SndFileTransfer]
| CRUserProfileUpdated {fromProfile :: Profile, toProfile :: Profile}
| CRContactConnected Contact
| CRContactAnotherClient ContactName
| CRContactDisconnected ContactName
| CRContactSubscribed ContactName
| CRContactSubError ContactName ChatError
| CRGroupInvitation Group
| CRReceivedGroupInvitation Group ContactName GroupMemberRole
| CRUserJoinedGroup GroupName
| CRJoinedGroupMember GroupName GroupMember
| CRJoinedGroupMemberConnecting {group :: GroupName, hostMember :: GroupMember, member :: GroupMember}
| CRConnectedToGroupMember GroupName GroupMember
| CRDeletedMember {group :: GroupName, byMember :: GroupMember, deletedMember :: GroupMember}
| CRDeletedMemberUser GroupName GroupMember
| CRLeftMember GroupName GroupMember
| CRGroupEmpty Group
| CRGroupRemoved Group
| CRGroupDeleted GroupName GroupMember
| CRMemberSubError GroupName ContactName ChatError
| CRGroupSubscribed Group
| CRContactAnotherClient Contact
| CRContactDisconnected Contact
| CRContactSubscribed Contact
| CRContactSubError Contact ChatError
| CRGroupInvitation GroupInfo
| CRReceivedGroupInvitation GroupInfo Contact GroupMemberRole
| CRUserJoinedGroup GroupInfo
| CRJoinedGroupMember GroupInfo GroupMember
| CRJoinedGroupMemberConnecting {group :: GroupInfo, hostMember :: GroupMember, member :: GroupMember}
| CRConnectedToGroupMember GroupInfo GroupMember
| CRDeletedMember {group :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember}
| CRDeletedMemberUser GroupInfo GroupMember
| CRLeftMember GroupInfo GroupMember
| CRGroupEmpty GroupInfo
| CRGroupRemoved GroupInfo
| CRGroupDeleted GroupInfo GroupMember
| CRMemberSubError GroupInfo ContactName ChatError -- TODO Contact? or GroupMember?
| CRGroupSubscribed GroupInfo
| CRSndFileSubError SndFileTransfer ChatError
| CRRcvFileSubError RcvFileTransfer ChatError
| CRUserContactLinkSubscribed
@ -193,12 +185,12 @@ data ChatErrorType
| CEGroupContactRole ContactName
| CEGroupDuplicateMember ContactName
| CEGroupDuplicateMemberId
| CEGroupNotJoined GroupName
| CEGroupNotJoined GroupInfo
| CEGroupMemberNotActive
| CEGroupMemberUserRemoved
| CEGroupMemberNotFound ContactName
| CEGroupMemberIntroNotFound ContactName
| CEGroupCantResendInvitation GroupName ContactName
| CEGroupCantResendInvitation GroupInfo ContactName
| CEGroupInternal String
| CEFileNotFound String
| CEFileAlreadyReceiving String

160
src/Simplex/Chat/Messages.hs
View file

@ -8,16 +8,18 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Messages where
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson (FromJSON, ToJSON, (.=))
import qualified Data.Aeson as J
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime)
import Data.Time.LocalTime (ZonedTime)
@ -28,28 +30,148 @@ import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), serializeMsgIntegrity)
import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgIntegrity, MsgMeta (..), serializeMsgIntegrity)
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
import Simplex.Messaging.Protocol (MsgBody)
data ChatType = CTDirect | CTGroup
deriving (Show)
data ChatInfo (c :: ChatType) where
DirectChat :: Contact -> ChatInfo 'CTDirect
GroupChat :: GroupInfo -> ChatInfo 'CTGroup
deriving instance Show (ChatInfo c)
type ChatItemData d = (CIMeta d, CIContent d)
data ChatItem (c :: ChatType) (d :: MsgDirection) where
DirectChatItem :: CIMeta d -> CIContent d -> ChatItem 'CTDirect d
SndGroupChatItem :: CIMeta 'MDSnd -> CIContent 'MDSnd -> ChatItem 'CTGroup 'MDSnd
RcvGroupChatItem :: GroupMember -> CIMeta 'MDRcv -> CIContent 'MDRcv -> ChatItem 'CTGroup 'MDRcv
deriving instance Show (ChatItem c d)
data CChatItem c = forall d. CChatItem (SMsgDirection d) (ChatItem c d)
deriving instance Show (CChatItem c)
chatItemId :: ChatItem c d -> ChatItemId
chatItemId = \case
DirectChatItem (CISndMeta CIMetaProps {itemId}) _ -> itemId
DirectChatItem (CIRcvMeta CIMetaProps {itemId} _) _ -> itemId
SndGroupChatItem (CISndMeta CIMetaProps {itemId}) _ -> itemId
RcvGroupChatItem _ (CIRcvMeta CIMetaProps {itemId} _) _ -> itemId
data ChatDirection (c :: ChatType) (d :: MsgDirection) where
CDDirect :: Contact -> ChatDirection 'CTDirect d
CDSndGroup :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd
CDRcvGroup :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
data NewChatItem d = NewChatItem
{ createdByMsgId_ :: Maybe MessageId,
itemSent :: MsgDirection,
itemTs :: ChatItemTs,
itemContent :: CIContent d,
itemText :: Text,
createdAt :: UTCTime
}
deriving (Show)
-- | type to show one chat with messages
data Chat c = Chat (ChatInfo c) [CChatItem c]
deriving (Show)
-- | type to show the list of chats, with one last message in each
data AChatPreview = forall c. AChatPreview (SChatType c) (ChatInfo c) (Maybe (CChatItem c))
deriving instance Show AChatPreview
-- | type to show a mix of messages from multiple chats
data AChatItem = forall c d. AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
deriving instance Show AChatItem
data CIMeta (d :: MsgDirection) where
CISndMeta :: CIMetaProps -> CIMeta 'MDSnd
CIRcvMeta :: CIMetaProps -> MsgIntegrity -> CIMeta 'MDRcv
deriving instance Show (CIMeta d)
data CIMetaProps = CIMetaProps
{ itemId :: ChatItemId,
itemTs :: ChatItemTs,
localItemTs :: ZonedTime,
createdAt :: UTCTime
}
deriving (Show)
type ChatItemId = Int64
type ChatItemTs = UTCTime
data CIContent (d :: MsgDirection) where
CIMsgContent :: MsgContent -> CIContent d
CISndFileInvitation :: FileTransferId -> FilePath -> CIContent 'MDSnd
CIRcvFileInvitation :: RcvFileTransfer -> CIContent 'MDRcv
deriving instance Show (CIContent d)
instance ToField (CIContent d) where toField = toField . decodeLatin1 . LB.toStrict . J.encode
instance ToJSON (CIContent d) where
toJSON = J.toJSON . ciContentToJSON
toEncoding = J.toEncoding . ciContentToJSON
data CIContentJSON = CIContentJSON
{ tag :: Text,
subTag :: Maybe Text,
args :: J.Value
}
deriving (Generic, FromJSON)
instance ToJSON CIContentJSON where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
ciContentToJSON :: CIContent d -> CIContentJSON
ciContentToJSON = \case
CIMsgContent mc -> o "content" "" $ J.object ["content" .= mc]
CISndFileInvitation fId fPath -> o "sndFile" "invitation" $ J.object ["fileId" .= fId, "filePath" .= fPath]
CIRcvFileInvitation ft -> o "rcvFile" "invitation" $ J.object ["fileTransfer" .= ft]
where
o tag "" args = CIContentJSON {tag, subTag = Nothing, args}
o tag st args = CIContentJSON {tag, subTag = Just st, args}
ciContentToText :: CIContent d -> Text
ciContentToText = \case
CIMsgContent mc -> msgContentText mc
CISndFileInvitation fId fPath -> "you sent file #" <> T.pack (show fId) <> ": " <> T.pack fPath
CIRcvFileInvitation RcvFileTransfer {fileInvitation = FileInvitation {fileName}} -> "file " <> T.pack fileName
data SChatType (c :: ChatType) where
SCTDirect :: SChatType 'CTDirect
SCTGroup :: SChatType 'CTGroup
deriving instance Show (SChatType c)
instance TestEquality SChatType where
testEquality SCTDirect SCTDirect = Just Refl
testEquality SCTGroup SCTGroup = Just Refl
testEquality _ _ = Nothing
class ChatTypeI (c :: ChatType) where
chatType :: SChatType c
instance ChatTypeI 'CTDirect where chatType = SCTDirect
instance ChatTypeI 'CTGroup where chatType = SCTGroup
data NewMessage = NewMessage
{ direction :: MsgDirection,
cmEventTag :: CMEventTag,
chatTs :: UTCTime,
msgBody :: MsgBody
}
deriving (Show)
data Message = Message
{ msgId :: MessageId,
direction :: MsgDirection,
cmEventTag :: CMEventTag,
chatTs :: UTCTime,
msgBody :: MsgBody,
createdAt :: UTCTime
}
deriving (Show)
data PendingGroupMessage = PendingGroupMessage
{ msgId :: MessageId,
cmEventTag :: CMEventTag,
@ -57,13 +179,7 @@ data PendingGroupMessage = PendingGroupMessage
introId_ :: Maybe Int64
}
data ChatMsgMeta = ChatMsgMeta
{ msgId :: MessageId,
chatTs :: UTCTime,
localChatTs :: ZonedTime,
createdAt :: UTCTime
}
deriving (Show)
type MessageId = Int64
data MsgDirection = MDRcv | MDSnd
deriving (Show)
@ -72,6 +188,8 @@ data SMsgDirection (d :: MsgDirection) where
SMDRcv :: SMsgDirection 'MDRcv
SMDSnd :: SMsgDirection 'MDSnd
deriving instance Show (SMsgDirection d)
instance TestEquality SMsgDirection where
testEquality SMDRcv SMDRcv = Just Refl
testEquality SMDSnd SMDSnd = Just Refl
@ -118,7 +236,7 @@ data MsgMetaJSON = MsgMetaJSON
}
deriving (Eq, Show, FromJSON, Generic)
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
msgMetaToJson :: MsgMeta -> MsgMetaJSON
msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} =

2
src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs
View file

@ -16,6 +16,4 @@ CREATE TABLE pending_group_messages (
group_member_intro_id INTEGER REFERENCES group_member_intros ON DELETE CASCADE,
created_at TEXT NOT NULL DEFAULT (datetime('now'))
);
ALTER TABLE messages ADD chat_ts TEXT;
|]

35
src/Simplex/Chat/Migrations/M20220125_chat_items.hs Normal file
View file

@ -0,0 +1,35 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20220125_chat_items where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220125_chat_items :: Query
m20220125_chat_items =
[sql|
CREATE TABLE chat_items ( -- mutable chat_items presented to user
chat_item_id INTEGER PRIMARY KEY,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, -- NULL for sent even if group_id is not
chat_msg_id INTEGER, -- sent as part of the message that created the item
created_by_msg_id INTEGER UNIQUE REFERENCES messages (message_id) ON DELETE SET NULL,
item_sent INTEGER NOT NULL, -- 0 for received, 1 for sent
item_ts TEXT NOT NULL, -- broker_ts of creating message for received, created_at for sent
item_deleted INTEGER NOT NULL DEFAULT 0, -- 1 for deleted,
item_content TEXT NOT NULL, -- JSON
item_text TEXT NOT NULL, -- textual representation
created_at TEXT NOT NULL DEFAULT (datetime('now')),
updated_at TEXT NOT NULL DEFAULT (datetime('now'))
);
CREATE TABLE chat_item_messages (
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
message_id INTEGER NOT NULL UNIQUE REFERENCES messages ON DELETE CASCADE,
UNIQUE (chat_item_id, message_id)
);
ALTER TABLE files ADD COLUMN chat_item_id INTEGER DEFAULT NULL REFERENCES chat_items ON DELETE CASCADE;
|]

39
src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListDirect.sql Normal file
View file

@ -0,0 +1,39 @@
SELECT
c.contact_id,
cp.display_name,
cp.full_name,
cp.properties,
ci.chat_item_id,
ci.chat_msg_id,
ci.created_by_msg_id,
ci.item_sent,
ci.item_ts,
ci.item_deleted,
ci.item_text,
ci.item_content,
md.msg_delivery_id,
md.chat_ts,
md.agent_msg_meta,
mde.delivery_status,
mde.created_at
FROM contacts c
JOIN contact_profiles cp ON cp.contact_profile_id == c.contact_profile_id
JOIN (
SELECT contact_id, chat_item_id, MAX(item_ts) MaxDate
FROM chat_items
WHERE item_deleted != 1
GROUP BY contact_id, chat_item_id
) CIMaxDates ON CIMaxDates.contact_id = c.contact_id
LEFT JOIN chat_items ci ON ci.chat_item_id == CIMaxDates.chat_item_id
AND ci.item_ts == CIMaxDates.MaxDate
JOIN messages m ON m.message_id == ci.created_by_msg_id
JOIN msg_deliveries md ON md.message_id = m.message_id
JOIN (
SELECT msg_delivery_id, MAX(created_at) MaxDate
FROM msg_delivery_events
GROUP BY msg_delivery_id
) MDEMaxDates ON MDEMaxDates.msg_delivery_id = md.msg_delivery_id
JOIN msg_delivery_events mde ON mde.msg_delivery_id = MDEMaxDates.msg_delivery_id
AND mde.created_at = MDEMaxDates.MaxDate
WHERE c.user_id = ?
ORDER BY ci.item_ts DESC

45
src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListGroup.sql Normal file
View file

@ -0,0 +1,45 @@
SELECT
g.group_id,
gp.display_name,
gp.full_name,
gp.properties,
gm.group_member_id,
cp.display_name,
cp.full_name,
cp.properties,
ci.chat_item_id,
ci.chat_msg_id,
ci.created_by_msg_id,
ci.item_sent,
ci.item_ts,
ci.item_deleted,
ci.item_text,
ci.item_content,
md.msg_delivery_id,
md.chat_ts,
md.agent_msg_meta,
mde.delivery_status,
mde.created_at
FROM groups g
JOIN group_profiles gp ON gp.group_profile_id == g.group_profile_id
JOIN (
SELECT group_id, chat_item_id, MAX(item_ts) MaxDate
FROM chat_items
WHERE item_deleted != 1
GROUP BY group_id, chat_item_id
) CIMaxDates ON CIMaxDates.group_id = g.group_id
LEFT JOIN chat_items ci ON ci.chat_item_id == CIMaxDates.chat_item_id
AND ci.item_ts == CIMaxDates.MaxDate
LEFT JOIN group_members ON gm.group_member_id == ci.group_member_id
JOIN contact_profiles cp ON cp.contact_profile_id == gm.contact_profile_id
JOIN messages m ON m.message_id == ci.created_by_msg_id
JOIN msg_deliveries md ON md.message_id = m.message_id
JOIN (
SELECT msg_delivery_id, MAX(created_at) MaxDate
FROM msg_delivery_events
GROUP BY msg_delivery_id
) MDEMaxDates ON MDEMaxDates.msg_delivery_id = md.msg_delivery_id
JOIN msg_delivery_events mde ON mde.msg_delivery_id = MDEMaxDates.msg_delivery_id
AND mde.created_at = MDEMaxDates.MaxDate
WHERE c.user_id = ?
ORDER BY ci.item_ts DESC

44
src/Simplex/Chat/Migrations/chat_item_queries/getChatItemsMixed.sql Normal file
View file

@ -0,0 +1,44 @@
SELECT
c.contact_id,
cp.display_name,
cp.full_name,
cp.properties,
g.group_id,
gp.display_name,
gp.full_name,
gp.properties,
gm.group_member_id,
gmp.display_name,
gmp.full_name,
gmp.properties,
ci.chat_item_id,
ci.chat_msg_id,
ci.created_by_msg_id,
ci.item_sent,
ci.item_ts,
ci.item_deleted,
ci.item_text,
ci.item_content,
md.msg_delivery_id,
md.chat_ts,
md.agent_msg_meta,
mde.delivery_status,
mde.created_at
FROM chat_items ci
LEFT JOIN contacts c ON c.contact_id == ci.contact_id
JOIN contact_profiles cp ON cp.contact_profile_id == c.contact_profile_id
LEFT JOIN groups g ON g.group_id = ci.group_id
JOIN group_profiles gp ON gp.group_profile_id == g.group_profile_id
LEFT JOIN group_members ON gm.group_member_id == ci.group_member_id
JOIN contact_profiles gmp ON gmp.contact_profile_id == gm.contact_profile_id
JOIN messages m ON m.message_id == ci.created_by_msg_id
JOIN msg_deliveries md ON md.message_id = m.message_id
JOIN (
SELECT msg_delivery_id, MAX(created_at) MaxDate
FROM msg_delivery_events
GROUP BY msg_delivery_id
) MDEMaxDates ON MDEMaxDates.msg_delivery_id = md.msg_delivery_id
JOIN msg_delivery_events mde ON mde.msg_delivery_id = MDEMaxDates.msg_delivery_id
AND mde.created_at = MDEMaxDates.MaxDate
WHERE ci.user_id = ?
ORDER BY ci.item_ts DESC

32
src/Simplex/Chat/Migrations/chat_item_queries/getDirectChatItemList.sql Normal file
View file

@ -0,0 +1,32 @@
SELECT
c.contact_id,
cp.display_name,
cp.full_name,
cp.properties,
ci.chat_item_id,
ci.chat_msg_id,
ci.created_by_msg_id,
ci.item_sent,
ci.item_ts,
ci.item_deleted,
ci.item_text,
ci.item_content,
md.msg_delivery_id,
md.chat_ts,
md.agent_msg_meta,
mde.delivery_status,
mde.created_at
FROM contacts c
JOIN contact_profiles cp ON cp.contact_profile_id == c.contact_profile_id
LEFT JOIN chat_items ci ON ci.contact_id == c.contact_id
JOIN messages m ON m.message_id == ci.created_by_msg_id
JOIN msg_deliveries md ON md.message_id = m.message_id
JOIN (
SELECT msg_delivery_id, MAX(created_at) MaxDate
FROM msg_delivery_events
GROUP BY msg_delivery_id
) MDEMaxDates ON MDEMaxDates.msg_delivery_id = md.msg_delivery_id
JOIN msg_delivery_events mde ON mde.msg_delivery_id = MDEMaxDates.msg_delivery_id
AND mde.created_at = MDEMaxDates.MaxDate
WHERE c.user_id = ? AND c.contact_id = ?
ORDER BY ci.item_ts DESC

38
src/Simplex/Chat/Migrations/chat_item_queries/getGroupChatItemList.sql Normal file
View file

@ -0,0 +1,38 @@
SELECT
g.group_id,
gp.display_name,
gp.full_name,
gp.properties,
gm.group_member_id,
cp.display_name,
cp.full_name,
cp.properties,
ci.chat_item_id,
ci.chat_msg_id,
ci.created_by_msg_id,
ci.item_sent,
ci.item_ts,
ci.item_deleted,
ci.item_text,
ci.item_content,
md.msg_delivery_id,
md.chat_ts,
md.agent_msg_meta,
mde.delivery_status,
mde.created_at
FROM groups g
JOIN group_profiles gp ON gp.group_profile_id == g.group_profile_id
LEFT JOIN chat_items ci ON ci.group_id == g.group_id
LEFT JOIN group_members ON gm.group_member_id == ci.group_member_id
JOIN contact_profiles cp ON cp.contact_profile_id == gm.contact_profile_id
JOIN messages m ON m.message_id == ci.created_by_msg_id
JOIN msg_deliveries md ON md.message_id = m.message_id
JOIN (
SELECT msg_delivery_id, MAX(created_at) MaxDate
FROM msg_delivery_events
GROUP BY msg_delivery_id
) MDEMaxDates ON MDEMaxDates.msg_delivery_id = md.msg_delivery_id
JOIN msg_delivery_events mde ON mde.msg_delivery_id = MDEMaxDates.msg_delivery_id
AND mde.created_at = MDEMaxDates.MaxDate
WHERE g.user_id = ? AND g.group_id = ?
ORDER BY ci.item_ts DESC

26
src/Simplex/Chat/Protocol.hs
View file

@ -26,28 +26,22 @@ import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Util ((<$?>))
data ChatDirection (p :: AParty) where
ReceivedDirectMessage :: Connection -> Maybe Contact -> ChatDirection 'Agent
SentDirectMessage :: Contact -> ChatDirection 'Client
ReceivedGroupMessage :: Connection -> GroupName -> GroupMember -> ChatDirection 'Agent
SentGroupMessage :: GroupName -> ChatDirection 'Client
SndFileConnection :: Connection -> SndFileTransfer -> ChatDirection 'Agent
RcvFileConnection :: Connection -> RcvFileTransfer -> ChatDirection 'Agent
UserContactConnection :: Connection -> UserContact -> ChatDirection 'Agent
data ConnectionEntity
= RcvDirectMsgConnection Connection (Maybe Contact)
| RcvGroupMsgConnection Connection GroupInfo GroupMember
| SndFileConnection Connection SndFileTransfer
| RcvFileConnection Connection RcvFileTransfer
| UserContactConnection Connection UserContact
deriving (Eq, Show)
deriving instance Eq (ChatDirection p)
deriving instance Show (ChatDirection p)
fromConnection :: ChatDirection 'Agent -> Connection
fromConnection :: ConnectionEntity -> Connection
fromConnection = \case
ReceivedDirectMessage conn _ -> conn
ReceivedGroupMessage conn _ _ -> conn
RcvDirectMsgConnection conn _ -> conn
RcvGroupMsgConnection conn _ _ -> conn
SndFileConnection conn _ -> conn
RcvFileConnection conn _ -> conn
UserContactConnection conn _ -> conn

381
src/Simplex/Chat/Store.hs
View file

@ -3,6 +3,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@ -42,11 +43,13 @@ module Simplex.Chat.Store
getPendingSndChunks,
getPendingConnections,
getContactConnections,
getConnectionChatDirection,
getConnectionEntity,
updateConnectionStatus,
createNewGroup,
createGroupInvitation,
getGroup,
getGroupInfo,
getGroupMembers,
deleteGroup,
getUserGroups,
getUserGroupDetails,
@ -88,6 +91,7 @@ module Simplex.Chat.Store
createRcvFileChunk,
updatedRcvFileChunkStored,
deleteRcvFileChunks,
updateFileTransferChatItemId,
getFileTransfer,
getFileTransferProgress,
createNewMessage,
@ -98,6 +102,7 @@ module Simplex.Chat.Store
createPendingGroupMessage,
getPendingGroupMessages,
deletePendingGroupMessage,
createNewChatItem,
)
where
@ -115,7 +120,7 @@ import Data.Function (on)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find, sortBy)
import Data.Maybe (listToMaybe)
import Data.Maybe (fromJust, isJust, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime, getCurrentTime)
@ -125,10 +130,11 @@ import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages
import Simplex.Chat.Migrations.M20220101_initial
import Simplex.Chat.Migrations.M20220122_pending_group_messages
import Simplex.Chat.Migrations.M20220125_chat_items
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId, MsgMeta (..))
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction)
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..))
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, withTransaction)
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>))
@ -138,7 +144,8 @@ import UnliftIO.STM
schemaMigrations :: [(String, Query)]
schemaMigrations =
[ ("20220101_initial", m20220101_initial),
("20220122_pending_group_messages", m20220122_pending_group_messages)
("20220122_pending_group_messages", m20220122_pending_group_messages),
("20220125_chat_items", m20220125_chat_items)
]
-- | The list of migrations in ascending order by date
@ -771,19 +778,19 @@ mergeContactRecords st userId Contact {contactId = toContactId} Contact {contact
DB.execute db "DELETE FROM contacts WHERE contact_id = ? AND user_id = ?" (fromContactId, userId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
getConnectionChatDirection :: StoreMonad m => SQLiteStore -> User -> ConnId -> m (ChatDirection 'Agent)
getConnectionChatDirection st User {userId, userContactId} agentConnId =
getConnectionEntity :: StoreMonad m => SQLiteStore -> User -> ConnId -> m ConnectionEntity
getConnectionEntity st User {userId, userContactId} agentConnId =
liftIOEither . withTransaction st $ \db -> runExceptT $ do
c@Connection {connType, entityId} <- getConnection_ db
case entityId of
Nothing ->
if connType == ConnContact
then pure $ ReceivedDirectMessage c Nothing
then pure $ RcvDirectMsgConnection c Nothing
else throwError $ SEInternal $ "connection " <> bshow connType <> " without entity"
Just entId ->
case connType of
ConnMember -> uncurry (ReceivedGroupMessage c) <$> getGroupAndMember_ db entId c
ConnContact -> ReceivedDirectMessage c . Just <$> getContactRec_ db entId c
ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ db entId c
ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ db entId c
ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ db entId c
ConnRcvFile -> RcvFileConnection c <$> ExceptT (getRcvFileTransfer_ db userId entId)
ConnUserContact -> UserContactConnection c <$> getUserContact_ db entId
@ -820,27 +827,37 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
let profile = Profile {displayName, fullName}
in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup}
toContact _ _ _ = Left $ SEInternal "referenced contact not found"
getGroupAndMember_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO (GroupName, GroupMember)
getGroupAndMember_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember_ db groupMemberId c = ExceptT $ do
toGroupAndMember c
<$> DB.query
firstRow (toGroupAndMember c) (SEInternal "referenced group member not found") $
DB.query
db
[sql|
SELECT
g.local_display_name,
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name,
-- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
-- user membership
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status,
mu.invited_by, mu.local_display_name, mu.contact_id, pu.display_name, pu.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 = ?
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members mu ON g.group_id = mu.group_id
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
|]
(Only groupMemberId)
toGroupAndMember :: Connection -> [Only GroupName :. GroupMemberRow] -> Either StoreError (GroupName, GroupMember)
toGroupAndMember c [Only groupName :. memberRow] =
(groupMemberId, userId, userContactId)
toGroupAndMember :: Connection -> (Int64, GroupName, GroupName, Text) :. GroupMemberRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c ((groupId, localDisplayName, displayName, fullName) :. memberRow :. userMemberRow) =
let member = toGroupMember userContactId memberRow
in Right (groupName, (member :: GroupMember) {activeConn = Just c})
toGroupAndMember _ _ = Left $ SEInternal "referenced group member not found"
membership = toGroupMember userContactId userMemberRow
in ( GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName}, membership},
(member :: GroupMember) {activeConn = Just c}
)
getConnSndFileTransfer_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
getConnSndFileTransfer_ db fileId Connection {connId} =
ExceptT $
@ -859,7 +876,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
sndFileTransfer_ :: Int64 -> Int64 -> [(FileStatus, String, Integer, Integer, FilePath, Maybe ContactName, Maybe ContactName)] -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId [(fileStatus, fileName, fileSize, chunkSize, filePath, contactName_, memberName_)] =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {..}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId = AgentConnId agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
sndFileTransfer_ fileId _ _ = Left $ SESndFileNotFound fileId
getUserContact_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UserContact
@ -884,7 +901,7 @@ updateConnectionStatus st Connection {connId} connStatus =
DB.execute db "UPDATE connections SET conn_status = ? WHERE connection_id = ?" (connStatus, connId)
-- | creates completely new group with a single member - the current user
createNewGroup :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> GroupProfile -> m Group
createNewGroup :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> GroupProfile -> m GroupInfo
createNewGroup st gVar user groupProfile =
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
let GroupProfile {displayName, fullName} = groupProfile
@ -896,23 +913,23 @@ createNewGroup st gVar user groupProfile =
groupId <- insertedRowId db
memberId <- randomBytes gVar 12
membership <- createContactMember_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser
pure $ Right Group {groupId, localDisplayName = displayName, groupProfile, members = [], membership}
pure $ Right GroupInfo {groupId, localDisplayName = displayName, groupProfile, membership}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation ::
StoreMonad m => SQLiteStore -> User -> Contact -> GroupInvitation -> m Group
StoreMonad m => SQLiteStore -> User -> Contact -> GroupInvitation -> m GroupInfo
createGroupInvitation st user@User {userId} contact GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} =
liftIOEither . withTransaction st $ \db -> do
getGroupInvitationLdn_ db >>= \case
Nothing -> createGroupInvitation_ db
-- TODO treat the case that the invitation details could've changed
Just localDisplayName -> runExceptT $ fst <$> getGroup_ db user localDisplayName
Just localDisplayName -> getGroupInfo_ db user localDisplayName
where
getGroupInvitationLdn_ :: DB.Connection -> IO (Maybe GroupName)
getGroupInvitationLdn_ db =
listToMaybe . map fromOnly
<$> DB.query db "SELECT local_display_name FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1;" (connRequest, userId)
createGroupInvitation_ :: DB.Connection -> IO (Either StoreError Group)
createGroupInvitation_ :: DB.Connection -> IO (Either StoreError GroupInfo)
createGroupInvitation_ db = do
let GroupProfile {displayName, fullName} = groupProfile
withLocalDisplayName db userId displayName $ \localDisplayName -> do
@ -920,73 +937,24 @@ createGroupInvitation st user@User {userId} contact GroupInvitation {fromMember,
profileId <- insertedRowId db
DB.execute db "INSERT INTO groups (group_profile_id, local_display_name, inv_queue_info, user_id) VALUES (?, ?, ?, ?)" (profileId, localDisplayName, connRequest, userId)
groupId <- insertedRowId db
member <- createContactMember_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown
_ <- createContactMember_ db user groupId contact fromMember GCHostMember GSMemInvited IBUnknown
membership <- createContactMember_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact $ contactId contact)
pure Group {groupId, localDisplayName, groupProfile, members = [member], membership}
pure $ GroupInfo {groupId, localDisplayName, groupProfile, membership}
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
getGroup :: StoreMonad m => SQLiteStore -> User -> GroupName -> m Group
getGroup st user localDisplayName =
liftIOEither . withTransaction st $ \db -> runExceptT $ fst <$> getGroup_ db user localDisplayName
liftIOEither . withTransaction st $ \db -> runExceptT $ getGroup_ db user localDisplayName
getGroup_ :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO (Group, Maybe ConnReqInvitation)
getGroup_ db User {userId, userContactId} localDisplayName = do
(g@Group {groupId}, cReq) <- getGroupRec_
allMembers <- getMembers_ groupId
(members, membership) <- liftEither $ splitUserMember_ allMembers
pure (g {members, membership}, cReq)
where
getGroupRec_ :: ExceptT StoreError IO (Group, Maybe ConnReqInvitation)
getGroupRec_ = ExceptT $ do
toGroup
<$> DB.query
db
[sql|
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, Maybe ConnReqInvitation)] -> Either StoreError (Group, Maybe ConnReqInvitation)
toGroup [(groupId, displayName, fullName, cReq)] =
let groupProfile = GroupProfile {displayName, fullName}
in Right (Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined}, cReq)
toGroup _ = Left $ SEGroupNotFound localDisplayName
getMembers_ :: Int64 -> ExceptT StoreError IO [GroupMember]
getMembers_ groupId = ExceptT $ do
Right . map toContactMember
<$> DB.query
db
[sql|
SELECT
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.group_member_id = m.group_member_id
)
WHERE m.group_id = ? AND m.user_id = ?
|]
(groupId, userId)
toContactMember :: (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember (memberRow :. connRow) =
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow}
splitUserMember_ :: [GroupMember] -> Either StoreError ([GroupMember], GroupMember)
splitUserMember_ allMembers =
let (b, a) = break ((== Just userContactId) . memberContactId) allMembers
in case a of
[] -> Left SEGroupWithoutUser
u : ms -> Right (b <> ms, u)
getGroup_ :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO Group
getGroup_ db user gName = do
gInfo <- ExceptT $ getGroupInfo_ db user gName
members <- liftIO $ getGroupMembers_ db user gInfo
pure $ Group gInfo members
deleteGroup :: MonadUnliftIO m => SQLiteStore -> User -> Group -> m ()
deleteGroup st User {userId} Group {groupId, members, localDisplayName} =
deleteGroup st User {userId} (Group GroupInfo {groupId, localDisplayName} members) =
liftIO . withTransaction st $ \db -> do
forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId m)
DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId)
@ -998,36 +966,97 @@ getUserGroups :: MonadUnliftIO m => SQLiteStore -> User -> m [Group]
getUserGroups st user@User {userId} =
liftIO . withTransaction st $ \db -> do
groupNames <- map fromOnly <$> DB.query db "SELECT local_display_name FROM groups WHERE user_id = ?" (Only userId)
map fst . rights <$> mapM (runExceptT . getGroup_ db user) groupNames
rights <$> mapM (runExceptT . getGroup_ db user) groupNames
getUserGroupDetails :: MonadUnliftIO m => SQLiteStore -> UserId -> m [GroupInfo]
getUserGroupDetails st userId =
getUserGroupDetails :: MonadUnliftIO m => SQLiteStore -> User -> m [GroupInfo]
getUserGroupDetails st User {userId, userContactId} =
liftIO . withTransaction st $ \db ->
map groupInfo
map (toGroupInfo userContactId)
<$> DB.query
db
[sql|
SELECT g.group_id, g.local_display_name, p.display_name, p.full_name, m.member_status
SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name,
m.group_member_id, g.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, mp.display_name, mp.full_name
FROM groups g
JOIN group_profiles p USING (group_profile_id)
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members m USING (group_id)
WHERE g.user_id = ? AND m.member_category = 'user'
JOIN contact_profiles mp USING (contact_profile_id)
WHERE g.user_id = ? AND m.contact_id = ?
|]
(Only userId)
where
groupInfo (groupId, localDisplayName, displayName, fullName, userMemberStatus) =
GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName}, userMemberStatus}
(userId, userContactId)
getGroupInfo :: StoreMonad m => SQLiteStore -> User -> GroupName -> m GroupInfo
getGroupInfo st user gName = liftIOEither . withTransaction st $ \db -> getGroupInfo_ db user gName
getGroupInfo_ :: DB.Connection -> User -> GroupName -> IO (Either StoreError GroupInfo)
getGroupInfo_ db User {userId, userContactId} gName =
firstRow (toGroupInfo userContactId) (SEGroupNotFound gName) $
DB.query
db
[sql|
SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name,
m.group_member_id, g.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, mp.display_name, mp.full_name
FROM groups g
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members m USING (group_id)
JOIN contact_profiles mp USING (contact_profile_id)
WHERE g.local_display_name = ? AND g.user_id = ? AND m.contact_id = ?
|]
(gName, userId, userContactId)
toGroupInfo :: Int64 -> (Int64, GroupName, GroupName, Text) :. GroupMemberRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName) :. memberRow) =
let membership = toGroupMember userContactId memberRow
in GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName}, membership}
getGroupMembers :: MonadUnliftIO m => SQLiteStore -> User -> GroupInfo -> m [GroupMember]
getGroupMembers st user gInfo = liftIO . withTransaction st $ \db -> getGroupMembers_ db user gInfo
getGroupMembers_ :: DB.Connection -> User -> GroupInfo -> IO [GroupMember]
getGroupMembers_ db User {userId, userContactId} GroupInfo {groupId} = do
map toContactMember
<$> DB.query
db
[sql|
SELECT
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.group_member_id = m.group_member_id
)
WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)
|]
(groupId, userId, userContactId)
where
toContactMember :: (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember (memberRow :. connRow) =
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow}
-- TODO no need to load all members to find the member who invited the used,
-- instead of findFromContact there could be a query
getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation
getGroupInvitation st user localDisplayName =
liftIOEither . withTransaction st $ \db -> runExceptT $ do
(Group {membership, members, groupProfile}, cReq) <- getGroup_ db user localDisplayName
cReq <- getConnRec_ db user
Group groupInfo@GroupInfo {membership} members <- getGroup_ db user localDisplayName
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
case (cReq, findFromContact (invitedBy membership) members) of
(Just connRequest, Just fromMember) ->
pure ReceivedGroupInvitation {fromMember, userMember = membership, connRequest, groupProfile}
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo}
_ -> throwError SEGroupInvitationNotFound
where
getConnRec_ :: DB.Connection -> User -> ExceptT StoreError IO (Maybe ConnReqInvitation)
getConnRec_ db User {userId} = ExceptT $ do
firstRow fromOnly (SEGroupNotFound localDisplayName) $
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.local_display_name = ? AND g.user_id = ?" (localDisplayName, userId)
findFromContact :: InvitedBy -> [GroupMember] -> Maybe GroupMember
findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId)
findFromContact _ = const Nothing
@ -1076,8 +1105,8 @@ updateGroupMemberStatus st userId GroupMember {groupMemberId} memStatus =
]
-- | add new member with profile
createNewGroupMember :: StoreMonad m => SQLiteStore -> User -> Group -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> m GroupMember
createNewGroupMember st user@User {userId} group memInfo@(MemberInfo _ _ Profile {displayName, fullName}) memCategory memStatus =
createNewGroupMember :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> m GroupMember
createNewGroupMember st user@User {userId} gInfo memInfo@(MemberInfo _ _ Profile {displayName, fullName}) memCategory memStatus =
liftIOEither . withTransaction st $ \db ->
withLocalDisplayName db userId displayName $ \localDisplayName -> do
DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName)
@ -1092,13 +1121,13 @@ createNewGroupMember st user@User {userId} group memInfo@(MemberInfo _ _ Profile
memContactId = Nothing,
memProfileId
}
createNewMember_ db user group newMember
createNewMember_ db user gInfo newMember
createNewMember_ :: DB.Connection -> User -> Group -> NewGroupMember -> IO GroupMember
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> IO GroupMember
createNewMember_
db
User {userId, userContactId}
Group {groupId}
GroupInfo {groupId}
NewGroupMember
{ memInfo = MemberInfo memberId memberRole memberProfile,
memCategory = memberCategory,
@ -1129,8 +1158,8 @@ deleteGroupMemberConnection_ :: DB.Connection -> UserId -> GroupMember -> IO ()
deleteGroupMemberConnection_ db userId GroupMember {groupMemberId} =
DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId)
createIntroductions :: MonadUnliftIO m => SQLiteStore -> Group -> GroupMember -> m [GroupMemberIntro]
createIntroductions st Group {members} toMember = do
createIntroductions :: MonadUnliftIO m => SQLiteStore -> [GroupMember] -> GroupMember -> m [GroupMemberIntro]
createIntroductions st members toMember = do
let reMembers = filter (\m -> memberCurrent m && groupMemberId m /= groupMemberId toMember) members
if null reMembers
then pure []
@ -1218,8 +1247,8 @@ getIntroduction_ db reMember toMember = ExceptT $ do
in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation}
toIntro _ = Left SEIntroNotFound
createIntroReMember :: StoreMonad m => SQLiteStore -> User -> Group -> GroupMember -> MemberInfo -> ConnId -> ConnId -> m GroupMember
createIntroReMember st user@User {userId} group@Group {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId =
createIntroReMember :: StoreMonad m => SQLiteStore -> User -> GroupInfo -> GroupMember -> MemberInfo -> ConnId -> ConnId -> m GroupMember
createIntroReMember st user@User {userId} gInfo@GroupInfo {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId =
liftIOEither . withTransaction st $ \db -> runExceptT $ do
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
Connection {connId = directConnId} <- liftIO $ createContactConnection_ db userId directAgentConnId memberContactId cLevel
@ -1235,7 +1264,7 @@ createIntroReMember st user@User {userId} group@Group {groupId} _host@GroupMembe
memContactId = Just contactId,
memProfileId
}
member <- createNewMember_ db user group newMember
member <- createNewMember_ db user gInfo newMember
conn <- createMemberConnection_ db userId (groupMemberId member) groupAgentConnId memberContactId cLevel
pure (member :: GroupMember) {activeConn = Just conn}
@ -1318,7 +1347,7 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
":sent_inv_queue_info" := connRequest
]
getViaGroupMember :: MonadUnliftIO m => SQLiteStore -> User -> Contact -> m (Maybe (GroupName, GroupMember))
getViaGroupMember :: MonadUnliftIO m => SQLiteStore -> User -> Contact -> m (Maybe (GroupInfo, GroupMember))
getViaGroupMember st User {userId, userContactId} Contact {contactId} =
liftIO . withTransaction st $ \db ->
toGroupAndMember
@ -1326,28 +1355,40 @@ getViaGroupMember st User {userId, userContactId} Contact {contactId} =
db
[sql|
SELECT
g.local_display_name,
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name,
-- via GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at,
-- user membership
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status,
mu.invited_by, mu.local_display_name, mu.contact_id, pu.display_name, pu.full_name
FROM group_members m
JOIN contacts ct ON ct.contact_id = m.contact_id
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
JOIN groups g ON g.group_id = m.group_id AND g.group_id = ct.via_group
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members mu ON g.group_id = mu.group_id
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.group_member_id = m.group_member_id
)
WHERE ct.user_id = ? AND ct.contact_id = ?
WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ?
|]
(userId, contactId)
(userId, contactId, userContactId)
where
toGroupAndMember :: [Only GroupName :. GroupMemberRow :. MaybeConnectionRow] -> Maybe (GroupName, GroupMember)
toGroupAndMember [Only groupName :. memberRow :. connRow] =
toGroupAndMember :: [(Int64, GroupName, GroupName, Text) :. GroupMemberRow :. MaybeConnectionRow :. GroupMemberRow] -> Maybe (GroupInfo, GroupMember)
toGroupAndMember [(groupId, localDisplayName, displayName, fullName) :. memberRow :. connRow :. userMemberRow] =
let member = toGroupMember userContactId memberRow
in Just (groupName, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
membership = toGroupMember userContactId userMemberRow
in Just
( GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName}, membership},
(member :: GroupMember) {activeConn = toMaybeConnection connRow}
)
toGroupAndMember _ = Nothing
getViaGroupContact :: MonadUnliftIO m => SQLiteStore -> User -> GroupMember -> m (Maybe Contact)
@ -1382,17 +1423,17 @@ getViaGroupContact st User {userId} GroupMember {groupMemberId} =
toContact _ = Nothing
createSndFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FilePath -> FileInvitation -> ConnId -> Integer -> m SndFileTransfer
createSndFileTransfer st userId Contact {contactId, localDisplayName = recipientDisplayName} filePath FileInvitation {fileName, fileSize} agentConnId chunkSize =
createSndFileTransfer st userId Contact {contactId, localDisplayName = recipientDisplayName} filePath FileInvitation {fileName, fileSize} aConnId chunkSize =
liftIO . withTransaction st $ \db -> do
DB.execute db "INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size) VALUES (?, ?, ?, ?, ?, ?)" (userId, contactId, fileName, filePath, fileSize, chunkSize)
fileId <- insertedRowId db
Connection {connId} <- createSndFileConnection_ db userId fileId agentConnId
Connection {connId} <- createSndFileConnection_ db userId fileId aConnId
let fileStatus = FSNew
DB.execute db "INSERT INTO snd_files (file_id, file_status, connection_id) VALUES (?, ?, ?)" (fileId, fileStatus, connId)
pure SndFileTransfer {..}
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName, connId, fileStatus, agentConnId = AgentConnId aConnId}
createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Group -> [(GroupMember, ConnId, FileInvitation)] -> FilePath -> Integer -> Integer -> m Int64
createSndGroupFileTransfer st userId Group {groupId} ms filePath fileSize chunkSize =
createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> [(GroupMember, ConnId, FileInvitation)] -> FilePath -> Integer -> Integer -> m Int64
createSndGroupFileTransfer st userId GroupInfo {groupId} ms filePath fileSize chunkSize =
liftIO . withTransaction st $ \db -> do
let fileName = takeFileName filePath
DB.execute db "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size) VALUES (?, ?, ?, ?, ?, ?)" (userId, groupId, fileName, filePath, fileSize, chunkSize)
@ -1496,7 +1537,7 @@ getRcvFileTransfer_ db userId fileId =
(userId, fileId)
where
rcvFileTransfer ::
[(FileStatus, ConnReqInvitation, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe ConnId)] ->
[(FileStatus, ConnReqInvitation, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId)] ->
Either StoreError RcvFileTransfer
rcvFileTransfer [(fileStatus', fileConnReq, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
let fileInv = FileInvitation {fileName, fileSize, fileConnReq}
@ -1577,6 +1618,11 @@ deleteRcvFileChunks st RcvFileTransfer {fileId} =
liftIO . withTransaction st $ \db ->
DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId)
updateFileTransferChatItemId :: MonadUnliftIO m => SQLiteStore -> FileTransferId -> ChatItemId -> m ()
updateFileTransferChatItemId st fileId ciId =
liftIO . withTransaction st $ \db ->
DB.execute db "UPDATE files SET chat_item_id = ? WHERE file_id = ?" (ciId, fileId)
getFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m FileTransfer
getFileTransfer st userId fileId =
liftIOEither . withTransaction st $ \db ->
@ -1627,15 +1673,15 @@ getSndFileTransfers_ db userId fileId =
|]
(userId, fileId)
where
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, ConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer]
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, AgentConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer]
sndFileTransfers [] = Left $ SESndFileNotFound fileId
sndFileTransfers fts = mapM sndFileTransfer fts
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId, contactName_, memberName_) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {..}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m Message
createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m MessageId
createNewMessage st newMsg =
liftIO . withTransaction st $ \db ->
createNewMessage_ db newMsg
@ -1646,13 +1692,13 @@ createSndMsgDelivery st sndMsgDelivery messageId =
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m Message
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m MessageId
createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery =
liftIO . withTransaction st $ \db -> do
msg@Message {msgId} <- createNewMessage_ db newMsg
msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery msgId
messageId <- createNewMessage_ db newMsg
msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery messageId
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent
pure msg
pure messageId
createSndMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> m ()
createSndMsgDeliveryEvent st connId agentMsgId sndMsgDeliveryStatus =
@ -1666,18 +1712,17 @@ createRcvMsgDeliveryEvent st connId agentMsgId rcvMsgDeliveryStatus =
msgDeliveryId <- ExceptT $ getMsgDeliveryId_ db connId agentMsgId
liftIO $ createMsgDeliveryEvent_ db msgDeliveryId rcvMsgDeliveryStatus
createNewMessage_ :: DB.Connection -> NewMessage -> IO Message
createNewMessage_ db NewMessage {direction, cmEventTag, chatTs, msgBody} = do
createNewMessage_ :: DB.Connection -> NewMessage -> IO MessageId
createNewMessage_ db NewMessage {direction, cmEventTag, msgBody} = do
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages
(msg_sent, chat_msg_event, chat_ts, msg_body, created_at) VALUES (?,?,?,?,?);
(msg_sent, chat_msg_event, msg_body, created_at) VALUES (?,?,?,?);
|]
(direction, cmEventTag, chatTs, msgBody, createdAt)
msgId <- insertedRowId db
pure Message {msgId, direction, cmEventTag, chatTs, msgBody, createdAt}
(direction, cmEventTag, msgBody, createdAt)
insertedRowId db
createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId = do
@ -1767,6 +1812,72 @@ deletePendingGroupMessage st groupMemberId messageId =
liftIO . withTransaction st $ \db ->
DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId)
createNewChatItem :: MonadUnliftIO m => SQLiteStore -> UserId -> ChatDirection c d -> NewChatItem d -> m ChatItemId
createNewChatItem st userId chatDirection NewChatItem {createdByMsgId_, itemSent, itemTs, itemContent, itemText, createdAt} =
liftIO . withTransaction st $ \db -> do
let (contactId_, groupId_, groupMemberId_) = ids
DB.execute
db
[sql|
INSERT INTO chat_items (
user_id, contact_id, group_id, group_member_id,
created_by_msg_id, item_sent, item_ts, item_content, item_text, created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
( (userId, contactId_, groupId_, groupMemberId_)
:. (createdByMsgId_, itemSent, itemTs, itemContent, itemText, createdAt, createdAt)
)
ciId <- insertedRowId db
when (isJust createdByMsgId_) $
DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id) VALUES (?,?)" (ciId, fromJust createdByMsgId_)
pure ciId
where
ids :: (Maybe Int64, Maybe Int64, Maybe Int64)
ids = case chatDirection of
CDDirect Contact {contactId} -> (Just contactId, Nothing, Nothing)
CDSndGroup GroupInfo {groupId} -> (Nothing, Just groupId, Nothing)
CDRcvGroup GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId)
-- getDirectChatItemList :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m ChatItemList
-- getDirectChatItemList st userId contactId =
-- liftIO . withTransaction st $ \db ->
-- DB.query
-- db
-- [sql|
-- ...
-- |]
-- (userId, contactId)
-- getGroupChatItemList :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m ChatItemList
-- getGroupChatItemList st userId groupId =
-- liftIO . withTransaction st $ \db ->
-- DB.query
-- db
-- [sql|
-- ...
-- |]
-- (userId, groupId)
-- getChatInfoList :: MonadUnliftIO m => SQLiteStore -> UserId -> m [ChatInfo]
-- getChatInfoList st userId =
-- liftIO . withTransaction st $ \db ->
-- DB.query
-- db
-- [sql|
-- ...
-- |]
-- (Only userId)
-- getChatItemsMixed :: MonadUnliftIO m => SQLiteStore -> UserId -> m [AnyChatItem]
-- getChatItemsMixed st userId =
-- liftIO . withTransaction st $ \db ->
-- DB.query
-- db
-- [sql|
-- ...
-- |]
-- (Only userId)
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
-- This function should be called inside transaction.
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)

102
src/Simplex/Chat/Types.hs
View file

@ -13,6 +13,7 @@ module Simplex.Chat.Types where
import Data.Aeson (FromJSON, ToJSON, (.:), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
@ -56,7 +57,7 @@ data User = User
}
deriving (Show, Generic, FromJSON)
instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
type UserId = Int64
@ -95,22 +96,19 @@ type ContactName = Text
type GroupName = Text
data Group = Group
{ groupId :: Int64,
localDisplayName :: GroupName,
groupProfile :: GroupProfile,
members :: [GroupMember],
membership :: GroupMember
}
data Group = Group GroupInfo [GroupMember]
deriving (Eq, Show)
data GroupInfo = GroupInfo
{ groupId :: Int64,
localDisplayName :: GroupName,
groupProfile :: GroupProfile,
userMemberStatus :: GroupMemberStatus
membership :: GroupMember
}
deriving (Show)
deriving (Eq, Show)
groupName :: GroupInfo -> GroupName
groupName GroupInfo {localDisplayName = g} = g
data Profile = Profile
{ displayName :: ContactName,
@ -118,7 +116,7 @@ data Profile = Profile
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON Profile where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON Profile where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data GroupProfile = GroupProfile
{ displayName :: GroupName,
@ -126,7 +124,7 @@ data GroupProfile = GroupProfile
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data GroupInvitation = GroupInvitation
{ fromMember :: MemberIdRole,
@ -136,7 +134,7 @@ data GroupInvitation = GroupInvitation
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON GroupInvitation where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON GroupInvitation where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data MemberIdRole = MemberIdRole
{ memberId :: MemberId,
@ -144,7 +142,7 @@ data MemberIdRole = MemberIdRole
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data IntroInvitation = IntroInvitation
{ groupConnReq :: ConnReqInvitation,
@ -152,7 +150,7 @@ data IntroInvitation = IntroInvitation
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON IntroInvitation where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON IntroInvitation where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data MemberInfo = MemberInfo
{ memberId :: MemberId,
@ -161,7 +159,7 @@ data MemberInfo = MemberInfo
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON MemberInfo where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON MemberInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
memberInfo :: GroupMember -> MemberInfo
memberInfo GroupMember {memberId, memberRole, memberProfile} =
@ -169,9 +167,8 @@ memberInfo GroupMember {memberId, memberRole, memberProfile} =
data ReceivedGroupInvitation = ReceivedGroupInvitation
{ fromMember :: GroupMember,
userMember :: GroupMember,
connRequest :: ConnReqInvitation,
groupProfile :: GroupProfile
groupInfo :: GroupInfo
}
deriving (Eq, Show)
@ -418,7 +415,7 @@ data SndFileTransfer = SndFileTransfer
chunkSize :: Integer,
recipientDisplayName :: ContactName,
connId :: Int64,
agentConnId :: ConnId,
agentConnId :: AgentConnId,
fileStatus :: FileStatus
}
deriving (Eq, Show)
@ -456,7 +453,9 @@ data RcvFileTransfer = RcvFileTransfer
senderDisplayName :: ContactName,
chunkSize :: Integer
}
deriving (Eq, Show)
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data RcvFileStatus
= RFSNew
@ -466,13 +465,65 @@ data RcvFileStatus
| RFSCancelled RcvFileInfo
deriving (Eq, Show)
instance FromJSON RcvFileStatus where
parseJSON = J.withObject "RcvFileStatus" $ \v -> do
let rfs mk = mk <$> v .: "fileInfo"
v .: "status" >>= \case
("new" :: Text) -> pure RFSNew
"accepted" -> rfs RFSAccepted
"connected" -> rfs RFSConnected
"complete" -> rfs RFSComplete
"cancelled" -> rfs RFSCancelled
_ -> fail "bad RcvFileStatus"
instance ToJSON RcvFileStatus where
toJSON s = J.object $ ["status" .= rfsTag s, "fileInfo" .= rfsInfo s]
toEncoding s = J.pairs $ ("status" .= rfsTag s <> "fileInfo" .= rfsInfo s)
rfsTag :: RcvFileStatus -> Text
rfsTag = \case
RFSNew -> "new"
RFSAccepted _ -> "accepted"
RFSConnected _ -> "connected"
RFSComplete _ -> "complete"
RFSCancelled _ -> "cancelled"
rfsInfo :: RcvFileStatus -> Maybe RcvFileInfo
rfsInfo = \case
RFSNew -> Nothing
RFSAccepted info -> Just info
RFSConnected info -> Just info
RFSComplete info -> Just info
RFSCancelled info -> Just info
data RcvFileInfo = RcvFileInfo
{ filePath :: FilePath,
connId :: Int64,
agentConnId :: ConnId
agentConnId :: AgentConnId
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON RcvFileInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
newtype AgentConnId = AgentConnId ConnId
deriving (Eq, Show)
instance StrEncoding AgentConnId where
strEncode (AgentConnId connId) = strEncode connId
strDecode s = AgentConnId <$> strDecode s
strP = AgentConnId <$> strP
instance FromJSON AgentConnId where
parseJSON = strParseJSON "AgentConnId"
instance ToJSON AgentConnId where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromField AgentConnId where fromField f = AgentConnId <$> fromField f
instance ToField AgentConnId where toField (AgentConnId m) = toField m
data FileTransfer = FTSnd [SndFileTransfer] | FTRcv RcvFileTransfer
deriving (Show)
@ -482,6 +533,13 @@ instance FromField FileStatus where fromField = fromTextField_ fileStatusT
instance ToField FileStatus where toField = toField . serializeFileStatus
instance FromJSON FileStatus where
parseJSON = J.withText "FileStatus" $ maybe (fail "bad FileStatus") pure . fileStatusT
instance ToJSON FileStatus where
toJSON = J.String . serializeFileStatus
toEncoding = JE.text . serializeFileStatus
fileStatusT :: Text -> Maybe FileStatus
fileStatusT = \case
"new" -> Just FSNew
@ -634,8 +692,6 @@ serializeIntroStatus = \case
GMIntroToConnected -> "to-con"
GMIntroConnected -> "con"
type MessageId = Int64
data Notification = Notification {title :: Text, text :: Text}
type JSONString = String

149
src/Simplex/Chat/View.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@ -32,14 +33,7 @@ serializeChatResponse = unlines . map unStyle . responseToView ""
responseToView :: String -> ChatResponse -> [StyledString]
responseToView cmd = \case
CRSentMessage c mc meta -> viewSentMessage (ttyToContact c) mc meta
CRSentGroupMessage g mc meta -> viewSentMessage (ttyToGroup g) mc meta
CRSentFileInvitation c fId fPath meta -> viewSentFileInvitation (ttyToContact c) fId fPath meta
CRSentGroupFileInvitation g fId fPath meta -> viewSentFileInvitation (ttyToGroup g) fId fPath meta
CRReceivedMessage c meta mc mOk -> viewReceivedMessage (ttyFromContact c) meta mc mOk
CRReceivedGroupMessage g c meta mc mOk -> viewReceivedMessage (ttyFromGroup g c) meta mc mOk
CRReceivedFileInvitation c meta ft mOk -> viewReceivedFileInvitation (ttyFromContact c) meta ft mOk
CRReceivedGroupFileInvitation g c meta ft mOk -> viewReceivedFileInvitation (ttyFromGroup g c) meta ft mOk
CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item
CRCommandAccepted _ -> r []
CRChatHelp section -> case section of
HSMain -> r chatHelpInfo
@ -54,7 +48,7 @@ responseToView cmd = \case
CRGroupCreated g -> r $ viewGroupCreated g
CRGroupMembers g -> r $ viewGroupMembers g
CRGroupsList gs -> r $ viewGroupsList gs
CRSentGroupInvitation g c -> r ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
CRSentGroupInvitation g c -> r ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c]
CRFileTransferStatus ftStatus -> r $ viewFileTransferStatus ftStatus
CRUserProfile p -> r $ viewUserProfile p
CRUserProfileNoChange -> r ["user profile did not change"]
@ -67,10 +61,10 @@ responseToView cmd = \case
CRAcceptingContactRequest c -> r' [ttyContact c <> ": accepting contact request..."]
CRUserContactLinkCreated cReq -> r' $ connReqContact_ "Your new chat address is created!" cReq
CRUserContactLinkDeleted -> r' viewUserContactLinkDeleted
CRUserAcceptedGroupSent _gn -> r' [] -- [ttyGroup g <> ": joining the group..."]
CRUserDeletedMember g m -> r' [ttyGroup g <> ": you removed " <> ttyMember m <> " from the group"]
CRLeftMemberUser g -> r' $ [ttyGroup g <> ": you left the group"] <> groupPreserved g
CRGroupDeletedUser g -> r' [ttyGroup g <> ": you deleted the group"]
CRUserAcceptedGroupSent _g -> r' [] -- [ttyGroup' g <> ": joining the group..."]
CRUserDeletedMember g m -> r' [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"]
CRLeftMemberUser g -> r' $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
CRGroupDeletedUser g -> r' [ttyGroup' g <> ": you deleted the group"]
CRRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath ->
r' ["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
CRRcvFileAcceptedSndCancelled ft -> r' $ viewRcvFileSndCancelled ft
@ -89,24 +83,24 @@ responseToView cmd = \case
CRSndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} ->
[ttyContact c <> " cancelled receiving " <> sndFile ft]
CRContactConnected ct -> [ttyFullContact ct <> ": contact is connected"]
CRContactAnotherClient c -> [ttyContact c <> ": contact is connected to another client"]
CRContactDisconnected c -> [ttyContact c <> ": disconnected from server (messages will be queued)"]
CRContactSubscribed c -> [ttyContact c <> ": connected to server"]
CRContactSubError c e -> [ttyContact c <> ": contact error " <> sShow e]
CRGroupInvitation Group {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} ->
CRContactAnotherClient c -> [ttyContact' c <> ": contact is connected to another client"]
CRContactDisconnected c -> [ttyContact' c <> ": disconnected from server (messages will be queued)"]
CRContactSubscribed c -> [ttyContact' c <> ": connected to server"]
CRContactSubError c e -> [ttyContact' c <> ": contact error " <> sShow e]
CRGroupInvitation GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} ->
[groupInvitation ldn fullName]
CRReceivedGroupInvitation g c role -> viewReceivedGroupInvitation g c role
CRUserJoinedGroup g -> [ttyGroup g <> ": you joined the group"]
CRJoinedGroupMember g m -> [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
CRJoinedGroupMemberConnecting g host m -> [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
CRConnectedToGroupMember g m -> [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
CRDeletedMemberUser g by -> [ttyGroup g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g
CRDeletedMember g by m -> [ttyGroup g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"]
CRLeftMember g m -> [ttyGroup g <> ": " <> ttyMember m <> " left the group"]
CRUserJoinedGroup g -> [ttyGroup' g <> ": you joined the group"]
CRJoinedGroupMember g m -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "]
CRJoinedGroupMemberConnecting g host m -> [ttyGroup' g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
CRConnectedToGroupMember g m -> [ttyGroup' g <> ": " <> connectedMember m <> " is connected"]
CRDeletedMemberUser g by -> [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group"] <> groupPreserved g
CRDeletedMember g by m -> [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group"]
CRLeftMember g m -> [ttyGroup' g <> ": " <> ttyMember m <> " left the group"]
CRGroupEmpty g -> [ttyFullGroup g <> ": group is empty"]
CRGroupRemoved g -> [ttyFullGroup g <> ": you are no longer a member or group deleted"]
CRGroupDeleted gn m -> [ttyGroup gn <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> gn) <> " to delete the local copy of the group"]
CRMemberSubError gn c e -> [ttyGroup gn <> " member " <> ttyContact c <> " error: " <> sShow e]
CRGroupDeleted g m -> [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName g) <> " to delete the local copy of the group"]
CRMemberSubError g c e -> [ttyGroup' g <> " member " <> ttyContact c <> " error: " <> sShow e]
CRGroupSubscribed g -> [ttyFullGroup g <> ": connected to server(s)"]
CRSndFileSubError SndFileTransfer {fileId, fileName} e ->
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
@ -121,6 +115,33 @@ responseToView cmd = \case
-- this function should be `id` in case of asynchronous command responses
r' = r
viewChatItem :: ChatInfo c -> ChatItem c d -> [StyledString]
viewChatItem chat item = case (chat, item) of
(DirectChat c, DirectChatItem ciMeta content) -> case ciMeta of
CISndMeta meta -> case content of
CIMsgContent mc -> viewSentMessage to mc meta
CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
CIRcvMeta meta mOk -> case content of
CIMsgContent mc -> viewReceivedMessage from meta mc mOk
CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft mOk
where
to = ttyToContact' c
from = ttyFromContact' c
(GroupChat g, SndGroupChatItem (CISndMeta meta) content) -> case content of
CIMsgContent mc -> viewSentMessage to mc meta
CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
where
to = ttyToGroup g
(GroupChat g, RcvGroupChatItem c (CIRcvMeta meta mOk) content) -> case content of
CIMsgContent mc -> viewReceivedMessage from meta mc mOk
CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft mOk
where
from = ttyFromGroup' g c
where
ttyToContact' Contact {localDisplayName = c} = ttyToContact c
ttyFromContact' Contact {localDisplayName = c} = ttyFromContact c
ttyFromGroup' g GroupMember {localDisplayName = c} = ttyFromGroup g c
viewInvalidConnReq :: [StyledString]
viewInvalidConnReq =
[ "",
@ -167,26 +188,26 @@ viewReceivedContactRequest c Profile {fullName} =
"to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)"
]
viewGroupCreated :: Group -> [StyledString]
viewGroupCreated g@Group {localDisplayName} =
viewGroupCreated :: GroupInfo -> [StyledString]
viewGroupCreated g@GroupInfo {localDisplayName} =
[ "group " <> ttyFullGroup g <> " is created",
"use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members"
]
viewCannotResendInvitation :: GroupName -> ContactName -> [StyledString]
viewCannotResendInvitation g c =
[ ttyContact c <> " is already invited to group " <> ttyGroup g,
"to re-send invitation: " <> highlight ("/rm " <> g <> " " <> c) <> ", " <> highlight ("/a " <> g <> " " <> c)
viewCannotResendInvitation :: GroupInfo -> ContactName -> [StyledString]
viewCannotResendInvitation GroupInfo {localDisplayName = gn} c =
[ ttyContact c <> " is already invited to group " <> ttyGroup gn,
"to re-send invitation: " <> highlight ("/rm " <> gn <> " " <> c) <> ", " <> highlight ("/a " <> gn <> " " <> c)
]
viewReceivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString]
viewReceivedGroupInvitation g@Group {localDisplayName} c role =
[ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (strEncode role),
"use " <> highlight ("/j " <> localDisplayName) <> " to accept"
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
viewReceivedGroupInvitation g c role =
[ ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role),
"use " <> highlight ("/j " <> groupName g) <> " to accept"
]
groupPreserved :: GroupName -> [StyledString]
groupPreserved g = ["use " <> highlight ("/d #" <> g) <> " to delete the group"]
groupPreserved :: GroupInfo -> [StyledString]
groupPreserved g = ["use " <> highlight ("/d #" <> groupName g) <> " to delete the group"]
connectedMember :: GroupMember -> StyledString
connectedMember m = case memberCategory m of
@ -195,7 +216,7 @@ connectedMember m = case memberCategory m of
_ -> "member " <> ttyMember m -- these case is not used
viewGroupMembers :: Group -> [StyledString]
viewGroupMembers Group {membership, members} = map groupMember . filter (not . removedOrLeft) $ membership : members
viewGroupMembers (Group GroupInfo {membership} members) = map groupMember . filter (not . removedOrLeft) $ membership : members
where
removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft
groupMember m = ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m
@ -219,8 +240,8 @@ viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <nam
viewGroupsList gs = map groupSS $ sortOn ldn_ gs
where
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName)
groupSS GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, userMemberStatus} =
case userMemberStatus of
groupSS GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership} =
case memberStatus membership of
GSMemInvited -> groupInvitation ldn fullName
_ -> ttyGroup ldn <> optFullName ldn fullName
@ -268,17 +289,17 @@ viewContactUpdated
where
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
viewReceivedMessage :: StyledString -> ChatMsgMeta -> MsgContent -> MsgIntegrity -> [StyledString]
viewReceivedMessage :: StyledString -> CIMetaProps -> MsgContent -> MsgIntegrity -> [StyledString]
viewReceivedMessage from meta mc = receivedWithTime_ from meta (ttyMsgContent mc)
receivedWithTime_ :: StyledString -> ChatMsgMeta -> [StyledString] -> MsgIntegrity -> [StyledString]
receivedWithTime_ from ChatMsgMeta {localChatTs, createdAt} styledMsg mOk = do
receivedWithTime_ :: StyledString -> CIMetaProps -> [StyledString] -> MsgIntegrity -> [StyledString]
receivedWithTime_ from CIMetaProps {localItemTs, createdAt} styledMsg mOk = do
prependFirst (formattedTime <> " " <> from) styledMsg ++ showIntegrity mOk
where
formattedTime :: StyledString
formattedTime =
let localTime = zonedTimeToLocalTime localChatTs
tz = zonedTimeZone localChatTs
let localTime = zonedTimeToLocalTime localItemTs
tz = zonedTimeZone localItemTs
format =
if (localDay localTime < localDay (zonedTimeToLocalTime $ utcToZonedTime tz createdAt))
&& (timeOfDayToTime (localTimeOfDay localTime) > (6 * 60 * 60 :: DiffTime))
@ -297,15 +318,15 @@ receivedWithTime_ from ChatMsgMeta {localChatTs, createdAt} styledMsg mOk = do
msgError :: String -> [StyledString]
msgError s = [styled (Colored Red) s]
viewSentMessage :: StyledString -> MsgContent -> ChatMsgMeta -> [StyledString]
viewSentMessage :: StyledString -> MsgContent -> CIMetaProps -> [StyledString]
viewSentMessage to = sentWithTime_ . prependFirst to . ttyMsgContent
viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> ChatMsgMeta -> [StyledString]
viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> CIMetaProps -> [StyledString]
viewSentFileInvitation to fId fPath = sentWithTime_ $ ttySentFile to fId fPath
sentWithTime_ :: [StyledString] -> ChatMsgMeta -> [StyledString]
sentWithTime_ styledMsg ChatMsgMeta {localChatTs} =
prependFirst (ttyMsgTime localChatTs <> " ") styledMsg
sentWithTime_ :: [StyledString] -> CIMetaProps -> [StyledString]
sentWithTime_ styledMsg CIMetaProps {localItemTs} =
prependFirst (ttyMsgTime localItemTs <> " ") styledMsg
ttyMsgTime :: ZonedTime -> StyledString
ttyMsgTime = styleTime . formatTime defaultTimeLocale "%H:%M"
@ -342,7 +363,7 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
sndFile :: SndFileTransfer -> StyledString
sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName
viewReceivedFileInvitation :: StyledString -> ChatMsgMeta -> RcvFileTransfer -> MsgIntegrity -> [StyledString]
viewReceivedFileInvitation :: StyledString -> CIMetaProps -> RcvFileTransfer -> MsgIntegrity -> [StyledString]
viewReceivedFileInvitation from meta ft = receivedWithTime_ from meta (receivedFileInvitation_ ft)
receivedFileInvitation_ :: RcvFileTransfer -> [StyledString]
@ -425,7 +446,7 @@ viewChatError = \case
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
CEGroupUserRole -> ["you have insufficient permissions for this group command"]
CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]
CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> g)]
CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> groupName g)]
CEGroupMemberNotActive -> ["you cannot invite other members yet, try later"]
CEGroupMemberUserRemoved -> ["you are no longer a member of the group"]
CEGroupMemberNotFound c -> ["contact " <> ttyContact c <> " is not a group member"]
@ -466,6 +487,9 @@ viewChatError = \case
ttyContact :: ContactName -> StyledString
ttyContact = styled (Colored Green)
ttyContact' :: Contact -> StyledString
ttyContact' Contact {localDisplayName = c} = ttyContact c
ttyFullContact :: Contact -> StyledString
ttyFullContact Contact {localDisplayName, profile = Profile {fullName}} =
ttyFullName localDisplayName fullName
@ -489,20 +513,23 @@ ttyFromContact c = styled (Colored Yellow) $ c <> "> "
ttyGroup :: GroupName -> StyledString
ttyGroup g = styled (Colored Blue) $ "#" <> g
ttyGroup' :: GroupInfo -> StyledString
ttyGroup' = ttyGroup . groupName
ttyGroups :: [GroupName] -> StyledString
ttyGroups [] = ""
ttyGroups [g] = ttyGroup g
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
ttyFullGroup :: Group -> StyledString
ttyFullGroup Group {localDisplayName, groupProfile = GroupProfile {fullName}} =
ttyGroup localDisplayName <> optFullName localDisplayName fullName
ttyFullGroup :: GroupInfo -> StyledString
ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} =
ttyGroup g <> optFullName g fullName
ttyFromGroup :: GroupName -> ContactName -> StyledString
ttyFromGroup g c = styled (Colored Yellow) $ "#" <> g <> " " <> c <> "> "
ttyFromGroup :: GroupInfo -> ContactName -> StyledString
ttyFromGroup GroupInfo {localDisplayName = g} c = styled (Colored Yellow) $ "#" <> g <> " " <> c <> "> "
ttyToGroup :: GroupName -> StyledString
ttyToGroup g = styled (Colored Cyan) $ "#" <> g <> " "
ttyToGroup :: GroupInfo -> StyledString
ttyToGroup GroupInfo {localDisplayName = g} = styled (Colored Cyan) $ "#" <> g <> " "
ttyFilePath :: FilePath -> StyledString
ttyFilePath = plain