diff --git a/simplex-chat.cabal b/simplex-chat.cabal index a46f972ce0..17e5cc734d 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index ba0df44512..cab1767d05 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 692f917349..afff5ae9aa 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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 diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 99ce67a12d..2f86c8c2ed 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -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} = diff --git a/src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs b/src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs index 81e81c7d7a..c432b19f15 100644 --- a/src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs +++ b/src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs @@ -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; |] diff --git a/src/Simplex/Chat/Migrations/M20220125_chat_items.hs b/src/Simplex/Chat/Migrations/M20220125_chat_items.hs new file mode 100644 index 0000000000..38196e94d8 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220125_chat_items.hs @@ -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; +|] diff --git a/src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListDirect.sql b/src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListDirect.sql new file mode 100644 index 0000000000..bc5279d517 --- /dev/null +++ b/src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListDirect.sql @@ -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 diff --git a/src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListGroup.sql b/src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListGroup.sql new file mode 100644 index 0000000000..e1fbd4db55 --- /dev/null +++ b/src/Simplex/Chat/Migrations/chat_item_queries/getChatInfoListGroup.sql @@ -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 diff --git a/src/Simplex/Chat/Migrations/chat_item_queries/getChatItemsMixed.sql b/src/Simplex/Chat/Migrations/chat_item_queries/getChatItemsMixed.sql new file mode 100644 index 0000000000..f537cee929 --- /dev/null +++ b/src/Simplex/Chat/Migrations/chat_item_queries/getChatItemsMixed.sql @@ -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 diff --git a/src/Simplex/Chat/Migrations/chat_item_queries/getDirectChatItemList.sql b/src/Simplex/Chat/Migrations/chat_item_queries/getDirectChatItemList.sql new file mode 100644 index 0000000000..eb6426ba96 --- /dev/null +++ b/src/Simplex/Chat/Migrations/chat_item_queries/getDirectChatItemList.sql @@ -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 diff --git a/src/Simplex/Chat/Migrations/chat_item_queries/getGroupChatItemList.sql b/src/Simplex/Chat/Migrations/chat_item_queries/getGroupChatItemList.sql new file mode 100644 index 0000000000..5e35a9b095 --- /dev/null +++ b/src/Simplex/Chat/Migrations/chat_item_queries/getGroupChatItemList.sql @@ -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 diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 2873da060f..fe667fac7d 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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 diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index d53b0af769..2c39f09143 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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) diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 79bd105c52..1bfcdfe32b 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 3b78e9bcb7..8ae4758537 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 <> " ") <> " 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 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