lovely-projects/simplex-chat
lovely-projects/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-03-14 09:45:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

started chat model (#221)

Browse source 
* started chat model

* refactor processing commands and UI events

* message chat event processing

* groups: delayed delivery of messages and introductions to announced members (#217)

* combine migrations, rename fields

* show all view messages vis ChatResponse type

* serialize chat response

* update C api

* remove unused extensions, fix typos

Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2022-01-24 16:07:17 +00:00 • committed by GitHub
parent a5ad0b185c
commit b38d5f3465
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
18 changed files with 1000 additions and 758 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

67
apps/ios/Shared/Model/ChatModel.swift Normal file
View file

@ -0,0 +1,67 @@
//
// ChatModel.swift
// SimpleX
//
// Created by Evgeny Poberezkin on 22/01/2022.
// Copyright © 2022 SimpleX Chat. All rights reserved.
//
import Foundation
import Combine
import SwiftUI
final class ChatModel: ObservableObject {
@Published var currentUser: User?
@Published var channels: [ChatChannel] = []
}
struct User: Codable {
var userId: Int64
var userContactId: Int64
var localDisplayName: ContactName
var profile: Profile
var activeUser: Bool
}
typealias ContactName = String
typealias GroupName = String
struct Profile: Codable {
var displayName: String
var fullName: String
}
enum ChatChannel {
case contact(ContactInfo, [ChatMessage])
case group(GroupInfo, [ChatMessage])
}
struct ContactInfo: Codable {
var contactId: Int64
var localDisplayName: ContactName
var profile: Profile
var viaGroup: Int64?
}
struct GroupInfo: Codable {
var groupId: Int64
var localDisplayName: GroupName
var groupProfile: GroupProfile
}
struct GroupProfile: Codable {
var displayName: String
var fullName: String
}
struct ChatMessage {
var from: ContactInfo?
var ts: Date
var content: MsgContent
}
enum MsgContent {
case text(String)
case unknown
}

14
apps/ios/SimpleX.xcodeproj/project.pbxproj
View file

@ -21,6 +21,8 @@
5C764E83279C748B000C6508 /* libz.tbd in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C764E7C279C71DB000C6508 /* libz.tbd */; };
5C764E84279C748C000C6508 /* libiconv.tbd in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C764E7B279C71D4000C6508 /* libiconv.tbd */; };
5C764E85279C748C000C6508 /* libz.tbd in Frameworks */ = {isa = PBXBuildFile; fileRef = 5C764E7C279C71DB000C6508 /* libz.tbd */; };
5C764E89279CBCB3000C6508 /* ChatModel.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5C764E88279CBCB3000C6508 /* ChatModel.swift */; };
5C764E8A279CBCB3000C6508 /* ChatModel.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5C764E88279CBCB3000C6508 /* ChatModel.swift */; };
5CA059DC279559F40002BEB4 /* Tests_iOS.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059DB279559F40002BEB4 /* Tests_iOS.swift */; };
5CA059DE279559F40002BEB4 /* Tests_iOSLaunchTests.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059DD279559F40002BEB4 /* Tests_iOSLaunchTests.swift */; };
5CA059E8279559F40002BEB4 /* Tests_macOS.swift in Sources */ = {isa = PBXBuildFile; fileRef = 5CA059E7279559F40002BEB4 /* Tests_macOS.swift */; };
@ -64,6 +66,7 @@
5C764E7D279C7275000C6508 /* SimpleX (iOS)-Bridging-Header.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = "SimpleX (iOS)-Bridging-Header.h"; sourceTree = "<group>"; };
5C764E7E279C7275000C6508 /* SimpleX (macOS)-Bridging-Header.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = "SimpleX (macOS)-Bridging-Header.h"; sourceTree = "<group>"; };
5C764E7F279C7276000C6508 /* dummy.m */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.objc; path = dummy.m; sourceTree = "<group>"; };
5C764E88279CBCB3000C6508 /* ChatModel.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ChatModel.swift; sourceTree = "<group>"; };
5CA059C3279559F40002BEB4 /* SimpleXApp.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = SimpleXApp.swift; sourceTree = "<group>"; };
5CA059C4279559F40002BEB4 /* ContentView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ContentView.swift; sourceTree = "<group>"; };
5CA059C5279559F40002BEB4 /* Assets.xcassets */ = {isa = PBXFileReference; lastKnownFileType = folder.assetcatalog; path = Assets.xcassets; sourceTree = "<group>"; };
@ -143,6 +146,14 @@
name = Frameworks;
sourceTree = "<group>";
};
5C764E87279CBC8E000C6508 /* Model */ = {
isa = PBXGroup;
children = (
5C764E88279CBCB3000C6508 /* ChatModel.swift */,
);
path = Model;
sourceTree = "<group>";
};
5CA059BD279559F40002BEB4 = {
isa = PBXGroup;
children = (
@ -159,6 +170,7 @@
5CA059C2279559F40002BEB4 /* Shared */ = {
isa = PBXGroup;
children = (
5C764E87279CBC8E000C6508 /* Model */,
5CA059C3279559F40002BEB4 /* SimpleXApp.swift */,
5C764E7F279C7276000C6508 /* dummy.m */,
5CA059C4279559F40002BEB4 /* ContentView.swift */,
@ -373,6 +385,7 @@
5CA059ED279559F40002BEB4 /* ContentView.swift in Sources */,
5CA05A4C27974EB60002BEB4 /* ProfileView.swift in Sources */,
5CA059EB279559F40002BEB4 /* SimpleXApp.swift in Sources */,
5C764E89279CBCB3000C6508 /* ChatModel.swift in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
@ -385,6 +398,7 @@
5CA059EE279559F40002BEB4 /* ContentView.swift in Sources */,
5CA05A4D27974EB60002BEB4 /* ProfileView.swift in Sources */,
5CA059EC279559F40002BEB4 /* SimpleXApp.swift in Sources */,
5C764E8A279CBCB3000C6508 /* ChatModel.swift in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};

2
simplex-chat.cabal
View file

@ -23,7 +23,9 @@ library
Simplex.Chat.Controller
Simplex.Chat.Help
Simplex.Chat.Markdown
Simplex.Chat.Messages
Simplex.Chat.Migrations.M20220101_initial
Simplex.Chat.Migrations.M20220122_pending_group_messages
Simplex.Chat.Mobile
Simplex.Chat.Options
Simplex.Chat.Protocol

567
src/Simplex/Chat.hs
View file

@ -6,7 +6,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
@ -26,6 +25,7 @@ import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isSpace)
import Data.Foldable (for_)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (find)
@ -35,16 +35,16 @@ import Data.Maybe (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.LocalTime (utcToLocalZonedTime)
import Data.Word (Word32)
import Simplex.Chat.Controller
import Simplex.Chat.Help
import Simplex.Chat.Messages
import Simplex.Chat.Options (ChatOpts (..))
import Simplex.Chat.Protocol
import Simplex.Chat.Store
import Simplex.Chat.Styled
import Simplex.Chat.Types
import Simplex.Chat.Util (ifM, unlessM)
import Simplex.Chat.View
import Simplex.Chat.Util (ifM, safeDecodeUtf8, unlessM)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig)
import Simplex.Messaging.Agent.Protocol
@ -52,58 +52,20 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Protocol (CorrId (..), MsgBody)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util (raceAny_, tryError)
import Simplex.Messaging.Util (tryError)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath (combine, splitExtensions, takeFileName)
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout)
import Text.Read (readMaybe)
import UnliftIO.Async (race_)
import UnliftIO.Concurrent (forkIO, threadDelay)
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory)
import qualified UnliftIO.Exception as E
import UnliftIO.IO (hClose, hSeek, hTell)
import UnliftIO.STM
data ChatCommand
= ChatHelp
| FilesHelp
| GroupsHelp
| MyAddressHelp
| MarkdownHelp
| Welcome
| AddContact
| Connect (Maybe AConnectionRequestUri)
| ConnectAdmin
| DeleteContact ContactName
| ListContacts
| CreateMyAddress
| DeleteMyAddress
| ShowMyAddress
| AcceptContact ContactName
| RejectContact ContactName
| SendMessage ContactName ByteString
| NewGroup GroupProfile
| AddMember GroupName ContactName GroupMemberRole
| JoinGroup GroupName
| RemoveMember GroupName ContactName
| MemberRole GroupName ContactName GroupMemberRole
| LeaveGroup GroupName
| DeleteGroup GroupName
| ListMembers GroupName
| ListGroups
| SendGroupMessage GroupName ByteString
| SendFile ContactName FilePath
| SendGroupFile GroupName FilePath
| ReceiveFile Int64 (Maybe FilePath)
| CancelFile Int64
| FileStatus Int64
| UpdateProfile Profile
| ShowProfile
| QuitChat
| ShowVersion
deriving (Show)
defaultChatConfig :: ChatConfig
defaultChatConfig =
ChatConfig
@ -138,103 +100,92 @@ newChatController chatStore user config@ChatConfig {agentConfig = cfg, tbqSize}
rcvFiles <- newTVarIO M.empty
pure ChatController {activeTo, firstTime, currentUser, smpAgent, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification}
runChatController :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m ()
runChatController = do
q <- asks outputQ
let toView = atomically . writeTBQueue q
raceAny_
[ inputSubscriber toView,
agentSubscriber toView,
notificationSubscriber
]
runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
runChatController = race_ agentSubscriber notificationSubscriber
withLock :: MonadUnliftIO m => TMVar () -> m () -> m ()
withLock :: MonadUnliftIO m => TMVar () -> m a -> m a
withLock lock =
E.bracket_
(void . atomically $ takeTMVar lock)
(atomically $ putTMVar lock ())
inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
inputSubscriber toView = do
q <- asks inputQ
l <- asks chatLock
a <- asks smpAgent
forever $
atomically (readTBQueue q) >>= \case
InputControl _ -> pure ()
InputCommand s ->
case parseAll chatCommandP . B.dropWhileEnd isSpace . encodeUtf8 $ T.pack s of
Left e -> toView [plain s, "invalid input: " <> plain e]
Right cmd -> do
case cmd of
SendMessage c msg -> toView =<< liftIO (viewSentMessage c msg)
SendGroupMessage g msg -> toView =<< liftIO (viewSentGroupMessage g msg)
SendFile c f -> toView =<< liftIO (viewSentFileInvitation c f)
SendGroupFile g f -> toView =<< liftIO (viewSentGroupFileInvitation g f)
_ -> toView [plain s]
user <- readTVarIO =<< asks currentUser
withAgentLock a . withLock l . void . runExceptT $
processChatCommand toView' user cmd `catchError` (toView' . viewChatError)
where
toView' = ExceptT . fmap Right . toView
execChatCommand :: (MonadUnliftIO m, MonadReader ChatController m) => String -> m ChatResponse
execChatCommand s = case parseAll chatCommandP . B.dropWhileEnd isSpace . encodeUtf8 $ T.pack s of
Left e -> pure . CRChatError . ChatError $ CECommandError e
Right cmd -> do
ChatController {chatLock = l, smpAgent = a, currentUser} <- ask
user <- readTVarIO currentUser
withAgentLock a . withLock l $ either CRChatCmdError id <$> runExceptT (processChatCommand user cmd)
processChatCommand :: forall m. ChatMonad m => ([StyledString] -> m ()) -> User -> ChatCommand -> m ()
processChatCommand toView user@User {userId, profile} = \case
ChatHelp -> toView chatHelpInfo
FilesHelp -> toView filesHelpInfo
GroupsHelp -> toView groupsHelpInfo
MyAddressHelp -> toView myAddressHelpInfo
MarkdownHelp -> toView markdownInfo
Welcome -> toView $ chatWelcome user
AddContact -> do
toView :: ChatMonad m => ChatResponse -> m ()
toView event = do
q <- asks outputQ
atomically $ writeTBQueue q (CorrId "", event)
processChatCommand :: forall m. ChatMonad m => User -> ChatCommand -> m ChatResponse
processChatCommand user@User {userId, profile} = \case
ChatHelp section -> pure $ CRChatHelp section
Welcome -> pure $ CRWelcome user
AddContact -> procCmd $ do
(connId, cReq) <- withAgent (`createConnection` SCMInvitation)
withStore $ \st -> createDirectConnection st userId connId
toView $ viewConnReqInvitation cReq
Connect (Just (ACR SCMInvitation cReq)) -> connect cReq (XInfo profile) >> toView viewSentConfirmation
Connect (Just (ACR SCMContact cReq)) -> connect cReq (XContact profile Nothing) >> toView viewSentInvitation
Connect Nothing -> toView viewInvalidConnReq
ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> toView viewSentInvitation
pure $ CRInvitation cReq
Connect (Just (ACR SCMInvitation cReq)) -> procCmd $ do
connect cReq $ XInfo profile
pure CRSentConfirmation
Connect (Just (ACR SCMContact cReq)) -> procCmd $ do
connect cReq $ XContact profile Nothing
pure CRSentInvitation
Connect Nothing -> chatError CEInvalidConnReq
ConnectAdmin -> procCmd $ do
connect adminContactReq $ XContact profile Nothing
pure CRSentInvitation
DeleteContact cName ->
withStore (\st -> getContactGroupNames st userId cName) >>= \case
[] -> do
conns <- withStore $ \st -> getContactConnections st userId cName
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteContact st userId cName
unsetActive $ ActiveC cName
toView $ viewContactDeleted cName
gs -> toView $ viewContactGroups cName gs
ListContacts -> withStore (`getUserContacts` user) >>= toView . viewContactsList
CreateMyAddress -> do
procCmd $ do
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteContact st userId cName
unsetActive $ ActiveC cName
pure $ CRContactDeleted cName
gs -> chatError $ CEContactGroups cName gs
ListContacts -> CRContactsList <$> withStore (`getUserContacts` user)
CreateMyAddress -> procCmd $ do
(connId, cReq) <- withAgent (`createConnection` SCMContact)
withStore $ \st -> createUserContactLink st userId connId cReq
toView $ viewUserContactLinkCreated cReq
pure $ CRUserContactLinkCreated cReq
DeleteMyAddress -> do
conns <- withStore $ \st -> getUserContactLinkConnections st userId
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteUserContactLink st userId
toView viewUserContactLinkDeleted
ShowMyAddress -> do
cReq <- withStore $ \st -> getUserContactLink st userId
toView $ viewUserContactLink cReq
procCmd $ do
withAgent $ \a -> forM_ conns $ \Connection {agentConnId} ->
deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
withStore $ \st -> deleteUserContactLink st userId
pure CRUserContactLinkDeleted
ShowMyAddress -> CRUserContactLink <$> withStore (`getUserContactLink` userId)
AcceptContact cName -> do
UserContactRequest {agentInvitationId, profileId} <- withStore $ \st ->
getContactRequest st userId cName
connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile
withStore $ \st -> createAcceptedContact st userId connId cName profileId
toView $ viewAcceptingContactRequest cName
procCmd $ do
connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile
withStore $ \st -> createAcceptedContact st userId connId cName profileId
pure $ CRAcceptingContactRequest cName
RejectContact cName -> do
UserContactRequest {agentContactConnId, agentInvitationId} <- withStore $ \st ->
getContactRequest st userId cName
`E.finally` deleteContactRequest st userId cName
withAgent $ \a -> rejectContact a agentContactConnId agentInvitationId
toView $ viewContactRequestRejected cName
SendMessage cName msg -> sendMessageCmd cName msg
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)
setActive $ ActiveC cName
pure $ CRSentMessage cName msgContent meta
NewGroup gProfile -> do
gVar <- asks idsDrg
group <- withStore $ \st -> createNewGroup st gVar user gProfile
toView $ viewGroupCreated group
CRGroupCreated <$> withStore (\st -> createNewGroup st gVar user gProfile)
AddMember gName cName memRole -> do
(group, contact) <- withStore $ \st -> (,) <$> getGroup st user gName <*> getContact st userId cName
let Group {groupId, groupProfile, membership, members} = group
@ -243,10 +194,10 @@ processChatCommand toView user@User {userId, profile} = \case
when (memberStatus membership == GSMemInvited) $ chatError (CEGroupNotJoined gName)
unless (memberActive membership) $ chatError CEGroupMemberNotActive
let sendInvitation memberId cReq = do
sendDirectMessage (contactConn contact) $
void . sendDirectMessage (contactConn contact) $
XGrpInv $ GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
toView $ viewSentGroupInvitation gName cName
setActive $ ActiveG gName
pure $ CRSentGroupInvitation gName cName
case contactMember contact members of
Nothing -> do
gVar <- asks idsDrg
@ -257,16 +208,18 @@ processChatCommand toView user@User {userId, profile} = \case
| memberStatus == GSMemInvited ->
withStore (\st -> getMemberInvitation st user groupMemberId) >>= \case
Just cReq -> sendInvitation memberId cReq
Nothing -> toView $ viewCannotResendInvitation gName cName
| otherwise -> chatError (CEGroupDuplicateMember cName)
Nothing -> chatError $ CEGroupCantResendInvitation gName cName
| otherwise -> chatError $ CEGroupDuplicateMember cName
JoinGroup gName -> do
ReceivedGroupInvitation {fromMember, userMember, connRequest} <- withStore $ \st -> getGroupInvitation st user gName
agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (userMember :: GroupMember)
withStore $ \st -> do
createMemberConnection st userId fromMember agentConnId
updateGroupMemberStatus st userId fromMember GSMemAccepted
updateGroupMemberStatus st userId userMember GSMemAccepted
MemberRole _gName _cName _mRole -> pure ()
procCmd $ do
agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (userMember :: GroupMember)
withStore $ \st -> do
createMemberConnection st userId fromMember agentConnId
updateGroupMemberStatus st userId fromMember GSMemAccepted
updateGroupMemberStatus st userId userMember GSMemAccepted
pure $ CRUserAcceptedGroupSent gName
MemberRole _gName _cName _mRole -> chatError $ CECommandError "unsupported"
RemoveMember gName cName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
case find ((== cName) . (localDisplayName :: GroupMember -> ContactName)) members of
@ -274,16 +227,18 @@ processChatCommand toView user@User {userId, profile} = \case
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do
let userRole = memberRole (membership :: GroupMember)
when (userRole < GRAdmin || userRole < mRole) $ chatError CEGroupUserRole
when (mStatus /= GSMemInvited) . sendGroupMessage members $ XGrpMemDel mId
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved
toView $ viewDeletedMember gName Nothing (Just m)
procCmd $ do
when (mStatus /= GSMemInvited) . void . sendGroupMessage members $ XGrpMemDel mId
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved
pure $ CRUserDeletedMember gName m
LeaveGroup gName -> do
Group {membership, members} <- withStore $ \st -> getGroup st user gName
sendGroupMessage members XGrpLeave
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft
toView $ viewLeftMemberUser gName
procCmd $ do
void $ sendGroupMessage members XGrpLeave
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft
pure $ CRLeftMemberUser gName
DeleteGroup gName -> do
g@Group {membership, members} <- withStore $ \st -> getGroup st user gName
let s = memberStatus membership
@ -291,21 +246,21 @@ processChatCommand toView user@User {userId, profile} = \case
memberRole (membership :: GroupMember) == GROwner
|| (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited)
unless canDelete $ chatError CEGroupUserRole
when (memberActive membership) $ sendGroupMessage members XGrpDel
mapM_ deleteMemberConnection members
withStore $ \st -> deleteGroup st user g
toView $ viewGroupDeletedUser gName
ListMembers gName -> do
group <- withStore $ \st -> getGroup st user gName
toView $ viewGroupMembers group
ListGroups -> withStore (`getUserGroupDetails` userId) >>= toView . viewGroupsList
procCmd $ do
when (memberActive membership) . void $ sendGroupMessage members XGrpDel
mapM_ deleteMemberConnection members
withStore $ \st -> deleteGroup st user g
pure $ CRGroupDeletedUser gName
ListMembers gName -> CRGroupMembers <$> withStore (\st -> getGroup st user gName)
ListGroups -> CRGroupsList <$> withStore (`getUserGroupDetails` userId)
SendGroupMessage gName msg -> do
-- TODO save pending message delivery for members without connections
Group {members, membership} <- withStore $ \st -> getGroup st user gName
unless (memberActive membership) $ chatError CEGroupMemberUserRemoved
let msgEvent = XMsgNew . MCText $ safeDecodeUtf8 msg
sendGroupMessage members msgEvent
let msgContent = MCText $ safeDecodeUtf8 msg
meta <- liftIO . mkChatMsgMeta =<< sendGroupMessage members (XMsgNew msgContent)
setActive $ ActiveG gName
pure $ CRSentGroupMessage gName msgContent meta
SendFile cName f -> do
(fileSize, chSize) <- checkSndFile f
contact <- withStore $ \st -> getContact st userId cName
@ -313,9 +268,9 @@ processChatCommand toView 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
sendDirectMessage (contactConn contact) $ XFile fileInv
toView $ viewSentFileInfo fileId
meta <- liftIO . mkChatMsgMeta =<< sendDirectMessage (contactConn contact) (XFile fileInv)
setActive $ ActiveC cName
pure $ CRSentFileInvitation cName fileId f meta
SendGroupFile gName f -> do
(fileSize, chSize) <- checkSndFile f
group@Group {members, membership} <- withStore $ \st -> getGroup st user gName
@ -328,49 +283,65 @@ processChatCommand toView user@User {userId, profile} = \case
-- TODO sendGroupMessage - same file invitation to all
forM_ ms $ \(m, _, fileInv) ->
traverse (`sendDirectMessage` XFile fileInv) $ memberConn m
toView $ viewSentFileInfo fileId
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
ReceiveFile fileId filePath_ -> do
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
unless (fileStatus == RFSNew) . chatError $ CEFileAlreadyReceiving fileName
tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XFileAcpt fileName) >>= \case
Right agentConnId -> do
filePath <- getRcvFilePath fileId filePath_ fileName
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
toView $ viewRcvFileAccepted ft filePath
Left (ChatErrorAgent (SMP SMP.AUTH)) -> toView $ viewRcvFileSndCancelled ft
Left (ChatErrorAgent (CONN DUPLICATE)) -> toView $ viewRcvFileSndCancelled ft
Left e -> throwError e
CancelFile fileId ->
withStore (\st -> getFileTransfer st userId fileId) >>= \case
procCmd $ do
tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XFileAcpt fileName) >>= \case
Right agentConnId -> do
filePath <- getRcvFilePath fileId filePath_ fileName
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
pure $ CRRcvFileAccepted ft filePath
Left (ChatErrorAgent (SMP SMP.AUTH)) -> pure $ CRRcvFileAcceptedSndCancelled ft
Left (ChatErrorAgent (CONN DUPLICATE)) -> pure $ CRRcvFileAcceptedSndCancelled ft
Left e -> throwError e
CancelFile fileId -> do
ft' <- withStore (\st -> getFileTransfer st userId fileId)
procCmd $ case ft' of
FTSnd fts -> do
forM_ fts $ \ft -> cancelSndFileTransfer ft
toView $ viewSndGroupFileCancelled fts
pure $ CRSndGroupFileCancelled fts
FTRcv ft -> do
cancelRcvFileTransfer ft
toView $ viewRcvFileCancelled ft
pure $ CRRcvFileCancelled ft
FileStatus fileId ->
withStore (\st -> getFileTransferProgress st userId fileId) >>= toView . viewFileTransferStatus
UpdateProfile p -> unless (p == profile) $ do
user' <- withStore $ \st -> updateUserProfile st user p
asks currentUser >>= atomically . (`writeTVar` user')
contacts <- withStore (`getUserContacts` user)
forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p
toView $ viewUserProfileUpdated user user'
ShowProfile -> toView $ viewUserProfile profile
CRFileTransferStatus <$> withStore (\st -> getFileTransferProgress st userId fileId)
ShowProfile -> pure $ CRUserProfile profile
UpdateProfile p@Profile {displayName}
| p == profile -> pure CRUserProfileNoChange
| otherwise -> do
withStore $ \st -> updateUserProfile st user p
let user' = (user :: User) {localDisplayName = displayName, profile = p}
asks currentUser >>= atomically . (`writeTVar` user')
contacts <- withStore (`getUserContacts` user)
procCmd $ do
forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p
pure $ CRUserProfileUpdated profile p
QuitChat -> liftIO exitSuccess
ShowVersion -> toView clientVersionInfo
ShowVersion -> pure CRVersionInfo
where
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
connect :: ConnectionRequestUri c -> ChatMsgEvent -> m ()
connect cReq msg = do
connId <- withAgent $ \a -> joinConnection a cReq $ directMessage msg
withStore $ \st -> createDirectConnection st userId connId
sendMessageCmd :: ContactName -> ByteString -> m ()
sendMessageCmd cName msg = do
contact <- withStore $ \st -> getContact st userId cName
let msgEvent = XMsgNew . MCText $ safeDecodeUtf8 msg
sendDirectMessage (contactConn contact) msgEvent
setActive $ ActiveC cName
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
@ -411,21 +382,24 @@ processChatCommand toView user@User {userId, profile} = \case
f = filePath `combine` (name <> suffix <> ext)
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
agentSubscriber toView = do
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
l <- asks chatLock
subscribeUserConnections toView
subscribeUserConnections
forever $ do
(_, connId, msg) <- atomically $ readTBQueue q
user <- readTVarIO =<< asks currentUser
withLock l . void . runExceptT $
processAgentMessage toView' user connId msg `catchError` (toView' . viewChatError)
where
toView' = ExceptT . fmap Right . toView
processAgentMessage user connId msg `catchError` (toView . CRChatError)
subscribeUserConnections :: forall m. (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => ([StyledString] -> m ()) -> m ()
subscribeUserConnections toView = void . runExceptT $ do
subscribeUserConnections :: forall m. (MonadUnliftIO m, MonadReader ChatController m) => m ()
subscribeUserConnections = void . runExceptT $ do
user <- readTVarIO =<< asks currentUser
subscribeContacts user
subscribeGroups user
@ -433,40 +407,39 @@ subscribeUserConnections toView = void . runExceptT $ do
subscribePendingConnections user
subscribeUserContactLink user
where
toView' = ExceptT . fmap Right . toView
subscribeContacts user = do
contacts <- withStore (`getUserContacts` user)
forM_ contacts $ \ct@Contact {localDisplayName = c} ->
(subscribe (contactConnId ct) >> toView' (viewContactSubscribed c)) `catchError` (toView' . viewContactSubError c)
(subscribe (contactConnId ct) >> toView (CRContactSubscribed c)) `catchError` (toView . CRContactSubError c)
subscribeGroups user = do
groups <- withStore (`getUserGroups` user)
forM_ groups $ \g@Group {members, membership, localDisplayName = gn} -> do
let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members
if memberStatus membership == GSMemInvited
then toView' $ viewGroupInvitation g
then toView $ CRGroupInvitation g
else
if null connectedMembers
then
if memberActive membership
then toView' $ viewGroupEmpty g
else toView' $ viewGroupRemoved g
then toView $ CRGroupEmpty g
else toView $ CRGroupRemoved g
else do
forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
subscribe cId `catchError` (toView' . viewMemberSubError gn c)
toView' $ viewGroupSubscribed g
subscribe cId `catchError` (toView . CRMemberSubError gn 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' . viewSndFileSubError ft)
subscribe agentConnId `catchError` (toView . CRSndFileSubError ft)
void . forkIO $ do
threadDelay 1000000
l <- asks chatLock
a <- asks smpAgent
unless (fileStatus == FSNew) . unlessM (isFileActive fileId sndFiles) $
withAgentLock a . withLock l $
sendFileChunk toView' ft
sendFileChunk ft
subscribeRcvFile ft@RcvFileTransfer {fileStatus} =
case fileStatus of
RFSAccepted fInfo -> resume fInfo
@ -474,22 +447,22 @@ subscribeUserConnections toView = void . runExceptT $ do
_ -> pure ()
where
resume RcvFileInfo {agentConnId} =
subscribe agentConnId `catchError` (toView' . viewRcvFileSubError ft)
subscribe agentConnId `catchError` (toView . CRRcvFileSubError ft)
subscribePendingConnections user = do
cs <- withStore (`getPendingConnections` user)
subscribeConns cs `catchError` \_ -> pure ()
subscribeUserContactLink User {userId} = do
cs <- withStore (`getUserContactLinkConnections` userId)
(subscribeConns cs >> toView' viewUserContactLinkSubscribed)
`catchError` (toView' . viewUserContactLinkSubError)
(subscribeConns cs >> toView CRUserContactLinkSubscribed)
`catchError` (toView . CRUserContactLinkSubError)
subscribe cId = withAgent (`subscribeConnection` cId)
subscribeConns conns =
withAgent $ \a ->
forM_ conns $ \Connection {agentConnId} ->
subscribeConnection a agentConnId
processAgentMessage :: forall m. ChatMonad m => ([StyledString] -> m ()) -> User -> ConnId -> ACommand 'Agent -> m ()
processAgentMessage toView user@User {userId, profile} agentConnId agentMessage = 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
forM_ (agentMsgConnStatus agentMessage) $ \status ->
withStore $ \st -> updateConnectionStatus st (fromConnection chatDirection) status
@ -543,11 +516,11 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
_ -> pure ()
Just ct@Contact {localDisplayName = c} -> case agentMsg of
MSG meta msgBody -> do
chatMsgEvent <- saveRcvMSG conn meta msgBody
(chatMsgEvent, msg) <- saveRcvMSG conn meta msgBody
withAckMessage agentConnId meta $
case chatMsgEvent of
XMsgNew (MCText text) -> newTextMessage c meta text
XFile fInv -> processFileInvitation ct meta fInv
XMsgNew mc -> newContentMessage c msg mc meta
XFile fInv -> processFileInvitation ct msg fInv meta
XInfo p -> xInfo ct p
XGrpInv gInv -> processGroupInvitation ct gInv
XInfoProbe probe -> xInfoProbe ct probe
@ -579,7 +552,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
CON ->
withStore (\st -> getViaGroupMember st user ct) >>= \case
Nothing -> do
toView $ viewContactConnected ct
toView $ CRContactConnected ct
setActive $ ActiveC c
showToast (c <> "> ") "connected"
Just (gName, m) ->
@ -589,14 +562,14 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
SENT msgId ->
sentMsgDeliveryEvent conn msgId
END -> do
toView $ viewContactAnotherClient c
toView $ CRContactAnotherClient c
showToast (c <> "> ") "connected to another client"
unsetActive $ ActiveC c
DOWN -> do
toView $ viewContactDisconnected c
toView $ CRContactDisconnected c
showToast (c <> "> ") "disconnected"
UP -> do
toView $ viewContactSubscribed c
toView $ CRContactSubscribed c
showToast (c <> "> ") "is active"
setActive $ ActiveC c
-- TODO print errors
@ -644,21 +617,21 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
updateGroupMemberStatus st userId m GSMemConnected
unless (memberActive membership) $
updateGroupMemberStatus st userId membership GSMemConnected
-- TODO forward any pending (GMIntroInvReceived) introductions
sendPendingGroupMessages m conn
case memberCategory m of
GCHostMember -> do
toView $ viewUserJoinedGroup gName
toView $ CRUserJoinedGroup gName
setActive $ ActiveG gName
showToast ("#" <> gName) "you are connected to group"
GCInviteeMember -> do
toView $ viewJoinedGroupMember gName m
toView $ CRJoinedGroupMember gName m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
intros <- withStore $ \st -> createIntroductions st group m
sendGroupMessage members . XGrpMemNew $ memberInfo m
forM_ intros $ \intro -> do
sendDirectMessage conn . XGrpMemIntro . memberInfo $ reMember intro
withStore $ \st -> updateIntroStatus st intro GMIntroSent
void . sendGroupMessage members . XGrpMemNew $ memberInfo m
forM_ intros $ \intro@GroupMemberIntro {introId} -> do
void . sendDirectMessage conn . XGrpMemIntro . memberInfo $ reMember intro
withStore $ \st -> updateIntroStatus st introId GMIntroSent
_ -> do
-- TODO send probe and decide whether to use existing contact connection or the new contact connection
-- TODO notify member who forwarded introduction - question - where it is stored? There is via_contact but probably there should be via_member in group_members table
@ -671,11 +644,11 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
notifyMemberConnected gName m
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct
MSG meta msgBody -> do
chatMsgEvent <- saveRcvMSG conn meta msgBody
(chatMsgEvent, msg) <- saveRcvMSG conn meta msgBody
withAckMessage agentConnId meta $
case chatMsgEvent of
XMsgNew (MCText text) -> newGroupTextMessage gName m meta text
XFile fInv -> processGroupFileInvitation gName m meta fInv
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
@ -708,15 +681,15 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
_ -> messageError "CONF from file connection must have x.file.acpt"
CON -> do
withStore $ \st -> updateSndFileStatus st ft FSConnected
toView $ viewSndFileStart ft
sendFileChunk toView ft
toView $ CRSndFileStart ft
sendFileChunk ft
SENT msgId -> do
withStore $ \st -> updateSndFileChunkSent st ft msgId
unless (fileStatus == FSCancelled) $ sendFileChunk toView ft
unless (fileStatus == FSCancelled) $ sendFileChunk ft
MERR _ err -> do
cancelSndFileTransfer ft
case err of
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ toView $ viewSndFileRcvCancelled ft
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ toView $ CRSndFileRcvCancelled ft
_ -> chatError $ CEFileSend fileId err
MSG meta _ ->
withAckMessage agentConnId meta $ pure ()
@ -730,12 +703,12 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
case agentMsg of
CON -> do
withStore $ \st -> updateRcvFileStatus st ft FSConnected
toView $ viewRcvFileStart ft
toView $ CRRcvFileStart ft
MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do
parseFileChunk msgBody >>= \case
FileChunkCancel -> do
cancelRcvFileTransfer ft
toView $ viewRcvFileSndCancelled ft
toView $ CRRcvFileSndCancelled ft
FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of
MsgOk -> pure ()
@ -755,7 +728,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
withStore $ \st -> do
updateRcvFileStatus st ft FSComplete
deleteRcvFileChunks st ft
toView $ viewRcvFileComplete ft
toView $ CRRcvFileComplete ft
closeFileHandle fileId rcvFiles
withAgent (`deleteConnection` agentConnId)
RcvChunkDuplicate -> pure ()
@ -784,7 +757,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
profileContactRequest :: InvitationId -> Profile -> m ()
profileContactRequest invId p = do
cName <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p
toView $ viewReceivedContactRequest cName p
toView $ CRReceivedContactRequest cName p
showToast (cName <> "> ") "wants to connect to you"
withAckMessage :: ConnId -> MsgMeta -> m () -> m ()
@ -809,7 +782,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
notifyMemberConnected :: GroupName -> GroupMember -> m ()
notifyMemberConnected gName m@GroupMember {localDisplayName} = do
toView $ viewConnectedToGroupMember gName m
toView $ CRConnectedToGroupMember gName m
setActive $ ActiveG gName
showToast ("#" <> gName) $ "member " <> localDisplayName <> " is connected"
@ -817,47 +790,52 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
probeMatchingContacts ct = do
gVar <- asks idsDrg
(probe, probeId) <- withStore $ \st -> createSentProbe st gVar userId ct
sendDirectMessage (contactConn ct) $ XInfoProbe probe
void . sendDirectMessage (contactConn ct) $ XInfoProbe probe
cs <- withStore (\st -> getMatchingContacts st userId ct)
let probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
forM_ cs $ \c -> sendProbeHash c probeHash probeId `catchError` const (pure ())
where
sendProbeHash :: Contact -> ProbeHash -> Int64 -> m ()
sendProbeHash c probeHash probeId = do
sendDirectMessage (contactConn c) $ XInfoProbeCheck probeHash
void . sendDirectMessage (contactConn c) $ XInfoProbeCheck probeHash
withStore $ \st -> createSentProbeHash st userId probeId c
messageWarning :: Text -> m ()
messageWarning = toView . viewMessageError "warning"
messageWarning = toView . CRMessageError "warning"
messageError :: Text -> m ()
messageError = toView . viewMessageError "error"
messageError = toView . CRMessageError "error"
newTextMessage :: ContactName -> MsgMeta -> Text -> m ()
newTextMessage c meta text = do
toView =<< liftIO (viewReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)))
showToast (c <> "> ") text
newContentMessage :: ContactName -> Message -> MsgContent -> MsgMeta -> m ()
newContentMessage c msg mc MsgMeta {integrity} = do
meta <- liftIO $ mkChatMsgMeta msg
toView $ CRReceivedMessage c meta mc integrity
showToast (c <> "> ") $ msgContentText mc
setActive $ ActiveC c
newGroupTextMessage :: GroupName -> GroupMember -> MsgMeta -> Text -> m ()
newGroupTextMessage gName GroupMember {localDisplayName = c} meta text = do
toView =<< liftIO (viewReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)))
showToast ("#" <> gName <> " " <> c <> "> ") text
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
processFileInvitation :: Contact -> MsgMeta -> FileInvitation -> m ()
processFileInvitation contact@Contact {localDisplayName = c} meta fInv = do
processFileInvitation :: Contact -> Message -> FileInvitation -> MsgMeta -> m ()
processFileInvitation contact@Contact {localDisplayName = c} msg fInv MsgMeta {integrity} = 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
toView =<< liftIO (viewReceivedFileInvitation c (snd $ broker meta) ft (integrity (meta :: MsgMeta)))
meta <- liftIO $ mkChatMsgMeta msg
toView $ CRReceivedFileInvitation c meta ft integrity
showToast (c <> "> ") "wants to send a file"
setActive $ ActiveC c
processGroupFileInvitation :: GroupName -> GroupMember -> MsgMeta -> FileInvitation -> m ()
processGroupFileInvitation gName m@GroupMember {localDisplayName = c} meta fInv = do
processGroupFileInvitation :: GroupName -> GroupMember -> Message -> FileInvitation -> MsgMeta -> m ()
processGroupFileInvitation gName m@GroupMember {localDisplayName = c} msg fInv MsgMeta {integrity} = do
chSize <- asks $ fileChunkSize . config
ft <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize
toView =<< liftIO (viewReceivedGroupFileInvitation gName c (snd $ broker meta) ft (integrity (meta :: MsgMeta)))
meta <- liftIO $ mkChatMsgMeta msg
toView $ CRReceivedGroupFileInvitation gName c meta ft integrity
showToast ("#" <> gName <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG gName
@ -866,13 +844,13 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
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 $ viewReceivedGroupInvitation group c memRole
showToast ("#" <> gName <> " " <> c <> "> ") $ "invited you to join the group"
toView $ CRReceivedGroupInvitation group c memRole
showToast ("#" <> gName <> " " <> c <> "> ") "invited you to join the group"
xInfo :: Contact -> Profile -> m ()
xInfo c@Contact {profile = p} p' = unless (p == p') $ do
c' <- withStore $ \st -> updateContactProfile st userId c p'
toView $ viewContactUpdated c c'
toView $ CRContactUpdated c c'
xInfoProbe :: Contact -> Probe -> m ()
xInfoProbe c2 probe = do
@ -887,7 +865,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
probeMatch :: Contact -> Contact -> Probe -> m ()
probeMatch c1@Contact {profile = p1} c2@Contact {profile = p2} probe =
when (p1 == p2) $ do
sendDirectMessage (contactConn c1) $ XInfoProbeOk probe
void . sendDirectMessage (contactConn c1) $ XInfoProbeOk probe
mergeContacts c1 c2
xInfoProbeOk :: Contact -> Probe -> m ()
@ -898,7 +876,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
mergeContacts :: Contact -> Contact -> m ()
mergeContacts to from = do
withStore $ \st -> mergeContactRecords st userId to from
toView $ viewContactsMerged to from
toView $ CRContactsMerged to from
saveConnInfo :: Connection -> ConnInfo -> m ()
saveConnInfo activeConn connInfo = do
@ -917,7 +895,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
then messageError "x.grp.mem.new error: member already exists"
else do
newMember <- withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced
toView $ viewJoinedGroupMemberConnecting gName m newMember
toView $ CRJoinedGroupMemberConnecting gName m newMember
xGrpMemIntro :: Connection -> GroupName -> GroupMember -> MemberInfo -> m ()
xGrpMemIntro conn gName m memInfo@(MemberInfo memId _ _) =
@ -931,7 +909,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
(directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation)
newMember <- withStore $ \st -> createIntroReMember st user group m memInfo groupConnId directConnId
let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq}
sendDirectMessage conn msg
void $ sendDirectMessage conn msg
withStore $ \st -> updateGroupMemberStatus st userId newMember GSMemIntroInvited
_ -> messageError "x.grp.mem.intro can be only sent by host member"
@ -943,12 +921,8 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
case find (sameMemberId memId) $ members group of
Nothing -> messageError "x.grp.mem.inv error: referenced member does not exists"
Just reMember -> do
intro <- withStore $ \st -> saveIntroInvitation st reMember m introInv
case activeConn (reMember :: GroupMember) of
Nothing -> pure () -- this is not an error, introduction will be forwarded once the member is connected
Just reConn -> do
sendDirectMessage reConn $ XGrpMemFwd (memberInfo m) introInv
withStore $ \st -> updateIntroStatus st intro GMIntroInvForwarded
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 ()
@ -974,7 +948,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
then do
mapM_ deleteMemberConnection members
withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved
toView $ viewDeletedMemberUser gName m
toView $ CRDeletedMemberUser gName m
else case find (sameMemberId memId) members of
Nothing -> messageError "x.grp.mem.del with unknown member ID"
Just member -> do
@ -984,7 +958,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
else do
deleteMemberConnection member
withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved
toView $ viewDeletedMember gName (Just m) (Just member)
toView $ CRDeletedMember gName m member
sameMemberId :: MemberId -> GroupMember -> Bool
sameMemberId memId GroupMember {memberId} = memId == memberId
@ -993,7 +967,7 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
xGrpLeave gName m = do
deleteMemberConnection m
withStore $ \st -> updateGroupMemberStatus st userId m GSMemLeft
toView $ viewLeftMember gName m
toView $ CRLeftMember gName m
xGrpDel :: GroupName -> GroupMember -> m ()
xGrpDel gName m@GroupMember {memberRole} = do
@ -1003,13 +977,13 @@ processAgentMessage toView user@User {userId, profile} agentConnId agentMessage
updateGroupMemberStatus st userId membership GSMemGroupDeleted
pure members
mapM_ deleteMemberConnection ms
toView $ viewGroupDeleted gName m
toView $ CRGroupDeleted gName m
parseChatMessage :: ByteString -> Either ChatError ChatMessage
parseChatMessage = first ChatErrorMessage . strDecode
sendFileChunk :: ChatMonad m => ([StyledString] -> m ()) -> SndFileTransfer -> m ()
sendFileChunk toView ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
sendFileChunk :: ChatMonad m => SndFileTransfer -> m ()
sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
withStore (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo
@ -1017,7 +991,7 @@ sendFileChunk toView ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
withStore $ \st -> do
updateSndFileStatus st ft FSComplete
deleteSndFileChunks st ft
toView $ viewSndFileComplete ft
toView $ CRSndFileComplete ft
closeFileHandle fileId sndFiles
withAgent (`deleteConnection` agentConnId)
@ -1124,13 +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 ()
sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> m Message
sendDirectMessage conn chatMsgEvent = do
let msgBody = directMessage chatMsgEvent
newMsg = NewMessage {direction = MDSnd, chatMsgEventType = toChatEventTag chatMsgEvent, msgBody}
-- can be done in transaction after sendMessage, probably shouldn't
msgId <- withStore $ \st -> createNewMessage st newMsg
msg@Message {msgId, msgBody} <- createSndMessage chatMsgEvent
deliverMessage conn msgBody msgId
pure msg
createSndMessage :: ChatMonad m => ChatMsgEvent -> m Message
createSndMessage chatMsgEvent = do
chatTs <- liftIO getCurrentTime
let msgBody = directMessage chatMsgEvent
newMsg = NewMessage {direction = MDSnd, cmEventTag = toCMEventTag chatMsgEvent, msgBody, chatTs}
withStore $ \st -> createNewMessage st newMsg
directMessage :: ChatMsgEvent -> ByteString
directMessage chatMsgEvent = strEncode ChatMessage {chatMsgEvent}
@ -1141,23 +1120,45 @@ deliverMessage Connection {connId, agentConnId} msgBody msgId = do
let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
withStore $ \st -> createSndMsgDelivery st sndMsgDelivery msgId
sendGroupMessage :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> m ()
sendGroupMessage members chatMsgEvent = do
let msgBody = directMessage chatMsgEvent
newMsg = NewMessage {direction = MDSnd, chatMsgEventType = toChatEventTag chatMsgEvent, msgBody}
msgId <- withStore $ \st -> createNewMessage st newMsg
-- TODO once scheduled delivery is implemented memberActive should be changed to memberCurrent
forM_ (map memberConn $ filter memberActive members) $
traverse (\conn -> deliverMessage conn msgBody msgId)
sendGroupMessage :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> m Message
sendGroupMessage members chatMsgEvent =
sendGroupMessage' members chatMsgEvent Nothing $ pure ()
saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> m ChatMsgEvent
sendXGrpMemInv :: ChatMonad m => GroupMember -> ChatMsgEvent -> Int64 -> m Message
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' members chatMsgEvent introId_ postDeliver = do
msg@Message {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
sendPendingGroupMessages :: ChatMonad m => GroupMember -> Connection -> m ()
sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do
pendingMessages <- withStore $ \st -> getPendingGroupMessages st groupMemberId
-- TODO ensure order - pending messages interleave with user input messages
for_ pendingMessages $ \PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} -> do
deliverMessage conn msgBody msgId
withStore (\st -> deletePendingGroupMessage st groupMemberId msgId)
when (cmEventTag == XGrpMemFwd_) $ case introId_ of
Nothing -> chatError $ CEGroupMemberIntroNotFound localDisplayName
Just introId -> withStore (\st -> updateIntroStatus st introId GMIntroInvForwarded)
saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> m (ChatMsgEvent, Message)
saveRcvMSG Connection {connId} agentMsgMeta msgBody = do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
let newMsg = NewMessage {direction = MDRcv, chatMsgEventType = toChatEventTag chatMsgEvent, msgBody}
agentMsgId = fst $ recipient agentMsgMeta
let agentMsgId = fst $ recipient agentMsgMeta
chatTs = snd $ broker agentMsgMeta
cmEventTag = toCMEventTag chatMsgEvent
newMsg = NewMessage {direction = MDRcv, cmEventTag, chatTs, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta}
withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery
pure chatMsgEvent
msg <- withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery
pure (chatMsgEvent, msg)
allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m ()
allowAgentConnection conn@Connection {agentConnId} confId msg = do
@ -1247,10 +1248,10 @@ withStore action =
chatCommandP :: Parser ChatCommand
chatCommandP =
("/help files" <|> "/help file" <|> "/hf") $> FilesHelp
<|> ("/help groups" <|> "/help group" <|> "/hg") $> GroupsHelp
<|> ("/help address" <|> "/ha") $> MyAddressHelp
<|> ("/help" <|> "/h") $> ChatHelp
("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles
<|> ("/help groups" <|> "/help group" <|> "/hg") $> ChatHelp HSGroups
<|> ("/help address" <|> "/ha") $> ChatHelp HSMyAddress
<|> ("/help" <|> "/h") $> ChatHelp HSMain
<|> ("/group #" <|> "/group " <|> "/g #" <|> "/g ") *> (NewGroup <$> groupProfile)
<|> ("/add #" <|> "/add " <|> "/a #" <|> "/a ") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole)
<|> ("/join #" <|> "/join " <|> "/j #" <|> "/j ") *> (JoinGroup <$> displayName)
@ -1276,7 +1277,7 @@ chatCommandP =
<|> ("/show_address" <|> "/sa") $> ShowMyAddress
<|> ("/accept @" <|> "/accept " <|> "/ac @" <|> "/ac ") *> (AcceptContact <$> displayName)
<|> ("/reject @" <|> "/reject " <|> "/rc @" <|> "/rc ") *> (RejectContact <$> displayName)
<|> ("/markdown" <|> "/m") $> MarkdownHelp
<|> ("/markdown" <|> "/m") $> ChatHelp HSMarkdown
<|> ("/welcome" <|> "/w") $> Welcome
<|> ("/profile " <|> "/p ") *> (UpdateProfile <$> userProfile)
<|> ("/profile" <|> "/p") $> ShowProfile

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

@ -2,7 +2,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Controller where
@ -12,16 +11,20 @@ import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random (ChaChaDRG)
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
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.Styled
import Simplex.Chat.Types
import Simplex.Messaging.Agent (AgentClient)
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig)
import Simplex.Messaging.Agent.Protocol (AgentErrorType)
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
import Simplex.Messaging.Protocol (CorrId)
import System.IO (Handle)
import UnliftIO.STM
@ -51,8 +54,8 @@ data ChatController = ChatController
smpAgent :: AgentClient,
chatStore :: SQLiteStore,
idsDrg :: TVar ChaChaDRG,
inputQ :: TBQueue InputEvent,
outputQ :: TBQueue [StyledString],
inputQ :: TBQueue String,
outputQ :: TBQueue (CorrId, ChatResponse),
notifyQ :: TBQueue Notification,
sendNotification :: Notification -> IO (),
chatLock :: TMVar (),
@ -61,7 +64,120 @@ data ChatController = ChatController
config :: ChatConfig
}
data InputEvent = InputCommand String | InputControl Char
data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown
deriving (Show)
data ChatCommand
= ChatHelp HelpSection
| Welcome
| AddContact
| Connect (Maybe AConnectionRequestUri)
| ConnectAdmin
| DeleteContact ContactName
| ListContacts
| CreateMyAddress
| DeleteMyAddress
| ShowMyAddress
| AcceptContact ContactName
| RejectContact ContactName
| SendMessage ContactName ByteString
| NewGroup GroupProfile
| AddMember GroupName ContactName GroupMemberRole
| JoinGroup GroupName
| RemoveMember GroupName ContactName
| MemberRole GroupName ContactName GroupMemberRole
| LeaveGroup GroupName
| DeleteGroup GroupName
| ListMembers GroupName
| ListGroups
| SendGroupMessage GroupName ByteString
| SendFile ContactName FilePath
| SendGroupFile GroupName FilePath
| ReceiveFile Int64 (Maybe FilePath)
| CancelFile Int64
| FileStatus Int64
| ShowProfile
| UpdateProfile Profile
| QuitChat
| ShowVersion
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
| CRCommandAccepted CorrId
| CRChatHelp HelpSection
| CRWelcome User
| CRGroupCreated Group
| CRGroupMembers Group
| CRContactsList [Contact]
| CRUserContactLink ConnReqContact
| CRContactRequestRejected ContactName
| CRUserAcceptedGroupSent GroupName
| CRUserDeletedMember GroupName GroupMember
| CRGroupsList [GroupInfo]
| CRSentGroupInvitation GroupName ContactName
| CRFileTransferStatus (FileTransfer, [Integer])
| CRUserProfile Profile
| CRUserProfileNoChange
| CRVersionInfo
| CRInvitation ConnReqInvitation
| CRSentConfirmation
| CRSentInvitation
| CRContactUpdated {fromContact :: Contact, toContact :: Contact}
| CRContactsMerged {intoContact :: Contact, mergedContact :: Contact}
| CRContactDeleted ContactName
| CRUserContactLinkCreated ConnReqContact
| CRUserContactLinkDeleted
| CRReceivedContactRequest ContactName Profile
| CRAcceptingContactRequest ContactName
| CRLeftMemberUser GroupName
| CRGroupDeletedUser GroupName
| CRRcvFileAccepted RcvFileTransfer FilePath
| CRRcvFileAcceptedSndCancelled RcvFileTransfer
| CRRcvFileStart RcvFileTransfer
| CRRcvFileComplete RcvFileTransfer
| CRRcvFileCancelled RcvFileTransfer
| CRRcvFileSndCancelled RcvFileTransfer
| CRSndFileStart SndFileTransfer
| CRSndFileComplete SndFileTransfer
| CRSndFileCancelled SndFileTransfer
| CRSndFileRcvCancelled SndFileTransfer
| 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
| CRSndFileSubError SndFileTransfer ChatError
| CRRcvFileSubError RcvFileTransfer ChatError
| CRUserContactLinkSubscribed
| CRUserContactLinkSubError ChatError
| CRMessageError Text Text
| CRChatCmdError ChatError
| CRChatError ChatError
deriving (Show)
data ChatError
= ChatError ChatErrorType
@ -72,6 +188,8 @@ data ChatError
data ChatErrorType
= CEGroupUserRole
| CEInvalidConnReq
| CEContactGroups ContactName [GroupName]
| CEGroupContactRole ContactName
| CEGroupDuplicateMember ContactName
| CEGroupDuplicateMemberId
@ -79,6 +197,8 @@ data ChatErrorType
| CEGroupMemberNotActive
| CEGroupMemberUserRemoved
| CEGroupMemberNotFound ContactName
| CEGroupMemberIntroNotFound ContactName
| CEGroupCantResendInvitation GroupName ContactName
| CEGroupInternal String
| CEFileNotFound String
| CEFileAlreadyReceiving String
@ -89,9 +209,10 @@ data ChatErrorType
| CEFileRcvChunk String
| CEFileInternal String
| CEAgentVersion
| CECommandError String
deriving (Show, Exception)
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m, MonadFail m)
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
setActive to = asks activeTo >>= atomically . (`writeTVar` to)

179
src/Simplex/Chat/Messages.hs Normal file
View file

@ -0,0 +1,179 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Messages where
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 Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime)
import Data.Time.LocalTime (ZonedTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Database.SQLite.Simple.FromField (FromField (..))
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.Store.SQLite (fromTextField_)
import Simplex.Messaging.Protocol (MsgBody)
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,
msgBody :: MsgBody,
introId_ :: Maybe Int64
}
data ChatMsgMeta = ChatMsgMeta
{ msgId :: MessageId,
chatTs :: UTCTime,
localChatTs :: ZonedTime,
createdAt :: UTCTime
}
deriving (Show)
data MsgDirection = MDRcv | MDSnd
deriving (Show)
data SMsgDirection (d :: MsgDirection) where
SMDRcv :: SMsgDirection 'MDRcv
SMDSnd :: SMsgDirection 'MDSnd
instance TestEquality SMsgDirection where
testEquality SMDRcv SMDRcv = Just Refl
testEquality SMDSnd SMDSnd = Just Refl
testEquality _ _ = Nothing
class MsgDirectionI (d :: MsgDirection) where
msgDirection :: SMsgDirection d
instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
instance ToField MsgDirection where toField = toField . msgDirectionInt
msgDirectionInt :: MsgDirection -> Int
msgDirectionInt = \case
MDRcv -> 0
MDSnd -> 1
msgDirectionIntP :: Int -> Maybe MsgDirection
msgDirectionIntP = \case
0 -> Just MDRcv
1 -> Just MDSnd
_ -> Nothing
data SndMsgDelivery = SndMsgDelivery
{ connId :: Int64,
agentMsgId :: AgentMsgId
}
data RcvMsgDelivery = RcvMsgDelivery
{ connId :: Int64,
agentMsgId :: AgentMsgId,
agentMsgMeta :: MsgMeta
}
data MsgMetaJSON = MsgMetaJSON
{ integrity :: Text,
rcvId :: Int64,
rcvTs :: UTCTime,
serverId :: Text,
serverTs :: UTCTime,
sndId :: Int64
}
deriving (Eq, Show, FromJSON, Generic)
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions
msgMetaToJson :: MsgMeta -> MsgMetaJSON
msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} =
MsgMetaJSON
{ integrity = (decodeLatin1 . serializeMsgIntegrity) integrity,
rcvId,
rcvTs,
serverId = (decodeLatin1 . B64.encode) serverId,
serverTs,
sndId
}
msgMetaJson :: MsgMeta -> Text
msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson
data MsgDeliveryStatus (d :: MsgDirection) where
MDSRcvAgent :: MsgDeliveryStatus 'MDRcv
MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv
MDSSndPending :: MsgDeliveryStatus 'MDSnd
MDSSndAgent :: MsgDeliveryStatus 'MDSnd
MDSSndSent :: MsgDeliveryStatus 'MDSnd
MDSSndReceived :: MsgDeliveryStatus 'MDSnd
MDSSndRead :: MsgDeliveryStatus 'MDSnd
data AMsgDeliveryStatus = forall d. AMDS (SMsgDirection d) (MsgDeliveryStatus d)
instance (Typeable d, MsgDirectionI d) => FromField (MsgDeliveryStatus d) where
fromField = fromTextField_ msgDeliveryStatusT'
instance ToField (MsgDeliveryStatus d) where toField = toField . serializeMsgDeliveryStatus
serializeMsgDeliveryStatus :: MsgDeliveryStatus d -> Text
serializeMsgDeliveryStatus = \case
MDSRcvAgent -> "rcv_agent"
MDSRcvAcknowledged -> "rcv_acknowledged"
MDSSndPending -> "snd_pending"
MDSSndAgent -> "snd_agent"
MDSSndSent -> "snd_sent"
MDSSndReceived -> "snd_received"
MDSSndRead -> "snd_read"
msgDeliveryStatusT :: Text -> Maybe AMsgDeliveryStatus
msgDeliveryStatusT = \case
"rcv_agent" -> Just $ AMDS SMDRcv MDSRcvAgent
"rcv_acknowledged" -> Just $ AMDS SMDRcv MDSRcvAcknowledged
"snd_pending" -> Just $ AMDS SMDSnd MDSSndPending
"snd_agent" -> Just $ AMDS SMDSnd MDSSndAgent
"snd_sent" -> Just $ AMDS SMDSnd MDSSndSent
"snd_received" -> Just $ AMDS SMDSnd MDSSndReceived
"snd_read" -> Just $ AMDS SMDSnd MDSSndRead
_ -> Nothing
msgDeliveryStatusT' :: forall d. MsgDirectionI d => Text -> Maybe (MsgDeliveryStatus d)
msgDeliveryStatusT' s =
msgDeliveryStatusT s >>= \(AMDS d st) ->
case testEquality d (msgDirection @d) of
Just Refl -> Just st
_ -> Nothing

5
src/Simplex/Chat/Migrations/M20220101_initial.hs
View file

@ -242,11 +242,12 @@ CREATE TABLE contact_requests (
CREATE TABLE messages (
message_id INTEGER PRIMARY KEY,
msg_sent INTEGER NOT NULL, -- 0 for received, 1 for sent
chat_msg_event TEXT NOT NULL, -- message event type (the constructor of ChatMsgEvent)
chat_msg_event TEXT NOT NULL, -- message event tag (the constructor of CMEventTag)
msg_body BLOB, -- agent message body as received or sent
created_at TEXT NOT NULL DEFAULT (datetime('now'))
);
-- TODO ? agent_msg_id could be NOT NULL now that pending_group_messages are separate
-- message deliveries communicated with the agent, append only
CREATE TABLE msg_deliveries (
msg_delivery_id INTEGER PRIMARY KEY,
@ -259,7 +260,7 @@ CREATE TABLE msg_deliveries (
);
-- TODO recovery for received messages with "rcv_agent" status - acknowledge to agent
-- changes of messagy delivery status, append only
-- changes of message delivery status, append only
CREATE TABLE msg_delivery_events (
msg_delivery_event_id INTEGER PRIMARY KEY,
msg_delivery_id INTEGER NOT NULL REFERENCES msg_deliveries ON DELETE CASCADE, -- non UNIQUE for multiple events per msg delivery

21
src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs Normal file
View file

@ -0,0 +1,21 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20220122_pending_group_messages where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220122_pending_group_messages :: Query
m20220122_pending_group_messages =
[sql|
-- pending messages for announced (memberCurrent) but not yet connected (memberActive) group members
CREATE TABLE pending_group_messages (
pending_group_message_id INTEGER PRIMARY KEY,
group_member_id INTEGER NOT NULL REFERENCES group_members ON DELETE CASCADE,
message_id INTEGER NOT NULL REFERENCES messages ON DELETE CASCADE,
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;
|]

16
src/Simplex/Chat/Mobile.hs
View file

@ -21,8 +21,8 @@ import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Options
import Simplex.Chat.Store
import Simplex.Chat.Styled
import Simplex.Chat.Types
import Simplex.Chat.View
foreign export ccall "chat_init_store" cChatInitStore :: CString -> IO (StablePtr ChatStore)
@ -76,8 +76,6 @@ mobileChatOpts =
type CJSONString = CString
type JSONString = String
data ChatStore = ChatStore
{ dbFilePrefix :: FilePath,
chatStore :: SQLiteStore
@ -117,10 +115,18 @@ chatStart ChatStore {dbFilePrefix, chatStore} = do
pure cc
chatSendCmd :: ChatController -> String -> IO JSONString
chatSendCmd ChatController {inputQ} s = atomically (writeTBQueue inputQ $ InputCommand s) >> pure "{}"
chatSendCmd cc s = crToJSON <$> runReaderT (execChatCommand s) cc
chatRecvMsg :: ChatController -> IO String
chatRecvMsg ChatController {outputQ} = unlines . map unStyle <$> atomically (readTBQueue outputQ)
chatRecvMsg ChatController {outputQ} = serializeChatResponse . snd <$> atomically (readTBQueue outputQ)
jsonObject :: J.Series -> JSONString
jsonObject = LB.unpack . JE.encodingToLazyByteString . J.pairs
crToJSON :: ChatResponse -> JSONString
crToJSON = \case
CRUserProfile p -> o "profile" $ J.object ["profile" .= p]
r -> o "terminal" $ J.object ["response" .= serializeChatResponse r]
where
o :: String -> J.Value -> JSONString
o tp params = jsonObject ("type" .= tp <> "params" .= params)

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

@ -22,9 +22,12 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.HashMap.Strict as H
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
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 ((<$?>))
@ -111,6 +114,11 @@ instance ToJSON MsgContentType where
data MsgContent = MCText Text | MCUnknown
deriving (Eq, Show)
msgContentText :: MsgContent -> Text
msgContentText = \case
MCText t -> t
MCUnknown -> unknownMsgType
toMsgContentType :: MsgContent -> MsgContentType
toMsgContentType = \case
MCText _ -> MCText_
@ -161,6 +169,7 @@ data CMEventTag
| XInfoProbeCheck_
| XInfoProbeOk_
| XOk_
deriving (Eq, Show)
instance StrEncoding CMEventTag where
strEncode = \case
@ -234,8 +243,15 @@ toCMEventTag = \case
XInfoProbeOk _ -> XInfoProbeOk_
XOk -> XOk_
toChatEventTag :: ChatMsgEvent -> Text
toChatEventTag = decodeLatin1 . strEncode . toCMEventTag
cmEventTagT :: Text -> Maybe CMEventTag
cmEventTagT = either (const Nothing) Just . strDecode . encodeUtf8
serializeCMEventTag :: CMEventTag -> Text
serializeCMEventTag = decodeLatin1 . strEncode
instance FromField CMEventTag where fromField = fromTextField_ cmEventTagT
instance ToField CMEventTag where toField = toField . serializeCMEventTag
appToChatMessage :: AppMessage -> Either String ChatMessage
appToChatMessage AppMessage {event, params} = do
@ -271,7 +287,7 @@ appToChatMessage AppMessage {event, params} = do
chatToAppMessage :: ChatMessage -> AppMessage
chatToAppMessage ChatMessage {chatMsgEvent} = AppMessage {event, params}
where
event = toChatEventTag chatMsgEvent
event = serializeCMEventTag . toCMEventTag $ chatMsgEvent
o :: [(Text, J.Value)] -> J.Object
o = H.fromList
params = case chatMsgEvent of

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

@ -95,6 +95,9 @@ module Simplex.Chat.Store
createNewMessageAndRcvMsgDelivery,
createSndMsgDeliveryEvent,
createRcvMsgDeliveryEvent,
createPendingGroupMessage,
getPendingGroupMessages,
deletePendingGroupMessage,
)
where
@ -119,7 +122,9 @@ import Data.Time.Clock (UTCTime, getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..))
import qualified Database.SQLite.Simple as DB
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.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@ -132,7 +137,8 @@ import UnliftIO.STM
schemaMigrations :: [(String, Query)]
schemaMigrations =
[ ("20220101_initial", m20220101_initial)
[ ("20220101_initial", m20220101_initial),
("20220122_pending_group_messages", m20220122_pending_group_messages)
]
-- | The list of migrations in ascending order by date
@ -303,18 +309,18 @@ getContact :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Contact
getContact st userId localDisplayName =
liftIOEither . withTransaction st $ \db -> runExceptT $ getContact_ db userId localDisplayName
updateUserProfile :: StoreMonad m => SQLiteStore -> User -> Profile -> m User
updateUserProfile st u@User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
updateUserProfile :: StoreMonad m => SQLiteStore -> User -> Profile -> m ()
updateUserProfile st User {userId, userContactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
| displayName == newName =
liftIO . withTransaction st $ \db ->
updateContactProfile_ db userId userContactId p' $> (u :: User) {profile = p'}
updateContactProfile_ db userId userContactId p'
| otherwise =
liftIOEither . checkConstraint SEDuplicateName . withTransaction st $ \db -> do
DB.execute db "UPDATE users SET local_display_name = ? WHERE user_id = ?" (newName, userId)
DB.execute db "INSERT INTO display_names (local_display_name, ldn_base, user_id) VALUES (?, ?, ?)" (newName, newName, userId)
updateContactProfile_ db userId userContactId p'
updateContact_ db userId userContactId localDisplayName newName
pure . Right $ (u :: User) {localDisplayName = newName, profile = p'}
pure $ Right ()
updateContactProfile :: StoreMonad m => SQLiteStore -> UserId -> Contact -> Profile -> m Contact
updateContactProfile st userId c@Contact {contactId, localDisplayName, profile = Profile {displayName}} p'@Profile {displayName = newName}
@ -994,19 +1000,23 @@ getUserGroups st user@User {userId} =
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
getUserGroupDetails :: MonadUnliftIO m => SQLiteStore -> UserId -> m [(GroupName, Text, GroupMemberStatus)]
getUserGroupDetails :: MonadUnliftIO m => SQLiteStore -> UserId -> m [GroupInfo]
getUserGroupDetails st userId =
liftIO . withTransaction st $ \db ->
DB.query
db
[sql|
SELECT g.local_display_name, p.full_name, m.member_status
FROM groups g
JOIN group_profiles p USING (group_profile_id)
JOIN group_members m USING (group_id)
WHERE g.user_id = ? AND m.member_category = 'user'
|]
(Only userId)
map groupInfo
<$> DB.query
db
[sql|
SELECT g.group_id, g.local_display_name, p.display_name, p.full_name, m.member_status
FROM groups g
JOIN group_profiles p USING (group_profile_id)
JOIN group_members m USING (group_id)
WHERE g.user_id = ? AND m.member_category = 'user'
|]
(Only userId)
where
groupInfo (groupId, localDisplayName, displayName, fullName, userMemberStatus) =
GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName}, userMemberStatus}
getGroupInvitation :: StoreMonad m => SQLiteStore -> User -> GroupName -> m ReceivedGroupInvitation
getGroupInvitation st user localDisplayName =
@ -1139,8 +1149,8 @@ createIntroductions st Group {members} toMember = do
introId <- insertedRowId db
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
updateIntroStatus :: MonadUnliftIO m => SQLiteStore -> GroupMemberIntro -> GroupMemberIntroStatus -> m ()
updateIntroStatus st GroupMemberIntro {introId} introStatus' =
updateIntroStatus :: MonadUnliftIO m => SQLiteStore -> Int64 -> GroupMemberIntroStatus -> m ()
updateIntroStatus st introId introStatus =
liftIO . withTransaction st $ \db ->
DB.executeNamed
db
@ -1149,7 +1159,7 @@ updateIntroStatus st GroupMemberIntro {introId} introStatus' =
SET intro_status = :intro_status
WHERE group_member_intro_id = :intro_id
|]
[":intro_status" := introStatus', ":intro_id" := introId]
[":intro_status" := introStatus, ":intro_id" := introId]
saveIntroInvitation :: StoreMonad m => SQLiteStore -> GroupMember -> GroupMember -> IntroInvitation -> m GroupMemberIntro
saveIntroInvitation st reMember toMember introInv = do
@ -1625,7 +1635,7 @@ getSndFileTransfers_ db userId fileId =
Just recipientDisplayName -> Right SndFileTransfer {..}
Nothing -> Left $ SESndFileInvalid fileId
createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m MessageId
createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m Message
createNewMessage st newMsg =
liftIO . withTransaction st $ \db ->
createNewMessage_ db newMsg
@ -1636,12 +1646,13 @@ createSndMsgDelivery st sndMsgDelivery messageId =
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m ()
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m Message
createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery =
liftIO . withTransaction st $ \db -> do
messageId <- createNewMessage_ db newMsg
msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery messageId
msg@Message {msgId} <- createNewMessage_ db newMsg
msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery msgId
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent
pure msg
createSndMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> m ()
createSndMsgDeliveryEvent st connId agentMsgId sndMsgDeliveryStatus =
@ -1655,17 +1666,18 @@ createRcvMsgDeliveryEvent st connId agentMsgId rcvMsgDeliveryStatus =
msgDeliveryId <- ExceptT $ getMsgDeliveryId_ db connId agentMsgId
liftIO $ createMsgDeliveryEvent_ db msgDeliveryId rcvMsgDeliveryStatus
createNewMessage_ :: DB.Connection -> NewMessage -> IO MessageId
createNewMessage_ db NewMessage {direction, chatMsgEventType, msgBody} = do
createNewMessage_ :: DB.Connection -> NewMessage -> IO Message
createNewMessage_ db NewMessage {direction, cmEventTag, chatTs, msgBody} = do
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO messages
(msg_sent, chat_msg_event, msg_body, created_at) VALUES (?,?,?,?);
(msg_sent, chat_msg_event, chat_ts, msg_body, created_at) VALUES (?,?,?,?,?);
|]
(direction, chatMsgEventType, msgBody, createdAt)
insertedRowId db
(direction, cmEventTag, chatTs, msgBody, createdAt)
msgId <- insertedRowId db
pure Message {msgId, direction, cmEventTag, chatTs, msgBody, createdAt}
createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId = do
@ -1720,6 +1732,41 @@ getMsgDeliveryId_ db connId agentMsgId =
toMsgDeliveryId [Only msgDeliveryId] = Right msgDeliveryId
toMsgDeliveryId _ = Left $ SENoMsgDelivery connId agentMsgId
createPendingGroupMessage :: MonadUnliftIO m => SQLiteStore -> Int64 -> MessageId -> Maybe Int64 -> m ()
createPendingGroupMessage st groupMemberId messageId introId_ =
liftIO . withTransaction st $ \db -> do
createdAt <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO pending_group_messages
(group_member_id, message_id, group_member_intro_id, created_at) VALUES (?,?,?,?)
|]
(groupMemberId, messageId, introId_, createdAt)
getPendingGroupMessages :: MonadUnliftIO m => SQLiteStore -> Int64 -> m [PendingGroupMessage]
getPendingGroupMessages st groupMemberId =
liftIO . withTransaction st $ \db ->
map pendingGroupMessage
<$> DB.query
db
[sql|
SELECT pgm.message_id, m.chat_msg_event, m.msg_body, pgm.group_member_intro_id
FROM pending_group_messages pgm
JOIN messages m USING (message_id)
WHERE pgm.group_member_id = ?
ORDER BY pgm.message_id ASC
|]
(Only groupMemberId)
where
pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) =
PendingGroupMessage {msgId, cmEventTag, msgBody, introId_}
deletePendingGroupMessage :: MonadUnliftIO m => SQLiteStore -> Int64 -> MessageId -> m ()
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)
-- | 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)

1
src/Simplex/Chat/Styled.hs
View file

@ -21,6 +21,7 @@ import Simplex.Chat.Markdown
import System.Console.ANSI.Types
data StyledString = Styled [SGR] String | StyledString :<>: StyledString
deriving (Show)
instance Semigroup StyledString where (<>) = (:<>:)

8
src/Simplex/Chat/Terminal.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Chat.Terminal where
import Control.Logger.Simple
@ -24,15 +22,15 @@ simplexChat cfg opts t
| otherwise = initRun
where
initRun = do
sendNotification <- initializeNotifications
sendNotification' <- initializeNotifications
let f = chatStoreFile $ dbFilePrefix opts
st <- createStore f $ dbPoolSize cfg
user <- getCreateActiveUser st
ct <- newChatTerminal t
cc <- newChatController st user cfg opts sendNotification
cc <- newChatController st user cfg opts sendNotification'
runSimplexChat user ct cc
runSimplexChat :: User -> ChatTerminal -> ChatController -> IO ()
runSimplexChat user ct = runReaderT $ do
whenM (asks firstTime) . liftIO . printToTerminal ct $ chatWelcome user
raceAny_ [runTerminalInput ct, runTerminalOutput ct, runChatController]
raceAny_ [runTerminalInput ct, runTerminalOutput ct, runInputLoop ct, runChatController]

13
src/Simplex/Chat/Terminal/Input.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Terminal.Input where
@ -8,8 +9,10 @@ import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Data.List (dropWhileEnd)
import qualified Data.Text as T
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Terminal.Output
import Simplex.Chat.View
import System.Exit (exitSuccess)
import System.Terminal hiding (insertChars)
import UnliftIO.STM
@ -21,6 +24,14 @@ getKey =
Right (KeyEvent key ms) -> pure (key, ms)
_ -> getKey
runInputLoop :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
runInputLoop ct = do
q <- asks inputQ
forever $ do
s <- atomically $ readTBQueue q
r <- execChatCommand s
liftIO . printToTerminal ct $ responseToView s r
runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m ()
runTerminalInput ct = do
cc <- ask
@ -45,7 +56,7 @@ receiveFromTTY ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, term
ts <- readTVar termState
let s = inputString ts
writeTVar termState $ ts {inputString = "", inputPosition = 0, previousInput = s}
writeTBQueue inputQ $ InputCommand s
writeTBQueue inputQ s
updateTermState :: ActiveTo -> Int -> (Key, Modifiers) -> TerminalState -> TerminalState
updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p} = case key of

3
src/Simplex/Chat/Terminal/Output.hs
View file

@ -12,6 +12,7 @@ import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Simplex.Chat.Controller
import Simplex.Chat.Styled
import Simplex.Chat.View
import System.Console.ANSI.Types
import System.Terminal
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
@ -75,7 +76,7 @@ runTerminalOutput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerm
runTerminalOutput ct = do
ChatController {outputQ} <- ask
forever $
atomically (readTBQueue outputQ) >>= liftIO . printToTerminal ct
atomically (readTBQueue outputQ) >>= liftIO . printToTerminal ct . responseToView "" . snd
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ct s =

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

@ -8,7 +8,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Types where
@ -16,15 +15,11 @@ import Data.Aeson (FromJSON, ToJSON, (.:), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (UTCTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError)
@ -32,10 +27,9 @@ import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, MsgMeta (..), serializeMsgIntegrity)
import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Util ((<$?>))
class IsContact a where
@ -60,7 +54,7 @@ data User = User
profile :: Profile,
activeUser :: Bool
}
deriving (Generic, FromJSON)
deriving (Show, Generic, FromJSON)
instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions
@ -110,6 +104,14 @@ data Group = Group
}
deriving (Eq, Show)
data GroupInfo = GroupInfo
{ groupId :: Int64,
localDisplayName :: GroupName,
groupProfile :: GroupProfile,
userMemberStatus :: GroupMemberStatus
}
deriving (Show)
data Profile = Profile
{ displayName :: ContactName,
fullName :: Text
@ -409,7 +411,7 @@ serializeMemberStatus = \case
GSMemCreator -> "creator"
data SndFileTransfer = SndFileTransfer
{ fileId :: Int64,
{ fileId :: FileTransferId,
fileName :: String,
filePath :: String,
fileSize :: Integer,
@ -421,6 +423,8 @@ data SndFileTransfer = SndFileTransfer
}
deriving (Eq, Show)
type FileTransferId = Int64
data FileInvitation = FileInvitation
{ fileName :: String,
fileSize :: Integer,
@ -446,7 +450,7 @@ instance ToJSON FileInvitation where
<> "fileConnReq" .= fileConnReq
data RcvFileTransfer = RcvFileTransfer
{ fileId :: Int64,
{ fileId :: FileTransferId,
fileInvitation :: FileInvitation,
fileStatus :: RcvFileStatus,
senderDisplayName :: ContactName,
@ -470,6 +474,7 @@ data RcvFileInfo = RcvFileInfo
deriving (Eq, Show)
data FileTransfer = FTSnd [SndFileTransfer] | FTRcv RcvFileTransfer
deriving (Show)
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
@ -592,6 +597,7 @@ data GroupMemberIntro = GroupMemberIntro
introStatus :: GroupMemberIntroStatus,
introInvitation :: Maybe IntroInvitation
}
deriving (Show)
data GroupMemberIntroStatus
= GMIntroPending
@ -601,6 +607,7 @@ data GroupMemberIntroStatus
| GMIntroReConnected
| GMIntroToConnected
| GMIntroConnected
deriving (Show)
instance FromField GroupMemberIntroStatus where fromField = fromTextField_ introStatusT
@ -627,124 +634,8 @@ serializeIntroStatus = \case
GMIntroToConnected -> "to-con"
GMIntroConnected -> "con"
data NewMessage = NewMessage
{ direction :: MsgDirection,
chatMsgEventType :: Text,
msgBody :: MsgBody
}
type MessageId = Int64
data MsgDirection = MDRcv | MDSnd
data SMsgDirection (d :: MsgDirection) where
SMDRcv :: SMsgDirection 'MDRcv
SMDSnd :: SMsgDirection 'MDSnd
instance TestEquality SMsgDirection where
testEquality SMDRcv SMDRcv = Just Refl
testEquality SMDSnd SMDSnd = Just Refl
testEquality _ _ = Nothing
class MsgDirectionI (d :: MsgDirection) where
msgDirection :: SMsgDirection d
instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
instance ToField MsgDirection where toField = toField . msgDirectionInt
msgDirectionInt :: MsgDirection -> Int
msgDirectionInt = \case
MDRcv -> 0
MDSnd -> 1
msgDirectionIntP :: Int -> Maybe MsgDirection
msgDirectionIntP = \case
0 -> Just MDRcv
1 -> Just MDSnd
_ -> Nothing
data SndMsgDelivery = SndMsgDelivery
{ connId :: Int64,
agentMsgId :: AgentMsgId
}
data RcvMsgDelivery = RcvMsgDelivery
{ connId :: Int64,
agentMsgId :: AgentMsgId,
agentMsgMeta :: MsgMeta
}
data MsgMetaJSON = MsgMetaJSON
{ integrity :: Text,
rcvId :: Int64,
rcvTs :: UTCTime,
serverId :: Text,
serverTs :: UTCTime,
sndId :: Int64
}
deriving (Eq, Show, FromJSON, Generic)
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions
msgMetaToJson :: MsgMeta -> MsgMetaJSON
msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} =
MsgMetaJSON
{ integrity = (decodeLatin1 . serializeMsgIntegrity) integrity,
rcvId,
rcvTs,
serverId = (decodeLatin1 . B64.encode) serverId,
serverTs,
sndId
}
msgMetaJson :: MsgMeta -> Text
msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson
data MsgDeliveryStatus (d :: MsgDirection) where
MDSRcvAgent :: MsgDeliveryStatus 'MDRcv
MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv
MDSSndPending :: MsgDeliveryStatus 'MDSnd
MDSSndAgent :: MsgDeliveryStatus 'MDSnd
MDSSndSent :: MsgDeliveryStatus 'MDSnd
MDSSndReceived :: MsgDeliveryStatus 'MDSnd
MDSSndRead :: MsgDeliveryStatus 'MDSnd
data AMsgDeliveryStatus = forall d. AMDS (SMsgDirection d) (MsgDeliveryStatus d)
instance (Typeable d, MsgDirectionI d) => FromField (MsgDeliveryStatus d) where
fromField = fromTextField_ msgDeliveryStatusT'
instance ToField (MsgDeliveryStatus d) where toField = toField . serializeMsgDeliveryStatus
serializeMsgDeliveryStatus :: MsgDeliveryStatus d -> Text
serializeMsgDeliveryStatus = \case
MDSRcvAgent -> "rcv_agent"
MDSRcvAcknowledged -> "rcv_acknowledged"
MDSSndPending -> "snd_pending"
MDSSndAgent -> "snd_agent"
MDSSndSent -> "snd_sent"
MDSSndReceived -> "snd_received"
MDSSndRead -> "snd_read"
msgDeliveryStatusT :: Text -> Maybe AMsgDeliveryStatus
msgDeliveryStatusT = \case
"rcv_agent" -> Just $ AMDS SMDRcv MDSRcvAgent
"rcv_acknowledged" -> Just $ AMDS SMDRcv MDSRcvAcknowledged
"snd_pending" -> Just $ AMDS SMDSnd MDSSndPending
"snd_agent" -> Just $ AMDS SMDSnd MDSSndAgent
"snd_sent" -> Just $ AMDS SMDSnd MDSSndSent
"snd_received" -> Just $ AMDS SMDSnd MDSSndReceived
"snd_read" -> Just $ AMDS SMDSnd MDSSndRead
_ -> Nothing
msgDeliveryStatusT' :: forall d. MsgDirectionI d => Text -> Maybe (MsgDeliveryStatus d)
msgDeliveryStatusT' s =
msgDeliveryStatusT s >>= \(AMDS d st) ->
case testEquality d (msgDirection @d) of
Just Refl -> Just st
_ -> Nothing
data Notification = Notification {title :: Text, text :: Text}
type JSONString = String

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

@ -1,114 +1,125 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.View
( safeDecodeUtf8,
msgPlain,
clientVersionInfo,
viewConnReqInvitation,
viewSentConfirmation,
viewSentInvitation,
viewInvalidConnReq,
viewContactDeleted,
viewContactGroups,
viewContactsList,
viewUserContactLinkCreated,
viewUserContactLinkDeleted,
viewUserContactLink,
viewAcceptingContactRequest,
viewContactRequestRejected,
viewGroupCreated,
viewSentGroupInvitation,
viewCannotResendInvitation,
viewDeletedMember,
viewLeftMemberUser,
viewGroupDeletedUser,
viewGroupMembers,
viewSentFileInfo,
viewRcvFileAccepted,
viewRcvFileSndCancelled,
viewSndGroupFileCancelled,
viewRcvFileCancelled,
viewFileTransferStatus,
viewUserProfileUpdated,
viewUserProfile,
viewChatError,
viewSentMessage,
viewSentGroupMessage,
viewSentGroupFileInvitation,
viewSentFileInvitation,
viewGroupsList,
viewContactSubscribed,
viewContactSubError,
viewGroupInvitation,
viewGroupEmpty,
viewGroupRemoved,
viewMemberSubError,
viewGroupSubscribed,
viewSndFileSubError,
viewRcvFileSubError,
viewUserContactLinkSubscribed,
viewUserContactLinkSubError,
viewContactConnected,
viewContactDisconnected,
viewContactAnotherClient,
viewJoinedGroupMember,
viewUserJoinedGroup,
viewJoinedGroupMemberConnecting,
viewConnectedToGroupMember,
viewReceivedGroupInvitation,
viewDeletedMemberUser,
viewLeftMember,
viewSndFileStart,
viewSndFileComplete,
viewSndFileCancelled,
viewSndFileRcvCancelled,
viewRcvFileStart,
viewRcvFileComplete,
viewReceivedContactRequest,
viewMessageError,
viewReceivedMessage,
viewReceivedGroupMessage,
viewReceivedFileInvitation,
viewReceivedGroupFileInvitation,
viewContactUpdated,
viewContactsMerged,
viewGroupDeleted,
)
where
module Simplex.Chat.View where
import Data.ByteString.Char8 (ByteString)
import Data.Composition ((.:))
import Data.Function (on)
import Data.Int (Int64)
import Data.List (groupBy, intersperse, sort, sortOn)
import Data.List (groupBy, intersperse, sortOn)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (DiffTime, UTCTime)
import Data.Time.Clock (DiffTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTime, localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, zonedTimeToLocalTime)
import Data.Time.LocalTime (ZonedTime (..), localDay, localTimeOfDay, timeOfDayToTime, utcToZonedTime)
import Numeric (showFFloat)
import Simplex.Chat.Controller
import Simplex.Chat.Help
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Protocol
import Simplex.Chat.Store (StoreError (..))
import Simplex.Chat.Styled
import Simplex.Chat.Types
import Simplex.Chat.Util (safeDecodeUtf8)
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Encoding.String
import qualified Simplex.Messaging.Protocol as SMP
import System.Console.ANSI.Types
viewSentConfirmation :: [StyledString]
viewSentConfirmation = ["confirmation sent!"]
serializeChatResponse :: ChatResponse -> String
serializeChatResponse = unlines . map unStyle . responseToView ""
viewSentInvitation :: [StyledString]
viewSentInvitation = ["connection request sent!"]
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
CRCommandAccepted _ -> r []
CRChatHelp section -> case section of
HSMain -> r chatHelpInfo
HSFiles -> r filesHelpInfo
HSGroups -> r groupsHelpInfo
HSMyAddress -> r myAddressHelpInfo
HSMarkdown -> r markdownInfo
CRWelcome user -> r $ chatWelcome user
CRContactsList cs -> r $ viewContactsList cs
CRUserContactLink cReq -> r $ connReqContact_ "Your chat address:" cReq
CRContactRequestRejected c -> r [ttyContact c <> ": contact request rejected"]
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]
CRFileTransferStatus ftStatus -> r $ viewFileTransferStatus ftStatus
CRUserProfile p -> r $ viewUserProfile p
CRUserProfileNoChange -> r ["user profile did not change"]
CRVersionInfo -> r [plain versionStr, plain updateStr]
CRChatCmdError e -> r $ viewChatError e
CRInvitation cReq -> r' $ viewConnReqInvitation cReq
CRSentConfirmation -> r' ["confirmation sent!"]
CRSentInvitation -> r' ["connection request sent!"]
CRContactDeleted c -> r' [ttyContact c <> ": contact is deleted"]
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"]
CRRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath ->
r' ["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
CRRcvFileAcceptedSndCancelled ft -> r' $ viewRcvFileSndCancelled ft
CRSndGroupFileCancelled fts -> r' $ viewSndGroupFileCancelled fts
CRRcvFileCancelled ft -> r' $ receivingFile_ "cancelled" ft
CRUserProfileUpdated p p' -> r' $ viewUserProfileUpdated p p'
CRContactUpdated c c' -> viewContactUpdated c c'
CRContactsMerged intoCt mergedCt -> viewContactsMerged intoCt mergedCt
CRReceivedContactRequest c p -> viewReceivedContactRequest c p
CRRcvFileStart ft -> receivingFile_ "started" ft
CRRcvFileComplete ft -> receivingFile_ "completed" ft
CRRcvFileSndCancelled ft -> viewRcvFileSndCancelled ft
CRSndFileStart ft -> sendingFile_ "started" ft
CRSndFileComplete ft -> sendingFile_ "completed" ft
CRSndFileCancelled ft -> sendingFile_ "cancelled" ft
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}} ->
[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"]
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]
CRGroupSubscribed g -> [ttyFullGroup g <> ": connected to server(s)"]
CRSndFileSubError SndFileTransfer {fileId, fileName} e ->
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
CRRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e ->
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"]
CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"]
CRMessageError prefix err -> [plain prefix <> ": " <> plain err]
CRChatError e -> viewChatError e
where
r = (plain cmd :)
-- this function should be `id` in case of asynchronous command responses
r' = r
viewInvalidConnReq :: [StyledString]
viewInvalidConnReq =
@ -118,9 +129,6 @@ viewInvalidConnReq =
plain updateStr
]
viewUserContactLinkSubscribed :: [StyledString]
viewUserContactLinkSubscribed = ["Your address is active! To show: " <> highlight' "/sa"]
viewConnReqInvitation :: ConnReqInvitation -> [StyledString]
viewConnReqInvitation cReq =
[ "pass this invitation link to your contact (via another channel): ",
@ -130,49 +138,17 @@ viewConnReqInvitation cReq =
"and ask them to connect: " <> highlight' "/c <invitation_link_above>"
]
viewContactDeleted :: ContactName -> [StyledString]
viewContactDeleted c = [ttyContact c <> ": contact is deleted"]
viewContactGroups :: ContactName -> [GroupName] -> [StyledString]
viewContactGroups c gNames = [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
where
ttyGroups :: [GroupName] -> StyledString
ttyGroups [] = ""
ttyGroups [g] = ttyGroup g
ttyGroups (g : gs) = ttyGroup g <> ", " <> ttyGroups gs
viewContactsList :: [Contact] -> [StyledString]
viewContactsList =
let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
in map ttyFullContact . sortOn ldn
viewContactConnected :: Contact -> [StyledString]
viewContactConnected ct = [ttyFullContact ct <> ": contact is connected"]
viewContactDisconnected :: ContactName -> [StyledString]
viewContactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"]
viewContactAnotherClient :: ContactName -> [StyledString]
viewContactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
viewContactSubscribed :: ContactName -> [StyledString]
viewContactSubscribed c = [ttyContact c <> ": connected to server"]
viewContactSubError :: ContactName -> ChatError -> [StyledString]
viewContactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
viewUserContactLinkCreated :: ConnReqContact -> [StyledString]
viewUserContactLinkCreated = connReqContact_ "Your new chat address is created!"
viewUserContactLinkDeleted :: [StyledString]
viewUserContactLinkDeleted =
[ "Your chat address is deleted - accepted contacts will remain connected.",
"To create a new chat address use " <> highlight' "/ad"
]
viewUserContactLink :: ConnReqContact -> [StyledString]
viewUserContactLink = connReqContact_ "Your chat address:"
connReqContact_ :: StyledString -> ConnReqContact -> [StyledString]
connReqContact_ intro cReq =
[ intro,
@ -191,48 +167,12 @@ viewReceivedContactRequest c Profile {fullName} =
"to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)"
]
viewAcceptingContactRequest :: ContactName -> [StyledString]
viewAcceptingContactRequest c = [ttyContact c <> ": accepting contact request..."]
viewContactRequestRejected :: ContactName -> [StyledString]
viewContactRequestRejected c = [ttyContact c <> ": contact request rejected"]
viewUserContactLinkSubError :: ChatError -> [StyledString]
viewUserContactLinkSubError e =
[ "user address error: " <> sShow e,
"to delete your address: " <> highlight' "/da"
]
viewGroupSubscribed :: Group -> [StyledString]
viewGroupSubscribed g = [ttyFullGroup g <> ": connected to server(s)"]
viewGroupEmpty :: Group -> [StyledString]
viewGroupEmpty g = [ttyFullGroup g <> ": group is empty"]
viewGroupRemoved :: Group -> [StyledString]
viewGroupRemoved g = [ttyFullGroup g <> ": you are no longer a member or group deleted"]
viewMemberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
viewMemberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e]
viewGroupCreated :: Group -> [StyledString]
viewGroupCreated g@Group {localDisplayName} =
[ "group " <> ttyFullGroup g <> " is created",
"use " <> highlight ("/a " <> localDisplayName <> " <name>") <> " to add members"
]
viewGroupDeletedUser :: GroupName -> [StyledString]
viewGroupDeletedUser g = groupDeleted_ g Nothing
viewGroupDeleted :: GroupName -> GroupMember -> [StyledString]
viewGroupDeleted g m = groupDeleted_ g (Just m) <> ["use " <> highlight ("/d #" <> g) <> " to delete the local copy of the group"]
groupDeleted_ :: GroupName -> Maybe GroupMember -> [StyledString]
groupDeleted_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " deleted the group"]
viewSentGroupInvitation :: GroupName -> ContactName -> [StyledString]
viewSentGroupInvitation g c = ["invitation to join the group " <> ttyGroup g <> " sent to " <> ttyContact c]
viewCannotResendInvitation :: GroupName -> ContactName -> [StyledString]
viewCannotResendInvitation g c =
[ ttyContact c <> " is already invited to group " <> ttyGroup g,
@ -245,39 +185,9 @@ viewReceivedGroupInvitation g@Group {localDisplayName} c role =
"use " <> highlight ("/j " <> localDisplayName) <> " to accept"
]
viewJoinedGroupMember :: GroupName -> GroupMember -> [StyledString]
viewJoinedGroupMember g m = [ttyGroup g <> ": " <> ttyMember m <> " joined the group "]
viewUserJoinedGroup :: GroupName -> [StyledString]
viewUserJoinedGroup g = [ttyGroup g <> ": you joined the group"]
viewJoinedGroupMemberConnecting :: GroupName -> GroupMember -> GroupMember -> [StyledString]
viewJoinedGroupMemberConnecting g host m = [ttyGroup g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
viewConnectedToGroupMember :: GroupName -> GroupMember -> [StyledString]
viewConnectedToGroupMember g m = [ttyGroup g <> ": " <> connectedMember m <> " is connected"]
viewDeletedMember :: GroupName -> Maybe GroupMember -> Maybe GroupMember -> [StyledString]
viewDeletedMember g by m = [ttyGroup g <> ": " <> memberOrUser by <> " removed " <> memberOrUser m <> " from the group"]
viewDeletedMemberUser :: GroupName -> GroupMember -> [StyledString]
viewDeletedMemberUser g by = viewDeletedMember g (Just by) Nothing <> groupPreserved g
viewLeftMemberUser :: GroupName -> [StyledString]
viewLeftMemberUser g = leftMember_ g Nothing <> groupPreserved g
viewLeftMember :: GroupName -> GroupMember -> [StyledString]
viewLeftMember g m = leftMember_ g (Just m)
leftMember_ :: GroupName -> Maybe GroupMember -> [StyledString]
leftMember_ g m = [ttyGroup g <> ": " <> memberOrUser m <> " left the group"]
groupPreserved :: GroupName -> [StyledString]
groupPreserved g = ["use " <> highlight ("/d #" <> g) <> " to delete the group"]
memberOrUser :: Maybe GroupMember -> StyledString
memberOrUser = maybe "you" ttyMember
connectedMember :: GroupMember -> StyledString
connectedMember m = case memberCategory m of
GCPreMember -> "member " <> ttyFullMember m
@ -304,16 +214,15 @@ viewGroupMembers Group {membership, members} = map groupMember . filter (not . r
GSMemCreator -> "created group"
_ -> ""
viewGroupsList :: [(GroupName, Text, GroupMemberStatus)] -> [StyledString]
viewGroupsList :: [GroupInfo] -> [StyledString]
viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g <name>"]
viewGroupsList gs = map groupSS $ sort gs
viewGroupsList gs = map groupSS $ sortOn ldn_ gs
where
groupSS (displayName, fullName, GSMemInvited) = groupInvitation displayName fullName
groupSS (displayName, fullName, _) = ttyGroup displayName <> optFullName displayName fullName
viewGroupInvitation :: Group -> [StyledString]
viewGroupInvitation Group {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} =
[groupInvitation ldn fullName]
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName)
groupSS GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, userMemberStatus} =
case userMemberStatus of
GSMemInvited -> groupInvitation ldn fullName
_ -> ttyGroup ldn <> optFullName ldn fullName
groupInvitation :: GroupName -> Text -> StyledString
groupInvitation displayName fullName =
@ -326,7 +235,7 @@ groupInvitation displayName fullName =
<> " to delete invitation)"
viewContactsMerged :: Contact -> Contact -> [StyledString]
viewContactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayName = c2} =
viewContactsMerged _into@Contact {localDisplayName = c1} _merged@Contact {localDisplayName = c2} =
[ "contact " <> ttyContact c2 <> " is merged into " <> ttyContact c1,
"use " <> ttyToContact c1 <> highlight' "<message>" <> " to send messages"
]
@ -338,15 +247,13 @@ viewUserProfile Profile {displayName, fullName} =
"(the updated profile will be sent to all your contacts)"
]
viewUserProfileUpdated :: User -> User -> [StyledString]
viewUserProfileUpdated
User {localDisplayName = n, profile = Profile {fullName}}
User {localDisplayName = n', profile = Profile {fullName = fullName'}}
| n == n' && fullName == fullName' = []
| n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
| otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
where
notified = " (your contacts are notified)"
viewUserProfileUpdated :: Profile -> Profile -> [StyledString]
viewUserProfileUpdated Profile {displayName = n, fullName} Profile {displayName = n', fullName = fullName'}
| n == n' && fullName == fullName' = []
| n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
| otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
where
notified = " (your contacts are notified)"
viewContactUpdated :: Contact -> Contact -> [StyledString]
viewContactUpdated
@ -361,25 +268,19 @@ viewContactUpdated
where
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
viewMessageError :: Text -> Text -> [StyledString]
viewMessageError prefix err = [plain prefix <> ": " <> plain err]
viewReceivedMessage :: StyledString -> ChatMsgMeta -> MsgContent -> MsgIntegrity -> [StyledString]
viewReceivedMessage from meta mc = receivedWithTime_ from meta (ttyMsgContent mc)
viewReceivedMessage :: ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
viewReceivedMessage = viewReceivedMessage_ . ttyFromContact
viewReceivedGroupMessage :: GroupName -> ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
viewReceivedGroupMessage = viewReceivedMessage_ .: ttyFromGroup
viewReceivedMessage_ :: StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
viewReceivedMessage_ from utcTime msg mOk = do
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
pure $ prependFirst (t <> " " <> from) msg ++ showIntegrity mOk
receivedWithTime_ :: StyledString -> ChatMsgMeta -> [StyledString] -> MsgIntegrity -> [StyledString]
receivedWithTime_ from ChatMsgMeta {localChatTs, createdAt} styledMsg mOk = do
prependFirst (formattedTime <> " " <> from) styledMsg ++ showIntegrity mOk
where
formatUTCTime :: TimeZone -> ZonedTime -> StyledString
formatUTCTime localTz currentTime =
let localTime = utcToLocalTime localTz utcTime
formattedTime :: StyledString
formattedTime =
let localTime = zonedTimeToLocalTime localChatTs
tz = zonedTimeZone localChatTs
format =
if (localDay localTime < localDay (zonedTimeToLocalTime currentTime))
if (localDay localTime < localDay (zonedTimeToLocalTime $ utcToZonedTime tz createdAt))
&& (timeOfDayToTime (localTimeOfDay localTime) > (6 * 60 * 60 :: DiffTime))
then "%m-%d" -- if message is from yesterday or before and 6 hours has passed since midnight
else "%H:%M"
@ -396,28 +297,26 @@ viewReceivedMessage_ from utcTime msg mOk = do
msgError :: String -> [StyledString]
msgError s = [styled (Colored Red) s]
viewSentMessage :: ContactName -> ByteString -> IO [StyledString]
viewSentMessage = viewSentMessage_ . ttyToContact
viewSentMessage :: StyledString -> MsgContent -> ChatMsgMeta -> [StyledString]
viewSentMessage to = sentWithTime_ . prependFirst to . ttyMsgContent
viewSentGroupMessage :: GroupName -> ByteString -> IO [StyledString]
viewSentGroupMessage = viewSentMessage_ . ttyToGroup
viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> ChatMsgMeta -> [StyledString]
viewSentFileInvitation to fId fPath = sentWithTime_ $ ttySentFile to fId fPath
viewSentMessage_ :: StyledString -> ByteString -> IO [StyledString]
viewSentMessage_ to msg = sentWithTime_ to . msgPlain $ safeDecodeUtf8 msg
sentWithTime_ :: [StyledString] -> ChatMsgMeta -> [StyledString]
sentWithTime_ styledMsg ChatMsgMeta {localChatTs} =
prependFirst (ttyMsgTime localChatTs <> " ") styledMsg
viewSentFileInvitation :: ContactName -> FilePath -> IO [StyledString]
viewSentFileInvitation = viewSentFileInvitation_ . ttyToContact
ttyMsgTime :: ZonedTime -> StyledString
ttyMsgTime = styleTime . formatTime defaultTimeLocale "%H:%M"
viewSentGroupFileInvitation :: GroupName -> FilePath -> IO [StyledString]
viewSentGroupFileInvitation = viewSentFileInvitation_ . ttyToGroup
ttyMsgContent :: MsgContent -> [StyledString]
ttyMsgContent = \case
MCText t -> msgPlain t
MCUnknown -> ["unknown message type"]
viewSentFileInvitation_ :: StyledString -> FilePath -> IO [StyledString]
viewSentFileInvitation_ to f = sentWithTime_ ("/f " <> to) [ttyFilePath f]
sentWithTime_ :: StyledString -> [StyledString] -> IO [StyledString]
sentWithTime_ to styledMsg = do
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
pure $ prependFirst (styleTime time <> " " <> to) styledMsg
ttySentFile :: StyledString -> FileTransferId -> FilePath -> [StyledString]
ttySentFile to fId fPath = ["/f " <> to <> ttyFilePath fPath, "use " <> highlight ("/fc " <> show fId) <> " to cancel sending"]
prependFirst :: StyledString -> [StyledString] -> [StyledString]
prependFirst s [] = [s]
@ -426,18 +325,9 @@ prependFirst s (s' : ss) = (s <> s') : ss
msgPlain :: Text -> [StyledString]
msgPlain = map styleMarkdownText . T.lines
viewSentFileInfo :: Int64 -> [StyledString]
viewSentFileInfo fileId =
["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
viewSndFileStart :: SndFileTransfer -> [StyledString]
viewSndFileStart = sendingFile_ "started"
viewSndFileComplete :: SndFileTransfer -> [StyledString]
viewSndFileComplete = sendingFile_ "completed"
viewSndFileCancelled :: SndFileTransfer -> [StyledString]
viewSndFileCancelled = sendingFile_ "cancelled"
viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
[ttyContact c <> " cancelled sending " <> rcvFile ft]
viewSndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
viewSndGroupFileCancelled fts =
@ -449,18 +339,11 @@ sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
viewSndFileRcvCancelled :: SndFileTransfer -> [StyledString]
viewSndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} =
[ttyContact c <> " cancelled receiving " <> sndFile ft]
sndFile :: SndFileTransfer -> StyledString
sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName
viewReceivedFileInvitation :: ContactName -> UTCTime -> RcvFileTransfer -> MsgIntegrity -> IO [StyledString]
viewReceivedFileInvitation c ts = viewReceivedMessage c ts . receivedFileInvitation_
viewReceivedGroupFileInvitation :: GroupName -> ContactName -> UTCTime -> RcvFileTransfer -> MsgIntegrity -> IO [StyledString]
viewReceivedGroupFileInvitation g c ts = viewReceivedGroupMessage g c ts . receivedFileInvitation_
viewReceivedFileInvitation :: StyledString -> ChatMsgMeta -> RcvFileTransfer -> MsgIntegrity -> [StyledString]
viewReceivedFileInvitation from meta ft = receivedWithTime_ from meta (receivedFileInvitation_ ft)
receivedFileInvitation_ :: RcvFileTransfer -> [StyledString]
receivedFileInvitation_ RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} =
@ -480,27 +363,10 @@ humanReadableSize size
mB = kB * 1024
gB = mB * 1024
viewRcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString]
viewRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath =
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
viewRcvFileStart :: RcvFileTransfer -> [StyledString]
viewRcvFileStart = receivingFile_ "started"
viewRcvFileComplete :: RcvFileTransfer -> [StyledString]
viewRcvFileComplete = receivingFile_ "completed"
viewRcvFileCancelled :: RcvFileTransfer -> [StyledString]
viewRcvFileCancelled = receivingFile_ "cancelled"
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
[status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c]
viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
[ttyContact c <> " cancelled sending " <> rcvFile ft]
rcvFile :: RcvFileTransfer -> StyledString
rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransfer fileId fileName
@ -550,17 +416,11 @@ fileProgress :: [Integer] -> Integer -> Integer -> StyledString
fileProgress chunksNum chunkSize fileSize =
sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize
viewSndFileSubError :: SndFileTransfer -> ChatError -> [StyledString]
viewSndFileSubError SndFileTransfer {fileId, fileName} e =
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
viewRcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString]
viewRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e =
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
viewChatError :: ChatError -> [StyledString]
viewChatError = \case
ChatError err -> case err of
CEInvalidConnReq -> viewInvalidConnReq
CEContactGroups c gNames -> [ttyContact c <> ": contact cannot be deleted, it is a member of the group(s) " <> ttyGroups gNames]
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
CEGroupUserRole -> ["you have insufficient permissions for this group command"]
@ -569,6 +429,8 @@ viewChatError = \case
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"]
CEGroupMemberIntroNotFound c -> ["group member intro not found for " <> ttyContact c]
CEGroupCantResendInvitation g c -> viewCannotResendInvitation g c
CEGroupInternal s -> ["chat group bug: " <> plain s]
CEFileNotFound f -> ["file not found: " <> plain f]
CEFileAlreadyReceiving f -> ["file is already accepted: " <> plain f]
@ -579,6 +441,7 @@ viewChatError = \case
CEFileRcvChunk e -> ["error receiving file: " <> plain e]
CEFileInternal e -> ["file error: " <> plain e]
CEAgentVersion -> ["unsupported agent version"]
CECommandError e -> ["bad chat command: " <> plain e]
-- e -> ["chat error: " <> sShow e]
ChatErrorStore err -> case err of
SEDuplicateName -> ["this display name is already used by user, contact or group"]
@ -626,6 +489,11 @@ ttyFromContact c = styled (Colored Yellow) $ c <> "> "
ttyGroup :: GroupName -> StyledString
ttyGroup g = styled (Colored Blue) $ "#" <> g
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
@ -652,6 +520,3 @@ highlight' = highlight
styleTime :: String -> StyledString
styleTime = Styled [SetColor Foreground Vivid Black]
clientVersionInfo :: [StyledString]
clientVersionInfo = [plain versionStr, plain updateStr]

12
tests/ChatTests.hs
View file

@ -84,7 +84,7 @@ testAddContact =
-- test deleting contact
alice ##> "/d bob_1"
alice <## "bob_1: contact is deleted"
alice #> "@bob_1 hey"
alice ##> "@bob_1 hey"
alice <## "no contact bob_1"
testGroup :: IO ()
@ -168,7 +168,7 @@ testGroup =
concurrently_
(bob <# "#team alice> hello")
(cath </)
cath #> "#team hello"
cath ##> "#team hello"
cath <## "you are no longer a member of the group"
bob <##> cath
@ -293,7 +293,7 @@ testGroup2 =
bob <# "#club cath> hey",
(dan </)
]
dan #> "#club how is it going?"
dan ##> "#club how is it going?"
dan <## "you are no longer a member of the group"
dan ##> "/d #club"
dan <## "#club: you deleted the group"
@ -316,7 +316,7 @@ testGroup2 =
concurrently_
(alice <# "#club cath> hey")
(bob </)
bob #> "#club how is it going?"
bob ##> "#club how is it going?"
bob <## "you are no longer a member of the group"
bob ##> "/d #club"
bob <## "#club: you deleted the group"
@ -340,7 +340,7 @@ testGroupDelete =
]
bob ##> "/d #team"
bob <## "#team: you deleted the group"
cath #> "#team hi"
cath ##> "#team hi"
cath <## "you are no longer a member of the group"
cath ##> "/d #team"
cath <## "#team: you deleted the group"
@ -822,7 +822,7 @@ cc #> cmd = do
cc <# cmd
send :: TestCC -> String -> IO ()
send TestCC {chatController = cc} cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd
send TestCC {chatController = cc} cmd = atomically $ writeTBQueue (inputQ cc) cmd
(<##) :: TestCC -> String -> Expectation
cc <## line = getTermLine cc `shouldReturn` line