mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
simplify mobile API to have single controller (#274)
* simplify mobile API to have single controller * update chat response in swift * add async to stack
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
9b67aa537a
commit
408a30c25b
15 changed files with 287 additions and 237 deletions
|
|
@ -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<T: Encodable>(_ 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
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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": <user object>}` 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": <user object>}` or `{"error": "<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": <user object>}` or `{}`
|
||||
chatGetUser :: ChatStore -> IO JSONString
|
||||
chatGetUser ChatStore {chatStore} =
|
||||
maybe "{}" userObject <$> getActiveUser_ chatStore
|
||||
|
||||
-- | returns JSON in the form `{"user": <user object>}` or `{"error": "<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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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} =
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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"]
|
||||
|
||||
|
|
|
|||
|
|
@ -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 (<// 100000) tcs
|
||||
|
||||
testChatN :: [Profile] -> ([TestCC] -> IO ()) -> IO ()
|
||||
testChatN ps test = withTmpFiles $ do
|
||||
let envs = zip ps $ map ((testDBPrefix <>) . show) [(1 :: Int) ..]
|
||||
tcs <- getTestCCs envs []
|
||||
test tcs
|
||||
concurrentlyN_ $ map (<// 100000) tcs
|
||||
where
|
||||
getTestCCs [] tcs = pure tcs
|
||||
getTestCCs ((p, db) : envs') tcs = (:) <$> virtualSimplexChat db p <*> getTestCCs envs' tcs
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
43
tests/MobileTests.hs
Normal file
43
tests/MobileTests.hs
Normal file
|
|
@ -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\":{}}}"
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue