diff --git a/apps/ios/Shared/Model/ChatModel.swift b/apps/ios/Shared/Model/ChatModel.swift new file mode 100644 index 000000000..df83f32b4 --- /dev/null +++ b/apps/ios/Shared/Model/ChatModel.swift @@ -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 +} diff --git a/apps/ios/SimpleX.xcodeproj/project.pbxproj b/apps/ios/SimpleX.xcodeproj/project.pbxproj index ea1f5ebb1..7ff35241c 100644 --- a/apps/ios/SimpleX.xcodeproj/project.pbxproj +++ b/apps/ios/SimpleX.xcodeproj/project.pbxproj @@ -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 = ""; }; 5C764E7E279C7275000C6508 /* SimpleX (macOS)-Bridging-Header.h */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.h; path = "SimpleX (macOS)-Bridging-Header.h"; sourceTree = ""; }; 5C764E7F279C7276000C6508 /* dummy.m */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.objc; path = dummy.m; sourceTree = ""; }; + 5C764E88279CBCB3000C6508 /* ChatModel.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ChatModel.swift; sourceTree = ""; }; 5CA059C3279559F40002BEB4 /* SimpleXApp.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = SimpleXApp.swift; sourceTree = ""; }; 5CA059C4279559F40002BEB4 /* ContentView.swift */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.swift; path = ContentView.swift; sourceTree = ""; }; 5CA059C5279559F40002BEB4 /* Assets.xcassets */ = {isa = PBXFileReference; lastKnownFileType = folder.assetcatalog; path = Assets.xcassets; sourceTree = ""; }; @@ -143,6 +146,14 @@ name = Frameworks; sourceTree = ""; }; + 5C764E87279CBC8E000C6508 /* Model */ = { + isa = PBXGroup; + children = ( + 5C764E88279CBCB3000C6508 /* ChatModel.swift */, + ); + path = Model; + sourceTree = ""; + }; 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; }; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 8930f5a59..a46f972ce 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index a54690a2a..ba0df4451 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 11e344483..692f91734 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs new file mode 100644 index 000000000..99ce67a12 --- /dev/null +++ b/src/Simplex/Chat/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/Migrations/M20220101_initial.hs b/src/Simplex/Chat/Migrations/M20220101_initial.hs index a326ba060..b1ff29221 100644 --- a/src/Simplex/Chat/Migrations/M20220101_initial.hs +++ b/src/Simplex/Chat/Migrations/M20220101_initial.hs @@ -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 diff --git a/src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs b/src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs new file mode 100644 index 000000000..81e81c7d7 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220122_pending_group_messages.hs @@ -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; +|] diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 33cb54861..8b3fc64c9 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -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) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 0f5cb3766..2873da060 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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 diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index d025d4129..d53b0af76 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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) diff --git a/src/Simplex/Chat/Styled.hs b/src/Simplex/Chat/Styled.hs index a15bd90be..aaed7a4f7 100644 --- a/src/Simplex/Chat/Styled.hs +++ b/src/Simplex/Chat/Styled.hs @@ -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 (<>) = (:<>:) diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 5a658ca5d..648db4a56 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -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] diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 8c5f7b8cf..3670acb43 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -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 diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 4100504f7..eb911a178 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -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 = diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 078add3a1..79bd105c5 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 9158bdf3d..3b78e9bcb 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 " ] -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 <> " ") <> " 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 "] -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' "" <> " 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] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 2a4d4e05b..a8aff6362 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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 "#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 "#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 "#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