diff --git a/apps/ios/Shared/Model/SimpleXAPI.swift b/apps/ios/Shared/Model/SimpleXAPI.swift index 58d47066f3..da3dedaeb0 100644 --- a/apps/ios/Shared/Model/SimpleXAPI.swift +++ b/apps/ios/Shared/Model/SimpleXAPI.swift @@ -15,13 +15,16 @@ private let jsonDecoder = getJSONDecoder() private let jsonEncoder = getJSONEncoder() enum ChatCommand { + case showActiveUser + case createActiveUser(profile: Profile) + case startChat case apiGetChats case apiGetChat(type: ChatType, id: Int64) case apiSendMessage(type: ChatType, id: Int64, msg: MsgContent) case addContact case connect(connReq: String) case apiDeleteChat(type: ChatType, id: Int64) - case apiUpdateProfile(profile: Profile) + case updateProfile(profile: Profile) case createMyAddress case deleteMyAddress case showMyAddress @@ -32,32 +35,22 @@ enum ChatCommand { var cmdString: String { get { switch self { - case .apiGetChats: - return "/_get chats" - case let .apiGetChat(type, id): - return "/_get chat \(type.rawValue)\(id) count=500" - case let .apiSendMessage(type, id, mc): - return "/_send \(type.rawValue)\(id) \(mc.cmdString)" - case .addContact: - return "/connect" - case let .connect(connReq): - return "/connect \(connReq)" - case let .apiDeleteChat(type, id): - return "/_delete \(type.rawValue)\(id)" - case let .apiUpdateProfile(profile): - return "/profile \(profile.displayName) \(profile.fullName)" - case .createMyAddress: - return "/address" - case .deleteMyAddress: - return "/delete_address" - case .showMyAddress: - return "/show_address" - case let .apiAcceptContact(contactReqId): - return "/_accept \(contactReqId)" - case let .apiRejectContact(contactReqId): - return "/_reject \(contactReqId)" - case let .string(str): - return str + case .showActiveUser: return "/u" + case let .createActiveUser(profile): return "/u \(profile.displayName) \(profile.fullName)" + case .startChat: return "/_start" + case .apiGetChats: return "/_get chats" + case let .apiGetChat(type, id): return "/_get chat \(type.rawValue)\(id) count=500" + case let .apiSendMessage(type, id, mc): return "/_send \(type.rawValue)\(id) \(mc.cmdString)" + case .addContact: return "/connect" + case let .connect(connReq): return "/connect \(connReq)" + case let .apiDeleteChat(type, id): return "/_delete \(type.rawValue)\(id)" + case let .updateProfile(profile): return "/profile \(profile.displayName) \(profile.fullName)" + case .createMyAddress: return "/address" + case .deleteMyAddress: return "/delete_address" + case .showMyAddress: return "/show_address" + case let .apiAcceptContact(contactReqId): return "/_accept \(contactReqId)" + case let .apiRejectContact(contactReqId): return "/_reject \(contactReqId)" + case let .string(str): return str } } } @@ -69,6 +62,8 @@ struct APIResponse: Decodable { enum ChatResponse: Decodable, Error { case response(type: String, json: String) + case activeUser(user: User) + case chatStarted case apiChats(chats: [ChatData]) case apiChat(chat: ChatData) case invitation(connReqInvitation: String) @@ -90,11 +85,14 @@ enum ChatResponse: Decodable, Error { case contactSubError(contact: Contact, chatError: ChatError) case newChatItem(chatItem: AChatItem) case chatCmdError(chatError: ChatError) + case chatError(chatError: ChatError) var responseType: String { get { switch self { case let .response(type, _): return "* \(type)" + case .activeUser: return "activeUser" + case .chatStarted: return "chatStarted" case .apiChats: return "apiChats" case .apiChat: return "apiChat" case .invitation: return "invitation" @@ -116,6 +114,7 @@ enum ChatResponse: Decodable, Error { case .contactSubError: return "contactSubError" case .newChatItem: return "newChatItem" case .chatCmdError: return "chatCmdError" + case .chatError: return "chatError" } } } @@ -124,6 +123,8 @@ enum ChatResponse: Decodable, Error { get { switch self { case let .response(_, json): return json + case let .activeUser(user): return String(describing: user) + case .chatStarted: return noDetails case let .apiChats(chats): return String(describing: chats) case let .apiChat(chat): return String(describing: chat) case let .invitation(connReqInvitation): return connReqInvitation @@ -145,6 +146,7 @@ enum ChatResponse: Decodable, Error { case let .contactSubError(contact, chatError): return "contact:\n\(String(describing: contact))\nerror:\n\(String(describing: chatError))" case let .newChatItem(chatItem): return String(describing: chatItem) case let .chatCmdError(chatError): return String(describing: chatError) + case let .chatError(chatError): return String(describing: chatError) } } } @@ -260,7 +262,7 @@ func apiDeleteChat(type: ChatType, id: Int64) throws { } func apiUpdateProfile(profile: Profile) throws -> Profile? { - let r = try chatSendCmd(.apiUpdateProfile(profile: profile)) + let r = try chatSendCmd(.updateProfile(profile: profile)) switch r { case .userProfileNoChange: return nil case let .userProfileUpdated(_, toProfile): return toProfile @@ -423,16 +425,18 @@ private func encodeCJSON(_ value: T) -> [CChar] { enum ChatError: Decodable { case error(errorType: ChatErrorType) - case errorMessage(errorMessage: String) case errorAgent(agentError: AgentErrorType) case errorStore(storeError: StoreError) - case errorNotImplemented } enum ChatErrorType: Decodable { - case groupUserRole + case noActiveUser + case activeUserExists + case chatNotStarted case invalidConnReq + case invalidChatMessage(message: String) case contactGroups(contact: Contact, groupNames: [GroupName]) + case groupUserRole case groupContactRole(contactName: ContactName) case groupDuplicateMember(contactName: ContactName) case groupDuplicateMemberId diff --git a/apps/ios/Shared/Views/Chat/ChatItem/TextItemView.swift b/apps/ios/Shared/Views/Chat/ChatItem/TextItemView.swift index 026fc4d745..43c0c399bc 100644 --- a/apps/ios/Shared/Views/Chat/ChatItem/TextItemView.swift +++ b/apps/ios/Shared/Views/Chat/ChatItem/TextItemView.swift @@ -46,7 +46,6 @@ struct TextItemView: View { private func messageText(_ s: String, sent: Bool = false) -> Text { if s == "" { return Text("") } let parts = s.split(separator: " ") - print(parts) var res = wordToText(parts[0], sent) var i = 1 while i < parts.count { diff --git a/package.yaml b/package.yaml index b8eb26a949..a093a0cdd1 100644 --- a/package.yaml +++ b/package.yaml @@ -14,6 +14,7 @@ extra-source-files: dependencies: - aeson == 2.0.* - ansi-terminal >= 0.10 && < 0.12 + - async == 2.2.* - attoparsec == 0.14.* - base >= 4.7 && < 5 - base64-bytestring >= 1.0 && < 1.3 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 504b01c192..01568eb81f 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -46,6 +46,7 @@ library build-depends: aeson ==2.0.* , ansi-terminal >=0.10 && <0.12 + , async ==2.2.* , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 @@ -80,6 +81,7 @@ executable simplex-chat build-depends: aeson ==2.0.* , ansi-terminal >=0.10 && <0.12 + , async ==2.2.* , attoparsec ==0.14.* , base >=4.7 && <5 , base64-bytestring >=1.0 && <1.3 @@ -112,6 +114,7 @@ test-suite simplex-chat-test ChatClient ChatTests MarkdownTests + MobileTests ProtocolTests Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 65c260a09d..308810edbd 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -43,7 +43,7 @@ import Simplex.Chat.Options (ChatOpts (..)) import Simplex.Chat.Protocol import Simplex.Chat.Store import Simplex.Chat.Types -import Simplex.Chat.Util (ifM, safeDecodeUtf8, unlessM) +import Simplex.Chat.Util (ifM, safeDecodeUtf8, unlessM, whenM) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig) import Simplex.Messaging.Agent.Protocol @@ -58,7 +58,7 @@ 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.Async (Async, async, race_) import UnliftIO.Concurrent (forkIO, threadDelay) import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory) import qualified UnliftIO.Exception as E @@ -83,13 +83,14 @@ defaultChatConfig = logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} -newChatController :: SQLiteStore -> User -> ChatConfig -> ChatOpts -> (Notification -> IO ()) -> IO ChatController +newChatController :: SQLiteStore -> Maybe User -> ChatConfig -> ChatOpts -> (Notification -> IO ()) -> IO ChatController newChatController chatStore user config@ChatConfig {agentConfig = cfg, tbqSize} ChatOpts {dbFilePrefix, smpServers} sendNotification = do let f = chatStoreFile dbFilePrefix activeTo <- newTVarIO ActiveNone firstTime <- not <$> doesFileExist f currentUser <- newTVarIO user smpAgent <- getSMPAgentClient cfg {dbFile = dbFilePrefix <> "_agent.db", smpServers} + agentAsync <- newTVarIO Nothing idsDrg <- newTVarIO =<< drgNew inputQ <- newTBQueueIO tbqSize outputQ <- newTBQueueIO tbqSize @@ -97,10 +98,20 @@ newChatController chatStore user config@ChatConfig {agentConfig = cfg, tbqSize} chatLock <- newTMVarIO () sndFiles <- newTVarIO M.empty rcvFiles <- newTVarIO M.empty - pure ChatController {activeTo, firstTime, currentUser, smpAgent, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification} + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification} -runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m () -runChatController = race_ agentSubscriber notificationSubscriber +runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m () +runChatController = race_ notificationSubscriber . agentSubscriber + +startChatController :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m (Async ()) +startChatController user = do + s <- asks agentAsync + readTVarIO s >>= maybe (start s) pure + where + start s = do + a <- async $ runChatController user + atomically . writeTVar s $ Just a + pure a withLock :: MonadUnliftIO m => TMVar () -> m a -> m a withLock lock = @@ -110,26 +121,31 @@ withLock lock = execChatCommand :: (MonadUnliftIO m, MonadReader ChatController m) => ByteString -> m ChatResponse execChatCommand s = case parseAll chatCommandP $ B.dropWhileEnd isSpace s of - Left e -> pure . CRChatError . ChatError $ CECommandError e - Right cmd -> do - ChatController {currentUser} <- ask - user <- readTVarIO currentUser - either CRChatCmdError id <$> runExceptT (processChatCommand user cmd) + Left e -> pure $ chatCmdError e + Right cmd -> either CRChatCmdError id <$> runExceptT (processChatCommand cmd) toView :: ChatMonad m => ChatResponse -> m () toView event = do q <- asks outputQ atomically $ writeTBQueue q (Nothing, event) -processChatCommand :: forall m. ChatMonad m => User -> ChatCommand -> m ChatResponse -processChatCommand user@User {userId, profile} = \case - APIGetChats -> CRApiChats <$> withStore (`getChatPreviews` user) - APIGetChat cType cId pagination -> case cType of +processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse +processChatCommand = \case + ShowActiveUser -> withUser' $ pure . CRActiveUser + CreateActiveUser p -> do + u <- asks currentUser + whenM (isJust <$> readTVarIO u) $ throwChatError CEActiveUserExists + user <- withStore $ \st -> createUser st p True + atomically . writeTVar u $ Just user + pure $ CRActiveUser user + StartChat -> withUser' $ \user -> startChatController user $> CRChatStarted + APIGetChats -> CRApiChats <$> withUser (\user -> withStore (`getChatPreviews` user)) + APIGetChat cType cId pagination -> withUser $ \user -> case cType of CTDirect -> CRApiChat . AChat SCTDirect <$> withStore (\st -> getDirectChat st user cId pagination) CTGroup -> CRApiChat . AChat SCTGroup <$> withStore (\st -> getGroupChat st user cId pagination) - CTContactRequest -> pure $ CRChatError ChatErrorNotImplemented - APIGetChatItems _count -> pure $ CRChatError ChatErrorNotImplemented - APISendMessage cType chatId mc -> withChatLock $ case cType of + CTContactRequest -> pure $ chatCmdError "not implemented" + APIGetChatItems _pagination -> pure $ chatCmdError "not implemented" + APISendMessage cType chatId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of CTDirect -> do ct@Contact {localDisplayName = c} <- withStore $ \st -> getContact st userId chatId ci <- sendDirectChatItem userId ct (XMsgNew mc) (CISndMsgContent mc) @@ -141,8 +157,8 @@ processChatCommand user@User {userId, profile} = \case ci <- sendGroupChatItem userId group (XMsgNew mc) (CISndMsgContent mc) setActive $ ActiveG gName pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci - CTContactRequest -> pure . CRChatError . ChatError $ CECommandError "not supported" - APIDeleteChat cType chatId -> case cType of + CTContactRequest -> pure $ chatCmdError "not supported" + APIDeleteChat cType chatId -> withUser $ \User {userId} -> case cType of CTDirect -> do ct@Contact {localDisplayName} <- withStore $ \st -> getContact st userId chatId withStore (\st -> getContactGroupNames st userId ct) >>= \case @@ -155,16 +171,16 @@ processChatCommand user@User {userId, profile} = \case unsetActive $ ActiveC localDisplayName pure $ CRContactDeleted ct gs -> throwChatError $ CEContactGroups ct gs - CTGroup -> pure $ CRChatCmdError ChatErrorNotImplemented - CTContactRequest -> pure . CRChatError . ChatError $ CECommandError "not supported" - APIAcceptContact connReqId -> do + CTGroup -> pure $ chatCmdError "not implemented" + CTContactRequest -> pure $ chatCmdError "not supported" + APIAcceptContact connReqId -> withUser $ \User {userId, profile} -> do UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p} <- withStore $ \st -> getContactRequest st userId connReqId withChatLock . procCmd $ do connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profile acceptedContact <- withStore $ \st -> createAcceptedContact st userId connId cName profileId p pure $ CRAcceptingContactRequest acceptedContact - APIRejectContact connReqId -> withChatLock $ do + APIRejectContact connReqId -> withUser $ \User {userId} -> withChatLock $ do cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- withStore $ \st -> getContactRequest st userId connReqId @@ -172,51 +188,51 @@ processChatCommand user@User {userId, profile} = \case withAgent $ \a -> rejectContact a connId invId pure $ CRContactRequestRejected cReq ChatHelp section -> pure $ CRChatHelp section - Welcome -> pure $ CRWelcome user - AddContact -> withChatLock . procCmd $ do + Welcome -> withUser $ pure . CRWelcome + AddContact -> withUser $ \User {userId} -> withChatLock . procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMInvitation) withStore $ \st -> createDirectConnection st userId connId pure $ CRInvitation cReq - Connect (Just (ACR SCMInvitation cReq)) -> withChatLock . procCmd $ do - connect cReq $ XInfo profile + Connect (Just (ACR SCMInvitation cReq)) -> withUser $ \User {userId, profile} -> withChatLock . procCmd $ do + connect userId cReq $ XInfo profile pure CRSentConfirmation - Connect (Just (ACR SCMContact cReq)) -> withChatLock . procCmd $ do - connect cReq $ XContact profile Nothing + Connect (Just (ACR SCMContact cReq)) -> withUser $ \User {userId, profile} -> withChatLock . procCmd $ do + connect userId cReq $ XContact profile Nothing pure CRSentInvitation Connect Nothing -> throwChatError CEInvalidConnReq - ConnectAdmin -> withChatLock . procCmd $ do - connect adminContactReq $ XContact profile Nothing + ConnectAdmin -> withUser $ \User {userId, profile} -> withChatLock . procCmd $ do + connect userId adminContactReq $ XContact profile Nothing pure CRSentInvitation - DeleteContact cName -> do + DeleteContact cName -> withUser $ \User {userId} -> do contactId <- withStore $ \st -> getContactIdByName st userId cName - processChatCommand user $ APIDeleteChat CTDirect contactId - ListContacts -> CRContactsList <$> withStore (`getUserContacts` user) - CreateMyAddress -> withChatLock . procCmd $ do + processChatCommand $ APIDeleteChat CTDirect contactId + ListContacts -> withUser $ \user -> CRContactsList <$> withStore (`getUserContacts` user) + CreateMyAddress -> withUser $ \User {userId} -> withChatLock . procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMContact) withStore $ \st -> createUserContactLink st userId connId cReq pure $ CRUserContactLinkCreated cReq - DeleteMyAddress -> withChatLock $ do + DeleteMyAddress -> withUser $ \User {userId} -> withChatLock $ do conns <- withStore $ \st -> getUserContactLinkConnections st userId procCmd $ do withAgent $ \a -> forM_ conns $ \conn -> deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () withStore $ \st -> deleteUserContactLink st userId pure CRUserContactLinkDeleted - ShowMyAddress -> CRUserContactLink <$> withStore (`getUserContactLink` userId) - AcceptContact cName -> do + ShowMyAddress -> CRUserContactLink <$> (withUser $ \User {userId} -> withStore (`getUserContactLink` userId)) + AcceptContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \st -> getContactRequestIdByName st userId cName - processChatCommand user $ APIAcceptContact connReqId - RejectContact cName -> do + processChatCommand $ APIAcceptContact connReqId + RejectContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \st -> getContactRequestIdByName st userId cName - processChatCommand user $ APIRejectContact connReqId - SendMessage cName msg -> do + processChatCommand $ APIRejectContact connReqId + SendMessage cName msg -> withUser $ \User {userId} -> do contactId <- withStore $ \st -> getContactIdByName st userId cName let mc = MCText $ safeDecodeUtf8 msg - processChatCommand user $ APISendMessage CTDirect contactId mc - NewGroup gProfile -> do + processChatCommand $ APISendMessage CTDirect contactId mc + NewGroup gProfile -> withUser $ \user -> do gVar <- asks idsDrg CRGroupCreated <$> withStore (\st -> createNewGroup st gVar user gProfile) - AddMember gName cName memRole -> withChatLock $ do + AddMember gName cName memRole -> withUser $ \user@User {userId} -> withChatLock $ do -- TODO for large groups: no need to load all members to determine if contact is a member (group, contact) <- withStore $ \st -> (,) <$> getGroupByName st user gName <*> getContactByName st userId cName let Group gInfo@GroupInfo {groupId, groupProfile, membership} members = group @@ -241,7 +257,7 @@ processChatCommand user@User {userId, profile} = \case Just cReq -> sendInvitation memberId cReq Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName | otherwise -> throwChatError $ CEGroupDuplicateMember cName - JoinGroup gName -> do + JoinGroup gName -> withUser $ \user@User {userId} -> do ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g} <- withStore $ \st -> getGroupInvitation st user gName withChatLock . procCmd $ do agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (membership g :: GroupMember) @@ -251,7 +267,7 @@ processChatCommand user@User {userId, profile} = \case updateGroupMemberStatus st userId (membership g) GSMemAccepted pure $ CRUserAcceptedGroupSent g MemberRole _gName _cName _mRole -> throwChatError $ CECommandError "unsupported" - RemoveMember gName cName -> do + RemoveMember gName cName -> withUser $ \user@User {userId} -> do Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName case find ((== cName) . (localDisplayName :: GroupMember -> ContactName)) members of Nothing -> throwChatError $ CEGroupMemberNotFound cName @@ -263,14 +279,14 @@ processChatCommand user@User {userId, profile} = \case deleteMemberConnection m withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved pure $ CRUserDeletedMember gInfo m - LeaveGroup gName -> do + LeaveGroup gName -> withUser $ \user@User {userId} -> do Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName withChatLock . procCmd $ do void $ sendGroupMessage members XGrpLeave mapM_ deleteMemberConnection members withStore $ \st -> updateGroupMemberStatus st userId membership GSMemLeft pure $ CRLeftMemberUser gInfo - DeleteGroup gName -> do + DeleteGroup gName -> withUser $ \user -> do g@(Group gInfo@GroupInfo {membership} members) <- withStore $ \st -> getGroupByName st user gName let s = memberStatus membership canDelete = @@ -282,13 +298,13 @@ processChatCommand user@User {userId, profile} = \case mapM_ deleteMemberConnection members withStore $ \st -> deleteGroup st user g pure $ CRGroupDeletedUser gInfo - ListMembers gName -> CRGroupMembers <$> withStore (\st -> getGroupByName st user gName) - ListGroups -> CRGroupsList <$> withStore (`getUserGroupDetails` user) - SendGroupMessage gName msg -> do + ListMembers gName -> CRGroupMembers <$> (withUser $ \user -> withStore (\st -> getGroupByName st user gName)) + ListGroups -> CRGroupsList <$> withUser (\user -> withStore (`getUserGroupDetails` user)) + SendGroupMessage gName msg -> withUser $ \user -> do groupId <- withStore $ \st -> getGroupIdByName st user gName let mc = MCText $ safeDecodeUtf8 msg - processChatCommand user $ APISendMessage CTGroup groupId mc - SendFile cName f -> withChatLock $ do + processChatCommand $ APISendMessage CTGroup groupId mc + SendFile cName f -> withUser $ \User {userId} -> withChatLock $ do (fileSize, chSize) <- checkSndFile f contact <- withStore $ \st -> getContactByName st userId cName (agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) @@ -299,7 +315,7 @@ processChatCommand user@User {userId, profile} = \case withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci setActive $ ActiveC cName pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci - SendGroupFile gName f -> withChatLock $ do + SendGroupFile gName f -> withUser $ \user@User {userId} -> withChatLock $ do (fileSize, chSize) <- checkSndFile f Group gInfo@GroupInfo {membership} members <- withStore $ \st -> getGroupByName st user gName unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved @@ -319,7 +335,7 @@ processChatCommand user@User {userId, profile} = \case ciMeta@CIMeta {itemId} <- saveChatItem userId (CDGroupSnd gInfo) ci withStore $ \st -> updateFileTransferChatItemId st fileId itemId pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) $ ChatItem CIGroupSnd ciMeta ciContent - ReceiveFile fileId filePath_ -> do + ReceiveFile fileId filePath_ -> withUser $ \User {userId} -> do ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId unless (fileStatus == RFSNew) . throwChatError $ CEFileAlreadyReceiving fileName withChatLock . procCmd $ do @@ -331,7 +347,7 @@ processChatCommand user@User {userId, profile} = \case Left (ChatErrorAgent (SMP SMP.AUTH)) -> pure $ CRRcvFileAcceptedSndCancelled ft Left (ChatErrorAgent (CONN DUPLICATE)) -> pure $ CRRcvFileAcceptedSndCancelled ft Left e -> throwError e - CancelFile fileId -> do + CancelFile fileId -> withUser $ \User {userId} -> do ft' <- withStore (\st -> getFileTransfer st userId fileId) withChatLock . procCmd $ case ft' of FTSnd fts -> do @@ -341,18 +357,19 @@ processChatCommand user@User {userId, profile} = \case cancelRcvFileTransfer ft pure $ CRRcvFileCancelled ft FileStatus fileId -> - 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) - withChatLock . procCmd $ do - forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p - pure $ CRUserProfileUpdated profile p + CRFileTransferStatus <$> withUser (\User {userId} -> withStore $ \st -> getFileTransferProgress st userId fileId) + ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile profile + UpdateProfile p@Profile {displayName} -> withUser $ \user@User {profile} -> + if p == profile + then pure CRUserProfileNoChange + else do + withStore $ \st -> updateUserProfile st user p + let user' = (user :: User) {localDisplayName = displayName, profile = p} + asks currentUser >>= atomically . (`writeTVar` Just user') + contacts <- withStore (`getUserContacts` user) + withChatLock . procCmd $ do + forM_ contacts $ \ct -> sendDirectMessage (contactConn ct) $ XInfo p + pure $ CRUserProfileUpdated profile p QuitChat -> liftIO exitSuccess ShowVersion -> pure CRVersionInfo where @@ -367,13 +384,13 @@ processChatCommand user@User {userId, profile} = \case -- corrId <- liftIO $ SMP.CorrId <$> randomBytes gVar 8 -- void . forkIO $ -- withAgentLock a . withLock l $ - -- (atomically . writeTBQueue q) . (Just corrId,) =<< (action `catchError` (pure . CRChatError)) + -- (atomically . writeTBQueue q) . (Just corrId,) =<< (action `catchError` (pure . CRChatCmdError)) -- pure $ CRCmdAccepted corrId -- use function below to make commands "synchronous" procCmd :: m ChatResponse -> m ChatResponse procCmd = id - connect :: ConnectionRequestUri c -> ChatMsgEvent -> m () - connect cReq msg = do + connect :: UserId -> ConnectionRequestUri c -> ChatMsgEvent -> m () + connect userId cReq msg = do connId <- withAgent $ \a -> joinConnection a cReq $ directMessage msg withStore $ \st -> createDirectConnection st userId connId contactMember :: Contact -> [GroupMember] -> Maybe GroupMember @@ -416,31 +433,30 @@ processChatCommand 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) => m () -agentSubscriber = do +agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m () +agentSubscriber user = do q <- asks $ subQ . smpAgent l <- asks chatLock - subscribeUserConnections + subscribeUserConnections user forever $ do (_, connId, msg) <- atomically $ readTBQueue q - user <- readTVarIO =<< asks currentUser + u <- readTVarIO =<< asks currentUser withLock l . void . runExceptT $ - processAgentMessage user connId msg `catchError` (toView . CRChatError) + processAgentMessage u connId msg `catchError` (toView . CRChatError) -subscribeUserConnections :: forall m. (MonadUnliftIO m, MonadReader ChatController m) => m () -subscribeUserConnections = void . runExceptT $ do - user <- readTVarIO =<< asks currentUser - subscribeContacts user - subscribeGroups user - subscribeFiles user - subscribePendingConnections user - subscribeUserContactLink user +subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m () +subscribeUserConnections user@User {userId} = void . runExceptT $ do + subscribeContacts + subscribeGroups + subscribeFiles + subscribePendingConnections + subscribeUserContactLink where - subscribeContacts user = do + subscribeContacts = do contacts <- withStore (`getUserContacts` user) forM_ contacts $ \ct -> (subscribe (contactConnId ct) >> toView (CRContactSubscribed ct)) `catchError` (toView . CRContactSubError ct) - subscribeGroups user = do + subscribeGroups = do groups <- withStore (`getUserGroups` user) forM_ groups $ \(Group g@GroupInfo {membership} members) -> do let connectedMembers = mapMaybe (\m -> (m,) <$> memberConnId m) members @@ -456,7 +472,7 @@ subscribeUserConnections = void . runExceptT $ do forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) -> subscribe cId `catchError` (toView . CRMemberSubError g c) toView $ CRGroupSubscribed g - subscribeFiles user = do + subscribeFiles = do withStore (`getLiveSndFileTransfers` user) >>= mapM_ subscribeSndFile withStore (`getLiveRcvFileTransfers` user) >>= mapM_ subscribeRcvFile where @@ -477,10 +493,10 @@ subscribeUserConnections = void . runExceptT $ do where resume RcvFileInfo {agentConnId = AgentConnId cId} = subscribe cId `catchError` (toView . CRRcvFileSubError ft) - subscribePendingConnections user = do + subscribePendingConnections = do cs <- withStore (`getPendingConnections` user) subscribeConns cs `catchError` \_ -> pure () - subscribeUserContactLink User {userId} = do + subscribeUserContactLink = do cs <- withStore (`getUserContactLinkConnections` userId) (subscribeConns cs >> toView CRUserContactLinkSubscribed) `catchError` (toView . CRUserContactLinkSubError) @@ -489,8 +505,9 @@ subscribeUserConnections = void . runExceptT $ do withAgent $ \a -> forM_ conns $ subscribeConnection a . aConnId -processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m () -processAgentMessage user@User {userId, profile} agentConnId agentMessage = +processAgentMessage :: forall m. ChatMonad m => Maybe User -> ConnId -> ACommand 'Agent -> m () +processAgentMessage Nothing _ _ = throwChatError CENoActiveUser +processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage = (withStore (\st -> getConnectionEntity st user agentConnId) >>= updateConnStatus) >>= \case RcvDirectMsgConnection conn contact_ -> processDirectMessage agentMessage conn contact_ @@ -1026,7 +1043,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = toView $ CRGroupDeleted gInfo m parseChatMessage :: ByteString -> Either ChatError ChatMessage -parseChatMessage = first ChatErrorMessage . strDecode +parseChatMessage = first (ChatError . CEInvalidChatMessage) . strDecode sendFileChunk :: ChatMonad m => SndFileTransfer -> m () sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} = @@ -1319,6 +1336,18 @@ notificationSubscriber = do ChatController {notifyQ, sendNotification} <- ask forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification +withUser' :: ChatMonad m => (User -> m a) -> m a +withUser' action = + asks currentUser + >>= readTVarIO + >>= maybe (throwChatError CENoActiveUser) action + +withUser :: ChatMonad m => (User -> m a) -> m a +withUser action = withUser' $ \user -> + ifM chatStarted (action user) (throwChatError CEChatNotStarted) + where + chatStarted = fmap isJust . readTVarIO =<< asks agentAsync + withAgent :: ChatMonad m => (AgentClient -> ExceptT AgentErrorType m a) -> m a withAgent action = asks smpAgent @@ -1336,7 +1365,10 @@ withStore action = chatCommandP :: Parser ChatCommand chatCommandP = - "/_get chats" $> APIGetChats + ("/user " <|> "/u ") *> (CreateActiveUser <$> userProfile) + <|> ("/user" <|> "/u") $> ShowActiveUser + <|> "/_start" $> StartChat + <|> "/_get chats" $> APIGetChats <|> "/_get chat " *> (APIGetChat <$> chatTypeP <*> A.decimal <* A.space <*> chatPaginationP) <|> "/_get items count=" *> (APIGetChatItems <$> A.decimal) <|> "/_send " *> (APISendMessage <$> chatTypeP <*> A.decimal <* A.space <*> msgContentP) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index f3126037de..d38b5f2daf 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -8,6 +8,7 @@ module Simplex.Chat.Controller where +import Control.Concurrent.Async (Async) import Control.Exception import Control.Monad.Except import Control.Monad.IO.Unlift @@ -54,10 +55,11 @@ data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName deriving (Eq) data ChatController = ChatController - { currentUser :: TVar User, + { currentUser :: TVar (Maybe User), activeTo :: TVar ActiveTo, firstTime :: Bool, smpAgent :: AgentClient, + agentAsync :: TVar (Maybe (Async ())), chatStore :: SQLiteStore, idsDrg :: TVar ChaChaDRG, inputQ :: TBQueue String, @@ -78,7 +80,10 @@ instance ToJSON HelpSection where toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HS" data ChatCommand - = APIGetChats + = ShowActiveUser + | CreateActiveUser Profile + | StartChat + | APIGetChats | APIGetChat ChatType Int64 ChatPagination | APIGetChatItems Int | APISendMessage ChatType Int64 MsgContent @@ -120,7 +125,9 @@ data ChatCommand deriving (Show) data ChatResponse - = CRApiChats {chats :: [AChat]} + = CRActiveUser {user :: User} + | CRChatStarted + | CRApiChats {chats :: [AChat]} | CRApiChat {chat :: AChat} | CRNewChatItem {chatItem :: AChatItem} | CRMsgIntegrityError {msgerror :: MsgErrorType} -- TODO make it chat item to support in mobile @@ -198,10 +205,8 @@ instance ToJSON ChatResponse where data ChatError = ChatError {errorType :: ChatErrorType} - | ChatErrorMessage {errorMessage :: String} | ChatErrorAgent {agentError :: AgentErrorType} | ChatErrorStore {storeError :: StoreError} - | ChatErrorNotImplemented deriving (Show, Exception, Generic) instance ToJSON ChatError where @@ -209,9 +214,13 @@ instance ToJSON ChatError where toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "Chat" data ChatErrorType - = CEGroupUserRole + = CENoActiveUser + | CEActiveUserExists + | CEChatNotStarted | CEInvalidConnReq + | CEInvalidChatMessage {message :: String} | CEContactGroups {contact :: Contact, groupNames :: [GroupName]} + | CEGroupUserRole | CEGroupContactRole {contactName :: ContactName} | CEGroupDuplicateMember {contactName :: ContactName} | CEGroupDuplicateMemberId @@ -240,6 +249,9 @@ instance ToJSON ChatErrorType where type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m) +chatCmdError :: String -> ChatResponse +chatCmdError = CRChatCmdError . ChatError . CECommandError + setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m () setActive to = asks activeTo >>= atomically . (`writeTVar` to) diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 2803293638..293211a6a7 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -6,13 +6,10 @@ module Simplex.Chat.Mobile where -import Control.Concurrent (forkIO) import Control.Concurrent.STM -import Control.Monad.Except import Control.Monad.Reader -import Data.Aeson (ToJSON (..), (.=)) +import Data.Aeson (ToJSON (..)) import qualified Data.Aeson as J -import qualified Data.Aeson.Encoding as JE import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.List (find) @@ -26,36 +23,16 @@ import Simplex.Chat.Store import Simplex.Chat.Types import Simplex.Messaging.Protocol (CorrId (..)) -foreign export ccall "chat_init_store" cChatInitStore :: CString -> IO (StablePtr ChatStore) - -foreign export ccall "chat_get_user" cChatGetUser :: StablePtr ChatStore -> IO CJSONString - -foreign export ccall "chat_create_user" cChatCreateUser :: StablePtr ChatStore -> CJSONString -> IO CJSONString - -foreign export ccall "chat_start" cChatStart :: StablePtr ChatStore -> IO (StablePtr ChatController) +foreign export ccall "chat_init" cChatInit :: CString -> IO (StablePtr ChatController) foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CJSONString --- | creates or connects to chat store -cChatInitStore :: CString -> IO (StablePtr ChatStore) -cChatInitStore fp = peekCAString fp >>= chatInitStore >>= newStablePtr - --- | returns JSON in the form `{"user": }` or `{}` in case there is no active user (to show dialog to enter displayName/fullName) -cChatGetUser :: StablePtr ChatStore -> IO CJSONString -cChatGetUser cc = deRefStablePtr cc >>= chatGetUser >>= newCAString - --- | accepts Profile JSON, returns JSON `{"user": }` or `{"error": ""}` -cChatCreateUser :: StablePtr ChatStore -> CJSONString -> IO CJSONString -cChatCreateUser cPtr profileCJson = do - c <- deRefStablePtr cPtr - p <- peekCAString profileCJson - newCAString =<< chatCreateUser c p - --- | this function starts chat - it cannot be started during initialization right now, as it cannot work without user (to be fixed later) -cChatStart :: StablePtr ChatStore -> IO (StablePtr ChatController) -cChatStart st = deRefStablePtr st >>= chatStart >>= newStablePtr +-- | initialize chat controller +-- The active user has to be created and the chat has to be started before most commands can be used. +cChatInit :: CString -> IO (StablePtr ChatController) +cChatInit fp = peekCAString fp >>= chatInit >>= newStablePtr -- | send command to chat (same syntax as in terminal for now) cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString @@ -78,43 +55,15 @@ mobileChatOpts = type CJSONString = CString -data ChatStore = ChatStore - { dbFilePrefix :: FilePath, - chatStore :: SQLiteStore - } - -chatInitStore :: String -> IO ChatStore -chatInitStore dbFilePrefix = do - let f = chatStoreFile dbFilePrefix - chatStore <- createStore f $ dbPoolSize defaultChatConfig - pure ChatStore {dbFilePrefix, chatStore} - getActiveUser_ :: SQLiteStore -> IO (Maybe User) getActiveUser_ st = find activeUser <$> getUsers st --- | returns JSON in the form `{"user": }` or `{}` -chatGetUser :: ChatStore -> IO JSONString -chatGetUser ChatStore {chatStore} = - maybe "{}" userObject <$> getActiveUser_ chatStore - --- | returns JSON in the form `{"user": }` or `{"error": ""}` -chatCreateUser :: ChatStore -> JSONString -> IO JSONString -chatCreateUser ChatStore {chatStore} profileJson = - case J.eitherDecodeStrict' $ B.pack profileJson of - Left e -> pure $ err e - Right p -> either err userObject <$> runExceptT (createUser chatStore p True) - where - err e = jsonObject $ "error" .= show e - -userObject :: User -> JSONString -userObject user = jsonObject $ "user" .= user - -chatStart :: ChatStore -> IO ChatController -chatStart ChatStore {dbFilePrefix, chatStore} = do - Just user <- getActiveUser_ chatStore - cc <- newChatController chatStore user defaultChatConfig mobileChatOpts {dbFilePrefix} . const $ pure () - void . forkIO $ runReaderT runChatController cc - pure cc +chatInit :: String -> IO ChatController +chatInit dbFilePrefix = do + let f = chatStoreFile dbFilePrefix + chatStore <- createStore f $ dbPoolSize defaultChatConfig + user_ <- getActiveUser_ chatStore + newChatController chatStore user_ defaultChatConfig mobileChatOpts {dbFilePrefix} . const $ pure () chatSendCmd :: ChatController -> String -> IO JSONString chatSendCmd cc s = LB.unpack . J.encode . APIResponse Nothing <$> runReaderT (execChatCommand $ B.pack s) cc @@ -124,9 +73,6 @@ chatRecvMsg ChatController {outputQ} = json <$> atomically (readTBQueue outputQ) where json (corr, resp) = LB.unpack $ J.encode APIResponse {corr, resp} -jsonObject :: J.Series -> JSONString -jsonObject = LB.unpack . JE.encodingToLazyByteString . J.pairs - data APIResponse = APIResponse {corr :: Maybe CorrId, resp :: ChatResponse} deriving (Generic) diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 8fd34ff325..dc08ff65bf 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE FlexibleContexts #-} + module Simplex.Chat.Terminal where import Control.Logger.Simple +import Control.Monad.Except import Control.Monad.Reader import Simplex.Chat import Simplex.Chat.Controller @@ -11,8 +14,8 @@ import Simplex.Chat.Terminal.Input import Simplex.Chat.Terminal.Notification import Simplex.Chat.Terminal.Output import Simplex.Chat.Types (User) -import Simplex.Chat.Util (whenM) import Simplex.Messaging.Util (raceAny_) +import UnliftIO (async, waitEither_) simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO () simplexChat cfg opts t @@ -27,10 +30,15 @@ simplexChat cfg opts t st <- createStore f $ dbPoolSize cfg u <- getCreateActiveUser st ct <- newChatTerminal t - cc <- newChatController st u cfg opts sendNotification' + cc <- newChatController st (Just u) cfg opts sendNotification' runSimplexChat u ct cc runSimplexChat :: User -> ChatTerminal -> ChatController -> IO () -runSimplexChat u ct = runReaderT $ do - whenM (asks firstTime) . liftIO . printToTerminal ct $ chatWelcome u - raceAny_ [runTerminalInput ct, runTerminalOutput ct, runInputLoop ct, runChatController] +runSimplexChat u ct cc = do + when (firstTime cc) . printToTerminal ct $ chatWelcome u + a1 <- async $ runChatTerminal ct cc + a2 <- runReaderT (startChatController u) cc + waitEither_ a1 a2 + +runChatTerminal :: ChatTerminal -> ChatController -> IO () +runChatTerminal ct cc = raceAny_ [runTerminalInput ct cc, runTerminalOutput ct cc, runInputLoop ct cc] diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 11e43b3253..f4bc51769e 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -25,21 +25,16 @@ 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 . encodeUtf8 $ T.pack s - liftIO . printToTerminal ct $ responseToView s r +runInputLoop :: ChatTerminal -> ChatController -> IO () +runInputLoop ct cc = forever $ do + s <- atomically . readTBQueue $ inputQ cc + r <- runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc + printToTerminal ct $ responseToView s r -runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m () -runTerminalInput ct = do - cc <- ask - liftIO $ - withChatTerm ct $ do - updateInput ct - receiveFromTTY cc ct +runTerminalInput :: ChatTerminal -> ChatController -> IO () +runTerminalInput ct cc = withChatTerm ct $ do + updateInput ct + receiveFromTTY cc ct receiveFromTTY :: MonadTerminal m => ChatController -> ChatTerminal -> m () receiveFromTTY ChatController {inputQ, activeTo} ct@ChatTerminal {termSize, termState} = diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index eb911a1785..7de744f569 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -72,11 +72,10 @@ withTermLock ChatTerminal {termLock} action = do action atomically $ putTMVar termLock () -runTerminalOutput :: (MonadUnliftIO m, MonadReader ChatController m) => ChatTerminal -> m () -runTerminalOutput ct = do - ChatController {outputQ} <- ask +runTerminalOutput :: ChatTerminal -> ChatController -> IO () +runTerminalOutput ct cc = forever $ - atomically (readTBQueue outputQ) >>= liftIO . printToTerminal ct . responseToView "" . snd + atomically (readTBQueue $ outputQ cc) >>= printToTerminal ct . responseToView "" . snd printToTerminal :: ChatTerminal -> [StyledString] -> IO () printToTerminal ct s = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 69dc24282c..48b30625ff 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -34,8 +34,10 @@ serializeChatResponse = unlines . map unStyle . responseToView "" responseToView :: String -> ChatResponse -> [StyledString] responseToView cmd = \case - CRApiChats chats -> api [sShow chats] - CRApiChat chat -> api [sShow chat] + CRActiveUser User {profile} -> r $ viewUserProfile profile + CRChatStarted -> r ["chat started"] + CRApiChats chats -> r [sShow chats] + CRApiChat chat -> r [sShow chat] CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr CRCmdAccepted _ -> r [] @@ -115,7 +117,6 @@ responseToView cmd = \case CRMessageError prefix err -> [plain prefix <> ": " <> plain err] CRChatError e -> viewChatError e where - api = (highlight cmd :) r = (plain cmd :) -- this function should be `r` for "synchronous", `id` for "asynchronous" command responses -- r' = id @@ -447,7 +448,11 @@ fileProgress chunksNum chunkSize fileSize = viewChatError :: ChatError -> [StyledString] viewChatError = \case ChatError err -> case err of + CENoActiveUser -> ["error: active user is required"] + CEActiveUserExists -> ["error: active user already exists"] + CEChatNotStarted -> ["error: chat not started"] CEInvalidConnReq -> viewInvalidConnReq + CEInvalidChatMessage e -> ["chat message error: " <> sShow e] CEContactGroups Contact {localDisplayName} gNames -> [ttyContact localDisplayName <> ": 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"] @@ -488,8 +493,6 @@ viewChatError = \case ChatErrorAgent err -> case err of SMP SMP.AUTH -> ["error: this connection is deleted"] e -> ["smp agent error: " <> sShow e] - ChatErrorMessage e -> ["chat message error: " <> sShow e] - ChatErrorNotImplemented -> ["chat error: not implemented"] where fileNotFound fileId = ["file " <> sShow fileId <> " not found"] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index a7bcf14d2f..4099568c7d 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -79,7 +79,7 @@ virtualSimplexChat dbFilePrefix profile = do Right user <- runExceptT $ createUser st profile True t <- withVirtualTerminal termSettings pure ct <- newChatTerminal t - cc <- newChatController st user cfg opts {dbFilePrefix} . const $ pure () -- no notifications + cc <- newChatController st (Just user) cfg opts {dbFilePrefix} . const $ pure () -- no notifications chatAsync <- async $ runSimplexChat user ct cc termQ <- newTQueueIO termAsync <- async $ readTerminalOutput t termQ @@ -108,16 +108,18 @@ readTerminalOutput t termQ = do then map (dropWhileEnd (== ' ')) diff else getDiff_ (n + 1) len win' win -testChatN :: [Profile] -> ([TestCC] -> IO ()) -> IO () -testChatN ps test = +withTmpFiles :: IO () -> IO () +withTmpFiles = bracket_ (createDirectoryIfMissing False "tests/tmp") (removeDirectoryRecursive "tests/tmp") - $ do - let envs = zip ps $ map ((testDBPrefix <>) . show) [(1 :: Int) ..] - tcs <- getTestCCs envs [] - test tcs - concurrentlyN_ $ map ( ([TestCC] -> IO ()) -> IO () +testChatN ps test = withTmpFiles $ do + let envs = zip ps $ map ((testDBPrefix <>) . show) [(1 :: Int) ..] + tcs <- getTestCCs envs [] + test tcs + concurrentlyN_ $ map ( virtualSimplexChat db p <*> getTestCCs envs' tcs diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 6ac2ba4f3d..82916e5ff0 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -10,6 +10,7 @@ import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM import qualified Data.ByteString as B import Data.Char (isDigit) +import Data.Maybe (fromJust) import qualified Data.Text as T import Simplex.Chat.Controller import Simplex.Chat.Types (Profile (..), User (..)) @@ -753,7 +754,7 @@ connectUsers cc1 cc2 = do showName :: TestCC -> IO String showName (TestCC ChatController {currentUser} _ _ _ _) = do - User {localDisplayName, profile = Profile {fullName}} <- readTVarIO currentUser + Just User {localDisplayName, profile = Profile {fullName}} <- readTVarIO currentUser pure . T.unpack $ localDisplayName <> " (" <> fullName <> ")" createGroup2 :: String -> TestCC -> TestCC -> IO () @@ -811,7 +812,7 @@ cc1 <##> cc2 = do cc1 <# (name2 <> "> hey") userName :: TestCC -> IO [Char] -userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName <$> readTVarIO currentUser +userName (TestCC ChatController {currentUser} _ _ _ _) = T.unpack . localDisplayName . fromJust <$> readTVarIO currentUser (##>) :: TestCC -> String -> IO () cc ##> cmd = do diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs new file mode 100644 index 0000000000..96d5d8c409 --- /dev/null +++ b/tests/MobileTests.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module MobileTests where + +import ChatClient +import ChatTests +import Control.Monad.Except +import Simplex.Chat.Mobile +import Simplex.Chat.Store +import Test.Hspec + +mobileTests :: Spec +mobileTests = do + describe "mobile API" $ do + it "start new chat without user" testChatApiNoUser + it "start new chat with existing user" testChatApi + +noActiveUser :: String +noActiveUser = "{\"resp\":{\"chatCmdError\":{\"chatError\":{\"error\":{\"errorType\":{\"noActiveUser\":{}}}}}}}" + +activeUserExists :: String +activeUserExists = "{\"resp\":{\"chatCmdError\":{\"chatError\":{\"error\":{\"errorType\":{\"activeUserExists\":{}}}}}}}" + +activeUser :: String +activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"displayName\":\"alice\",\"fullName\":\"Alice\"},\"activeUser\":true}}}}" + +testChatApiNoUser :: IO () +testChatApiNoUser = withTmpFiles $ do + cc <- chatInit testDBPrefix + chatSendCmd cc "/u" `shouldReturn` noActiveUser + chatSendCmd cc "/_start" `shouldReturn` noActiveUser + chatSendCmd cc "/u alice Alice" `shouldReturn` activeUser + chatSendCmd cc "/_start" `shouldReturn` "{\"resp\":{\"chatStarted\":{}}}" + +testChatApi :: IO () +testChatApi = withTmpFiles $ do + let f = chatStoreFile testDBPrefix + st <- createStore f 1 + Right _ <- runExceptT $ createUser st aliceProfile True + cc <- chatInit testDBPrefix + chatSendCmd cc "/u" `shouldReturn` activeUser + chatSendCmd cc "/u alice Alice" `shouldReturn` activeUserExists + chatSendCmd cc "/_start" `shouldReturn` "{\"resp\":{\"chatStarted\":{}}}" diff --git a/tests/Test.hs b/tests/Test.hs index 961475ab38..8ed0ac0dcb 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,6 +1,7 @@ import ChatClient import ChatTests import MarkdownTests +import MobileTests import ProtocolTests import Test.Hspec @@ -8,4 +9,5 @@ main :: IO () main = withSmpServer . hspec $ do describe "SimpleX chat markdown" markdownTests describe "SimpleX chat protocol" protocolTests + describe "Mobile API Tests" mobileTests describe "SimpleX chat client" chatTests