dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-06-02 06:24:36 +00:00
Code Issues Packages Projects Releases Wiki Activity

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
18 changed files with 1000 additions and 758 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Controller.hs
+128 -7
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)