mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: move CLI notifications and active chat to view layer (for remote CLI) (#3196)
* core: move CLI notifications to view layer (to allow notifications in remote CLI) * remove unused * refactor activeTo * move activeTo to ChatTerminal * refactor * move back * remove extension
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
a67b79952b
commit
4ecf94dfad
21 changed files with 249 additions and 181 deletions
|
|
@ -24,7 +24,7 @@ import Text.Read
|
|||
main :: IO ()
|
||||
main = do
|
||||
opts <- welcomeGetOpts
|
||||
simplexChatCore terminalChatConfig opts Nothing mySquaringBot
|
||||
simplexChatCore terminalChatConfig opts mySquaringBot
|
||||
|
||||
welcomeGetOpts :: IO ChatOpts
|
||||
welcomeGetOpts = do
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ import Text.Read
|
|||
main :: IO ()
|
||||
main = do
|
||||
opts <- welcomeGetOpts
|
||||
simplexChatCore terminalChatConfig opts Nothing $
|
||||
simplexChatCore terminalChatConfig opts $
|
||||
chatBotRepl welcomeMessage $ \_contact msg ->
|
||||
pure $ case readMaybe msg :: Maybe Integer of
|
||||
Just n -> msg <> " * " <> msg <> " = " <> show (n * n)
|
||||
|
|
|
|||
|
|
@ -8,4 +8,4 @@ import Simplex.Chat.Terminal (terminalChatConfig)
|
|||
main :: IO ()
|
||||
main = do
|
||||
opts <- welcomeGetOpts
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ broadcastBot opts
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) $ broadcastBot opts
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ main = do
|
|||
welcome opts
|
||||
t <- withTerminal pure
|
||||
simplexChatTerminal terminalChatConfig opts t
|
||||
else simplexChatCore terminalChatConfig opts Nothing $ \user cc -> do
|
||||
else simplexChatCore terminalChatConfig opts $ \user cc -> do
|
||||
r <- sendChatCmdStr cc chatCmd
|
||||
ts <- getCurrentTime
|
||||
tz <- getCurrentTimeZone
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ import UnliftIO.STM
|
|||
|
||||
simplexChatServer :: ChatServerConfig -> ChatConfig -> ChatOpts -> IO ()
|
||||
simplexChatServer srvCfg cfg opts =
|
||||
simplexChatCore cfg opts Nothing . const $ runChatServer srvCfg
|
||||
simplexChatCore cfg opts . const $ runChatServer srvCfg
|
||||
|
||||
data ChatServerConfig = ChatServerConfig
|
||||
{ chatPort :: ServiceName,
|
||||
|
|
|
|||
|
|
@ -12,4 +12,4 @@ main :: IO ()
|
|||
main = do
|
||||
opts@DirectoryOpts {directoryLog} <- welcomeGetOpts
|
||||
st <- restoreDirectoryStore directoryLog
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ directoryService st opts
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) $ directoryService st opts
|
||||
|
|
|
|||
|
|
@ -183,13 +183,11 @@ createChatDatabase filePrefix key confirmMigrations = runExceptT $ do
|
|||
agentStore <- ExceptT $ createAgentStore (agentStoreFile filePrefix) key confirmMigrations
|
||||
pure ChatDatabase {chatStore, agentStore}
|
||||
|
||||
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> IO ChatController
|
||||
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} sendToast = do
|
||||
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> IO ChatController
|
||||
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} = do
|
||||
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
|
||||
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize}
|
||||
sendNotification = fromMaybe (const $ pure ()) sendToast
|
||||
firstTime = dbNew chatStore
|
||||
activeTo <- newTVarIO ActiveNone
|
||||
currentUser <- newTVarIO user
|
||||
servers <- agentServers config
|
||||
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore
|
||||
|
|
@ -197,7 +195,6 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
|||
idsDrg <- newTVarIO =<< liftIO drgNew
|
||||
inputQ <- newTBQueueIO tbqSize
|
||||
outputQ <- newTBQueueIO tbqSize
|
||||
notifyQ <- newTBQueueIO tbqSize
|
||||
subscriptionMode <- newTVarIO SMSubscribe
|
||||
chatLock <- newEmptyTMVarIO
|
||||
sndFiles <- newTVarIO M.empty
|
||||
|
|
@ -213,7 +210,34 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
|||
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
|
||||
tempDirectory <- newTVarIO tempDir
|
||||
contactMergeEnabled <- newTVarIO True
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile, contactMergeEnabled}
|
||||
pure
|
||||
ChatController
|
||||
{ firstTime,
|
||||
currentUser,
|
||||
smpAgent,
|
||||
agentAsync,
|
||||
chatStore,
|
||||
chatStoreChanged,
|
||||
idsDrg,
|
||||
inputQ,
|
||||
outputQ,
|
||||
subscriptionMode,
|
||||
chatLock,
|
||||
sndFiles,
|
||||
rcvFiles,
|
||||
currentCalls,
|
||||
config,
|
||||
filesFolder,
|
||||
expireCIThreads,
|
||||
expireCIFlags,
|
||||
cleanupManagerAsync,
|
||||
timedItemThreads,
|
||||
showLiveItems,
|
||||
userXFTPFileConfig,
|
||||
tempDirectory,
|
||||
logFilePath = logFile,
|
||||
contactMergeEnabled
|
||||
}
|
||||
where
|
||||
configServers :: DefaultAgentServers
|
||||
configServers =
|
||||
|
|
@ -260,7 +284,7 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
|
|||
readTVarIO s >>= maybe (start s users) (pure . fst)
|
||||
where
|
||||
start s users = do
|
||||
a1 <- async $ race_ notificationSubscriber agentSubscriber
|
||||
a1 <- async agentSubscriber
|
||||
a2 <-
|
||||
if subConns
|
||||
then Just <$> async (subscribeUsers False users)
|
||||
|
|
@ -376,7 +400,6 @@ processChatCommand = \case
|
|||
user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
|
||||
storeServers user smpServers
|
||||
storeServers user xftpServers
|
||||
setActive ActiveNone
|
||||
atomically . writeTVar u $ Just user
|
||||
pure $ CRActiveUser user
|
||||
where
|
||||
|
|
@ -402,7 +425,6 @@ processChatCommand = \case
|
|||
user' <- privateGetUser userId'
|
||||
validateUserPassword user user' viewPwd_
|
||||
withStoreCtx' (Just "APISetActiveUser, setActiveUser") $ \db -> setActiveUser db userId'
|
||||
setActive ActiveNone
|
||||
let user'' = user' {activeUser = True}
|
||||
asks currentUser >>= atomically . (`writeTVar` Just user'')
|
||||
pure $ CRActiveUser user''
|
||||
|
|
@ -532,7 +554,7 @@ processChatCommand = \case
|
|||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIGetChatItems pagination search -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user pagination search
|
||||
pure $ CRChatItems user chatItems
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
|
||||
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db ->
|
||||
(,) <$> getAChatItem db user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
|
||||
|
|
@ -546,7 +568,7 @@ processChatCommand = \case
|
|||
pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses}
|
||||
APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
ct@Contact {contactId, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
assertDirectAllowed user MDSnd ct XMsgNew_
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
if isVoice mc && not (featureAllowed SCFVoice forUser ct)
|
||||
|
|
@ -563,7 +585,6 @@ processChatCommand = \case
|
|||
ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
|
||||
forM_ (timed_ >>= timedDeleteAt') $
|
||||
startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci)
|
||||
setActive $ ActiveC c
|
||||
pure $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
where
|
||||
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
|
|
@ -614,7 +635,7 @@ processChatCommand = \case
|
|||
assertUserGroupRole gInfo GRAuthor
|
||||
send g
|
||||
where
|
||||
send g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms)
|
||||
send g@(Group gInfo@GroupInfo {groupId, membership} ms)
|
||||
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
|
||||
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
|
||||
| otherwise = do
|
||||
|
|
@ -629,7 +650,6 @@ processChatCommand = \case
|
|||
createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew
|
||||
forM_ (timed_ >>= timedDeleteAt') $
|
||||
startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
|
||||
setActive $ ActiveG gName
|
||||
pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f))
|
||||
setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
|
|
@ -734,7 +754,7 @@ processChatCommand = \case
|
|||
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
|
||||
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> withChatLock "updateChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {contactId, localDisplayName = c}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
(ct@Contact {contactId}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
assertDirectAllowed user MDSnd ct XMsgUpdate_
|
||||
case cci of
|
||||
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
|
||||
|
|
@ -750,13 +770,12 @@ processChatCommand = \case
|
|||
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
|
||||
updateDirectChatItem' db user contactId ci (CISndMsgContent mc) live $ Just msgId
|
||||
startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci'
|
||||
setActive $ ActiveC c
|
||||
pure $ CRChatItemUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci')
|
||||
else pure $ CRChatItemNotChanged user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTGroup -> do
|
||||
Group gInfo@GroupInfo {groupId, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
|
||||
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db user chatId
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
cci <- withStore $ \db -> getGroupChatItem db user chatId itemId
|
||||
case cci of
|
||||
|
|
@ -773,7 +792,6 @@ processChatCommand = \case
|
|||
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
|
||||
updateGroupChatItem db user groupId ci (CISndMsgContent mc) live $ Just msgId
|
||||
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
|
||||
setActive $ ActiveG gName
|
||||
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
|
||||
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
|
|
@ -782,13 +800,12 @@ processChatCommand = \case
|
|||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {localDisplayName = c}, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
(ct, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
case (mode, msgDir, itemSharedMsgId, editable) of
|
||||
(CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False
|
||||
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
|
||||
assertDirectAllowed user MDSnd ct XMsgDel_
|
||||
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId Nothing)
|
||||
setActive $ ActiveC c
|
||||
if featureAllowed SCFFullDelete forUser ct
|
||||
then deleteDirectCI user ct ci True False
|
||||
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
|
||||
|
|
@ -898,7 +915,7 @@ processChatCommand = \case
|
|||
_ -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChat (ChatRef cType chatId) notify -> withUser $ \user@User {userId} -> case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {localDisplayName} <- withStore $ \db -> getContact db user chatId
|
||||
ct <- withStore $ \db -> getContact db user chatId
|
||||
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
|
||||
withChatLock "deleteChat direct" . procCmd $ do
|
||||
deleteFilesAndConns user filesInfo
|
||||
|
|
@ -910,7 +927,6 @@ processChatCommand = \case
|
|||
-- (possibly, race condition on integrity check?)
|
||||
withStore' $ \db -> deleteContactConnectionsAndFiles db userId ct
|
||||
withStore' $ \db -> deleteContact db user ct
|
||||
unsetActive $ ActiveC localDisplayName
|
||||
pure $ CRContactDeleted user ct
|
||||
CTContactConnection -> withChatLock "deleteChat contactConnection" . procCmd $ do
|
||||
conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withStore $ \db -> getPendingContactConnection db userId chatId
|
||||
|
|
@ -1698,11 +1714,10 @@ processChatCommand = \case
|
|||
LastMessages (Just chatName) count search -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
|
||||
setActive $ chatActiveTo chatName
|
||||
pure $ CRChatItems user (aChatItems . chat $ chatResp)
|
||||
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
|
||||
LastMessages Nothing count search -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast count) search
|
||||
pure $ CRChatItems user chatItems
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
LastChatItemId (Just chatName) index -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
|
||||
|
|
@ -1714,10 +1729,10 @@ processChatCommand = \case
|
|||
chatItem <- withStore $ \db -> do
|
||||
chatRef <- getChatRefViaItemId db user itemId
|
||||
getAChatItem db user chatRef itemId
|
||||
pure $ CRChatItems user ((: []) chatItem)
|
||||
pure $ CRChatItems user Nothing ((: []) chatItem)
|
||||
ShowChatItem Nothing -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast 1) Nothing
|
||||
pure $ CRChatItems user chatItems
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
ShowChatItemInfo chatName msg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
itemId <- getChatItemIdByText user chatRef msg
|
||||
|
|
@ -2059,8 +2074,7 @@ processChatCommand = \case
|
|||
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
|
||||
delGroupChatItem :: User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> m ChatResponse
|
||||
delGroupChatItem user gInfo@GroupInfo {localDisplayName = gName} ci msgId byGroupMember = do
|
||||
setActive $ ActiveG gName
|
||||
delGroupChatItem user gInfo ci msgId byGroupMember = do
|
||||
deletedTs <- liftIO getCurrentTime
|
||||
if groupFeatureAllowed SGFFullDelete gInfo
|
||||
then deleteGroupCI user gInfo ci True False byGroupMember deletedTs
|
||||
|
|
@ -2117,7 +2131,6 @@ processChatCommand = \case
|
|||
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg content
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
setActive $ ActiveG localDisplayName
|
||||
sndContactCITimed :: Bool -> Contact -> Maybe Int -> m (Maybe CITimed)
|
||||
sndContactCITimed live = sndCITimed_ live . contactTimedTTL
|
||||
sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> m (Maybe CITimed)
|
||||
|
|
@ -2167,7 +2180,6 @@ processChatCommand = \case
|
|||
users <- withStore' getUsers
|
||||
unless (length users > 1 && (isJust (viewPwdHash user) || length (filter (isNothing . viewPwdHash) users) > 1)) $
|
||||
throwChatError (CECantDeleteLastUser userId)
|
||||
setActive ActiveNone
|
||||
deleteChatUser :: User -> Bool -> m ChatResponse
|
||||
deleteChatUser user delSMPQueues = do
|
||||
filesInfo <- withStore' (`getUserFileInfo` user)
|
||||
|
|
@ -2867,17 +2879,16 @@ processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone ->
|
|||
processAgentMessageNoConn = \case
|
||||
CONNECT p h -> hostEvent $ CRHostConnected p h
|
||||
DISCONNECT p h -> hostEvent $ CRHostDisconnected p h
|
||||
DOWN srv conns -> serverEvent srv conns CRContactsDisconnected "disconnected"
|
||||
UP srv conns -> serverEvent srv conns CRContactsSubscribed "connected"
|
||||
DOWN srv conns -> serverEvent srv conns CRContactsDisconnected
|
||||
UP srv conns -> serverEvent srv conns CRContactsSubscribed
|
||||
SUSPENDED -> toView CRChatSuspended
|
||||
DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId
|
||||
where
|
||||
hostEvent :: ChatResponse -> m ()
|
||||
hostEvent = whenM (asks $ hostEvents . config) . toView
|
||||
serverEvent srv@(SMPServer host _ _) conns event str = do
|
||||
cs <- withStore' $ \db -> getConnectionsContacts db conns
|
||||
serverEvent srv conns event = do
|
||||
cs <- withStore' (`getConnectionsContacts` conns)
|
||||
toView $ event srv cs
|
||||
showToast ("server " <> str) (safeDecodeUtf8 $ strEncode host)
|
||||
|
||||
processAgentMsgSndFile :: forall m. ChatMonad m => ACorrId -> SndFileId -> ACommand 'Agent 'AESndFile -> m ()
|
||||
processAgentMsgSndFile _corrId aFileId msg =
|
||||
|
|
@ -3014,10 +3025,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
|
|||
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
|
||||
processAgentMessageConn user _ agentConnId END =
|
||||
withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= \case
|
||||
RcvDirectMsgConnection _ (Just ct@Contact {localDisplayName = c}) -> do
|
||||
toView $ CRContactAnotherClient user ct
|
||||
whenUserNtfs user $ showToast (c <> "> ") "connected to another client"
|
||||
unsetActive $ ActiveC c
|
||||
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
|
||||
entity -> toView $ CRSubscriptionEnd user entity
|
||||
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus
|
||||
|
|
@ -3084,7 +3092,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
||||
-- TODO add debugging output
|
||||
_ -> pure ()
|
||||
Just ct@Contact {localDisplayName = c, contactId} -> case agentMsg of
|
||||
Just ct@Contact {contactId} -> case agentMsg of
|
||||
INV (ACR _ cReq) ->
|
||||
-- [async agent commands] XGrpMemIntro continuation on receiving INV
|
||||
withCompletedCommand conn agentMsg $ \_ ->
|
||||
|
|
@ -3169,9 +3177,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
toView $ CRContactConnected user ct (fmap fromLocalProfile incognitoProfile)
|
||||
when (directOrUsed ct) $ createFeatureEnabledItems ct
|
||||
whenUserNtfs user $ do
|
||||
setActive $ ActiveC c
|
||||
showToast (c <> "> ") "connected"
|
||||
when (contactConnInitiated conn) $ do
|
||||
let Connection {groupLinkId} = conn
|
||||
doProbeContacts = isJust groupLinkId
|
||||
|
|
@ -3248,7 +3253,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
_ -> pure ()
|
||||
|
||||
processGroupMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> m ()
|
||||
processGroupMessage agentMsg connEntity conn@Connection {connId, connectionCode} gInfo@GroupInfo {groupId, localDisplayName = gName, groupProfile, membership, chatSettings} m = case agentMsg of
|
||||
processGroupMessage agentMsg connEntity conn@Connection {connId, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of
|
||||
INV (ACR _ cReq) ->
|
||||
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
|
||||
case cReq of
|
||||
|
|
@ -3338,15 +3343,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
let GroupInfo {groupProfile = GroupProfile {description}} = gInfo
|
||||
memberConnectedChatItem gInfo m
|
||||
forM_ description $ groupDescriptionChatItem gInfo m
|
||||
whenUserNtfs user $ do
|
||||
setActive $ ActiveG gName
|
||||
showToast ("#" <> gName) "you are connected to group"
|
||||
GCInviteeMember -> do
|
||||
memberConnectedChatItem gInfo m
|
||||
toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected}
|
||||
whenGroupNtfs user gInfo $ do
|
||||
setActive $ ActiveG gName
|
||||
showToast ("#" <> gName) $ "member " <> m.localDisplayName <> " is connected"
|
||||
intros <- withStore' $ \db -> createIntroductions db members m
|
||||
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
|
||||
forM_ intros $ \intro ->
|
||||
|
|
@ -3642,7 +3641,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
profileContactRequest invId chatVRange p xContactId_ = do
|
||||
withStore (\db -> createOrUpdateContactRequest db user userContactLinkId invId chatVRange p xContactId_) >>= \case
|
||||
CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
|
||||
CORRequest cReq@UserContactRequest {localDisplayName} -> do
|
||||
CORRequest cReq -> do
|
||||
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
|
||||
Just (UserContactLink {autoAccept}, groupId_, _) ->
|
||||
case autoAccept of
|
||||
|
|
@ -3657,10 +3656,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
ct <- acceptContactRequestAsync user cReq profileMode
|
||||
toView $ CRAcceptingGroupJoinRequest user gInfo ct
|
||||
_ -> do
|
||||
toView $ CRReceivedContactRequest user cReq
|
||||
whenUserNtfs user $
|
||||
showToast (localDisplayName <> "> ") "wants to connect to you"
|
||||
_ -> toView $ CRReceivedContactRequest user cReq
|
||||
_ -> pure ()
|
||||
|
||||
incAuthErrCounter :: ConnectionEntity -> Connection -> AgentErrorType -> m ()
|
||||
|
|
@ -3751,13 +3747,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing
|
||||
|
||||
notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> m ()
|
||||
notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} ct_ = do
|
||||
notifyMemberConnected gInfo m ct_ = do
|
||||
memberConnectedChatItem gInfo m
|
||||
toView $ CRConnectedToGroupMember user gInfo m ct_
|
||||
let g = groupName' gInfo
|
||||
whenGroupNtfs user gInfo $ do
|
||||
setActive $ ActiveG g
|
||||
showToast ("#" <> g) $ "member " <> c <> " is connected"
|
||||
|
||||
probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> m ()
|
||||
probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do
|
||||
|
|
@ -3819,7 +3811,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
messageError = toView . CRMessageError user "error"
|
||||
|
||||
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
|
||||
newContentMessage ct@Contact {localDisplayName = c, contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc
|
||||
|
|
@ -3832,23 +3824,18 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
if isVoice content && not (featureAllowed SCFVoice forContact ct)
|
||||
then do
|
||||
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
|
||||
setActive $ ActiveC c
|
||||
else do
|
||||
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
|
||||
timed_ = rcvContactCITimed ct itemTTL
|
||||
live = fromMaybe False live_
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
autoAcceptFile file_
|
||||
whenContactNtfs user ct $ do
|
||||
showMsgToast (c <> "> ") content formattedText
|
||||
setActive $ ActiveC c
|
||||
where
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions})
|
||||
pure ci
|
||||
|
||||
autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> m ()
|
||||
autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do
|
||||
|
|
@ -3907,7 +3894,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
pure (ft, CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol})
|
||||
|
||||
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
|
||||
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
|
||||
messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
updateRcvChatItem `catchCINotFound` \_ -> do
|
||||
-- This patches initial sharedMsgId into chat item when locally deleted chat item
|
||||
|
|
@ -3919,7 +3906,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateDirectChatItem' db user contactId ci content live Nothing
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
|
||||
setActive $ ActiveC c
|
||||
where
|
||||
MsgMeta {broker = (_, brokerTs)} = msgMeta
|
||||
content = CIRcvMsgContent mc
|
||||
|
|
@ -4006,7 +3992,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
e -> throwError e
|
||||
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
|
||||
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
|
||||
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
|
||||
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
|
||||
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
|
||||
| otherwise = do
|
||||
|
|
@ -4036,20 +4022,15 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
toView cr
|
||||
createItem timed_ live = do
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
autoAcceptFile file_
|
||||
let g = groupName' gInfo
|
||||
whenGroupNtfs user gInfo $ do
|
||||
showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
|
||||
setActive $ ActiveG g
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
|
||||
groupMsgToView gInfo m ci {reactions} msgMeta
|
||||
pure ci
|
||||
|
||||
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
|
||||
updateRcvChatItem `catchCINotFound` \_ -> do
|
||||
-- This patches initial sharedMsgId into chat item when locally deleted chat item
|
||||
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
|
||||
|
|
@ -4060,7 +4041,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateGroupChatItem db user groupId ci content live Nothing
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
||||
setActive $ ActiveG g
|
||||
where
|
||||
MsgMeta {broker = (_, brokerTs)} = msgMeta
|
||||
content = CIRcvMsgContent mc
|
||||
|
|
@ -4079,7 +4059,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
|
||||
updateGroupChatItem db user groupId ci content live $ Just msgId
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
||||
setActive $ ActiveG g
|
||||
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
|
||||
else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
|
||||
else messageError "x.msg.update: group member attempted to update a message of another member"
|
||||
|
|
@ -4115,7 +4094,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
|
||||
-- TODO remove once XFile is discontinued
|
||||
processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
processFileInvitation' ct fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||
|
|
@ -4124,13 +4103,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
whenContactNtfs user ct $ do
|
||||
showToast (c <> "> ") "wants to send a file"
|
||||
setActive $ ActiveC c
|
||||
|
||||
-- TODO remove once XFile is discontinued
|
||||
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processGroupFileInvitation' gInfo m@GroupMember {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
|
||||
|
|
@ -4138,10 +4114,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
let g = groupName' gInfo
|
||||
whenGroupNtfs user gInfo $ do
|
||||
showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
|
||||
setActive $ ActiveG g
|
||||
|
||||
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode)
|
||||
receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of
|
||||
|
|
@ -4322,8 +4294,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
|||
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
|
||||
whenContactNtfs user ct $
|
||||
showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group"
|
||||
where
|
||||
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
|
||||
sameGroupLinkId (Just gli) (Just gli') = gli == gli'
|
||||
|
|
@ -5470,29 +5440,20 @@ getCreateActiveUser st testView = do
|
|||
getWithPrompt :: String -> IO String
|
||||
getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
|
||||
|
||||
whenUserNtfs :: ChatMonad' m => User -> m () -> m ()
|
||||
whenUserNtfs User {showNtfs, activeUser} = when $ showNtfs || activeUser
|
||||
userNtf :: User -> Bool
|
||||
userNtf User {showNtfs, activeUser} = showNtfs || activeUser
|
||||
|
||||
whenContactNtfs :: ChatMonad' m => User -> Contact -> m () -> m ()
|
||||
whenContactNtfs user Contact {chatSettings} = whenUserNtfs user . when (enableNtfs chatSettings)
|
||||
chatNtf :: User -> ChatInfo c -> Bool
|
||||
chatNtf user = \case
|
||||
DirectChat ct -> contactNtf user ct
|
||||
GroupChat g -> groupNtf user g
|
||||
_ -> False
|
||||
|
||||
whenGroupNtfs :: ChatMonad' m => User -> GroupInfo -> m () -> m ()
|
||||
whenGroupNtfs user GroupInfo {chatSettings} = whenUserNtfs user . when (enableNtfs chatSettings)
|
||||
contactNtf :: User -> Contact -> Bool
|
||||
contactNtf user Contact {chatSettings} = userNtf user && enableNtfs chatSettings
|
||||
|
||||
showMsgToast :: ChatMonad' m => Text -> MsgContent -> Maybe MarkdownList -> m ()
|
||||
showMsgToast from mc md_ = showToast from $ maybe (msgContentText mc) (mconcat . map hideSecret) md_
|
||||
where
|
||||
hideSecret :: FormattedText -> Text
|
||||
hideSecret FormattedText {format = Just Secret} = "..."
|
||||
hideSecret FormattedText {text} = text
|
||||
|
||||
showToast :: ChatMonad' m => Text -> Text -> m ()
|
||||
showToast title text = atomically . (`writeTBQueue` Notification {title, text}) =<< asks notifyQ
|
||||
|
||||
notificationSubscriber :: ChatMonad' m => m ()
|
||||
notificationSubscriber = do
|
||||
ChatController {notifyQ, sendNotification} <- ask
|
||||
forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification
|
||||
groupNtf :: User -> GroupInfo -> Bool
|
||||
groupNtf user GroupInfo {chatSettings} = userNtf user && enableNtfs chatSettings
|
||||
|
||||
withUser' :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse
|
||||
withUser' action =
|
||||
|
|
|
|||
|
|
@ -34,8 +34,7 @@ import Data.List.NonEmpty (NonEmpty)
|
|||
import Data.Map.Strict (Map)
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import Data.Time (NominalDiffTime)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time (NominalDiffTime, UTCTime)
|
||||
import Data.Version (showVersion)
|
||||
import GHC.Generics (Generic)
|
||||
import Language.Haskell.TH (Exp, Q, runIO)
|
||||
|
|
@ -153,20 +152,10 @@ defaultInlineFilesConfig =
|
|||
receiveInstant = True -- allow receiving instant files, within receiveChunks limit
|
||||
}
|
||||
|
||||
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
|
||||
deriving (Eq)
|
||||
|
||||
chatActiveTo :: ChatName -> ActiveTo
|
||||
chatActiveTo (ChatName cType name) = case cType of
|
||||
CTDirect -> ActiveC name
|
||||
CTGroup -> ActiveG name
|
||||
_ -> ActiveNone
|
||||
|
||||
data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLiteStore}
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar (Maybe User),
|
||||
activeTo :: TVar ActiveTo,
|
||||
firstTime :: Bool,
|
||||
smpAgent :: AgentClient,
|
||||
agentAsync :: TVar (Maybe (Async (), Maybe (Async ()))),
|
||||
|
|
@ -175,8 +164,6 @@ data ChatController = ChatController
|
|||
idsDrg :: TVar ChaChaDRG,
|
||||
inputQ :: TBQueue String,
|
||||
outputQ :: TBQueue (Maybe CorrId, ChatResponse),
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO (),
|
||||
subscriptionMode :: TVar SubscriptionMode,
|
||||
chatLock :: Lock,
|
||||
sndFiles :: TVar (Map Int64 Handle),
|
||||
|
|
@ -433,7 +420,7 @@ data ChatResponse
|
|||
| CRApiChats {user :: User, chats :: [AChat]}
|
||||
| CRChats {chats :: [AChat]}
|
||||
| CRApiChat {user :: User, chat :: AChat}
|
||||
| CRChatItems {user :: User, chatItems :: [AChatItem]}
|
||||
| CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]}
|
||||
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
|
||||
| CRChatItemId User (Maybe ChatItemId)
|
||||
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
|
||||
|
|
@ -1074,14 +1061,6 @@ mkChatError = ChatError . CEException . show
|
|||
chatCmdError :: Maybe User -> String -> ChatResponse
|
||||
chatCmdError user = CRChatCmdError user . ChatError . CECommandError
|
||||
|
||||
setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
setActive to = asks activeTo >>= atomically . (`writeTVar` to)
|
||||
|
||||
unsetActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
unsetActive a = asks activeTo >>= atomically . (`modifyTVar` unset)
|
||||
where
|
||||
unset a' = if a == a' then ActiveNone else a'
|
||||
|
||||
toView :: ChatMonad' m => ChatResponse -> m ()
|
||||
toView event = do
|
||||
q <- asks outputQ
|
||||
|
|
|
|||
|
|
@ -14,8 +14,8 @@ import Simplex.Chat.Types
|
|||
import System.Exit (exitFailure)
|
||||
import UnliftIO.Async
|
||||
|
||||
simplexChatCore :: ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> (User -> ChatController -> IO ()) -> IO ()
|
||||
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat =
|
||||
simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
|
||||
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} chat =
|
||||
case logAgent of
|
||||
Just level -> do
|
||||
setLogLevel level
|
||||
|
|
@ -28,7 +28,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {core
|
|||
exitFailure
|
||||
run db@ChatDatabase {chatStore} = do
|
||||
u <- getCreateActiveUser chatStore testView
|
||||
cc <- newChatController db (Just u) cfg opts sendToast
|
||||
cc <- newChatController db (Just u) cfg opts
|
||||
runSimplexChat opts u cc chat
|
||||
|
||||
runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
|
||||
|
|
|
|||
|
|
@ -50,8 +50,10 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
|||
data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
|
||||
deriving (Eq, Show, Ord, Generic)
|
||||
|
||||
data ChatName = ChatName ChatType Text
|
||||
deriving (Show)
|
||||
data ChatName = ChatName {chatType :: ChatType, chatName :: Text}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON ChatName where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
chatTypeStr :: ChatType -> String
|
||||
chatTypeStr = \case
|
||||
|
|
|
|||
|
|
@ -196,7 +196,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
|
|||
where
|
||||
initialize st db = do
|
||||
user_ <- getActiveUser_ st
|
||||
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix dbKey) Nothing
|
||||
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix dbKey)
|
||||
migrate createStore dbFile confirmMigrations =
|
||||
ExceptT $
|
||||
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations)
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ import qualified Simplex.Messaging.Crypto as C
|
|||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI (..), SubscriptionMode)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
|
||||
createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
|
||||
createUserRecord db auId p activeUser = createUserRecordAt db auId p activeUser =<< liftIO getCurrentTime
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ import Simplex.Chat.Core
|
|||
import Simplex.Chat.Help (chatWelcome)
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Terminal.Input
|
||||
import Simplex.Chat.Terminal.Notification
|
||||
import Simplex.Chat.Terminal.Output
|
||||
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
||||
import Simplex.Messaging.Client (defaultNetworkConfig)
|
||||
|
|
@ -40,10 +39,9 @@ terminalChatConfig =
|
|||
}
|
||||
|
||||
simplexChatTerminal :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
|
||||
simplexChatTerminal cfg opts t = do
|
||||
sendToast <- if muteNotifications opts then pure Nothing else Just <$> initializeNotifications
|
||||
handle checkDBKeyError . simplexChatCore cfg opts sendToast $ \u cc -> do
|
||||
ct <- newChatTerminal t
|
||||
simplexChatTerminal cfg opts t =
|
||||
handle checkDBKeyError . simplexChatCore cfg opts $ \u cc -> do
|
||||
ct <- newChatTerminal t opts
|
||||
when (firstTime cc) . printToTerminal ct $ chatWelcome u
|
||||
runChatTerminal ct cc
|
||||
|
||||
|
|
|
|||
|
|
@ -57,14 +57,26 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
|||
cmd = parseChatCommand bs
|
||||
unless (isMessage cmd) $ echo s
|
||||
r <- runReaderT (execChatCommand bs) cc
|
||||
case r of
|
||||
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
|
||||
CRChatError _ _ -> when (isMessage cmd) $ echo s
|
||||
_ -> pure ()
|
||||
processResp s cmd r
|
||||
printRespToTerminal ct cc False r
|
||||
startLiveMessage cmd r
|
||||
where
|
||||
echo s = printToTerminal ct [plain s]
|
||||
processResp s cmd = \case
|
||||
CRActiveUser _ -> setActive ct ""
|
||||
CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_
|
||||
CRNewChatItem u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRChatItemDeleted u (AChatItem _ _ cInfo _) _ _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
|
||||
CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g
|
||||
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
|
||||
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
|
||||
CRChatError _ _ -> when (isMessage cmd) $ echo s
|
||||
CRCmdOk _ -> case cmd of
|
||||
Right APIDeleteUser {} -> setActive ct ""
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
isMessage = \case
|
||||
Right SendMessage {} -> True
|
||||
Right SendLiveMessage {} -> True
|
||||
|
|
@ -134,7 +146,7 @@ runTerminalInput ct cc = withChatTerm ct $ do
|
|||
receiveFromTTY cc ct
|
||||
|
||||
receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
|
||||
receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState} =
|
||||
receiveFromTTY cc@ChatController {inputQ, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} =
|
||||
forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
|
||||
where
|
||||
processKey :: (Key, Modifiers) -> IO ()
|
||||
|
|
@ -153,11 +165,11 @@ receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@C
|
|||
when (inputString ts /= "" || isLive) $
|
||||
atomically (submitInput live ts) >>= mapM_ (uncurry endLiveMessage)
|
||||
update key = do
|
||||
ac <- readTVarIO activeTo
|
||||
chatPrefix <- readTVarIO activeTo
|
||||
live <- isJust <$> readTVarIO liveMessageState
|
||||
ts <- readTVarIO termState
|
||||
user_ <- readTVarIO currentUser
|
||||
ts' <- updateTermState user_ chatStore ac live (width termSize) key ts
|
||||
ts' <- updateTermState user_ chatStore chatPrefix live (width termSize) key ts
|
||||
atomically $ writeTVar termState $! ts'
|
||||
|
||||
endLiveMessage :: String -> LiveMessage -> IO ()
|
||||
|
|
@ -203,8 +215,8 @@ data AutoComplete
|
|||
| ACCommand Text
|
||||
| ACNone
|
||||
|
||||
updateTermState :: Maybe User -> SQLiteStore -> ActiveTo -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
|
||||
updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
|
||||
updateTermState :: Maybe User -> SQLiteStore -> String -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
|
||||
updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
|
||||
CharKey c
|
||||
| ms == mempty || ms == shiftKey -> pure $ insertChars $ charsWithContact [c]
|
||||
| ms == altKey && c == 'b' -> pure $ setPosition prevWordPos
|
||||
|
|
@ -326,17 +338,13 @@ updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s,
|
|||
charsWithContact cs
|
||||
| live = cs
|
||||
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
|
||||
contactPrefix <> cs
|
||||
chatPrefix <> cs
|
||||
| (s == ">" || s == "\\" || s == "!") && cs == " " =
|
||||
cs <> contactPrefix
|
||||
cs <> chatPrefix
|
||||
| otherwise = cs
|
||||
insertChars = ts' . if p >= length s then append else insert
|
||||
append cs = let s' = s <> cs in (s', length s')
|
||||
insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
|
||||
contactPrefix = case ac of
|
||||
ActiveNone -> ""
|
||||
ActiveC c -> "@" <> T.unpack c <> " "
|
||||
ActiveG g -> "#" <> T.unpack g <> " "
|
||||
backDeleteChar
|
||||
| p == 0 || null s = ts
|
||||
| p >= length s = ts' (init s, length s - 1)
|
||||
|
|
|
|||
|
|
@ -13,13 +13,14 @@ import qualified Data.Map as M
|
|||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Util (catchAll_)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory)
|
||||
import System.FilePath (combine)
|
||||
import System.Info (os)
|
||||
import System.Process (readCreateProcess, shell)
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
initializeNotifications :: IO (Notification -> IO ())
|
||||
initializeNotifications =
|
||||
hideException <$> case os of
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
|
|
@ -14,13 +15,24 @@ import Control.Monad.Catch (MonadMask)
|
|||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.List (intercalate)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Simplex.Chat (processChatCommand)
|
||||
import Simplex.Chat (processChatCommand, chatNtf, contactNtf, groupNtf, userNtf)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..))
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications)
|
||||
import Simplex.Chat.Types (Contact, GroupInfo (..), User (..), UserContactRequest (..))
|
||||
import Simplex.Chat.View
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import System.Console.ANSI.Types
|
||||
import System.IO (IOMode (..), hPutStrLn, withFile)
|
||||
import System.Mem.Weak (Weak)
|
||||
|
|
@ -34,7 +46,9 @@ data ChatTerminal = ChatTerminal
|
|||
termSize :: Size,
|
||||
liveMessageState :: TVar (Maybe LiveMessage),
|
||||
nextMessageRow :: TVar Int,
|
||||
termLock :: TMVar ()
|
||||
termLock :: TMVar (),
|
||||
sendNotification :: Maybe (Notification -> IO ()),
|
||||
activeTo :: TVar String
|
||||
}
|
||||
|
||||
data TerminalState = TerminalState
|
||||
|
|
@ -79,16 +93,28 @@ instance WithTerminal VirtualTerminal where
|
|||
withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
|
||||
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
|
||||
|
||||
newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
|
||||
newChatTerminal t = do
|
||||
newChatTerminal :: WithTerminal t => t -> ChatOpts -> IO ChatTerminal
|
||||
newChatTerminal t opts = do
|
||||
termSize <- withTerm t . runTerminalT $ getWindowSize
|
||||
let lastRow = height termSize - 1
|
||||
termState <- newTVarIO mkTermState
|
||||
liveMessageState <- newTVarIO Nothing
|
||||
termLock <- newTMVarIO ()
|
||||
nextMessageRow <- newTVarIO lastRow
|
||||
sendNotification <- if muteNotifications opts then pure Nothing else Just <$> initializeNotifications
|
||||
activeTo <- newTVarIO ""
|
||||
-- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
|
||||
return ChatTerminal {termDevice = TerminalDevice t, termState, termSize, liveMessageState, nextMessageRow, termLock}
|
||||
pure
|
||||
ChatTerminal
|
||||
{ termDevice = TerminalDevice t,
|
||||
termState,
|
||||
termSize,
|
||||
liveMessageState,
|
||||
nextMessageRow,
|
||||
termLock,
|
||||
sendNotification,
|
||||
activeTo
|
||||
}
|
||||
|
||||
mkTermState :: TerminalState
|
||||
mkTermState =
|
||||
|
|
@ -122,6 +148,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
|
|||
_ -> printToTerminal ct
|
||||
liveItems <- readTVarIO showLiveItems
|
||||
responseString cc liveItems r >>= printResp
|
||||
responseNotification ct cc r
|
||||
where
|
||||
markChatItemRead (AChatItem _ _ chat item@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
|
||||
case (muted chat chatDir, itemStatus) of
|
||||
|
|
@ -132,6 +159,100 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
|
|||
_ -> pure ()
|
||||
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
|
||||
|
||||
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
|
||||
responseNotification t@ChatTerminal {sendNotification} cc = \case
|
||||
CRNewChatItem u (AChatItem _ SMDRcv cInfo ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) ->
|
||||
when (chatNtf u cInfo) $ do
|
||||
whenCurrUser cc u $ setActiveChat t cInfo
|
||||
case (cInfo, chatDir) of
|
||||
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
|
||||
(GroupChat g, CIGroupRcv m) -> sendNtf (fromGroup_ g m, text)
|
||||
_ -> pure ()
|
||||
where
|
||||
text = msgText mc formattedText
|
||||
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ChatItem {content = CIRcvMsgContent _}) ->
|
||||
whenCurrUser cc u $ when (chatNtf u cInfo) $ setActiveChat t cInfo
|
||||
CRContactConnected u ct _ -> when (contactNtf u ct) $ do
|
||||
whenCurrUser cc u $ setActiveContact t ct
|
||||
sendNtf (viewContactName ct <> "> ", "connected")
|
||||
CRContactAnotherClient u ct -> do
|
||||
whenCurrUser cc u $ unsetActiveContact t ct
|
||||
when (contactNtf u ct) $ sendNtf (viewContactName ct <> "> ", "connected to another client")
|
||||
CRContactsDisconnected srv _ -> serverNtf srv "disconnected"
|
||||
CRContactsSubscribed srv _ -> serverNtf srv "connected"
|
||||
CRReceivedGroupInvitation u g ct _ _ ->
|
||||
when (contactNtf u ct) $
|
||||
sendNtf ("#" <> viewGroupName g <> " " <> viewContactName ct <> "> ", "invited you to join the group")
|
||||
CRUserJoinedGroup u g _ -> when (groupNtf u g) $ do
|
||||
whenCurrUser cc u $ setActiveGroup t g
|
||||
sendNtf ("#" <> viewGroupName g, "you are connected to group")
|
||||
CRJoinedGroupMember u g m ->
|
||||
when (groupNtf u g) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
|
||||
CRConnectedToGroupMember u g m _ ->
|
||||
when (groupNtf u g) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
|
||||
CRReceivedContactRequest u UserContactRequest {localDisplayName = n} ->
|
||||
when (userNtf u) $ sendNtf (viewName n <> ">", "wants to connect to you")
|
||||
_ -> pure ()
|
||||
where
|
||||
sendNtf = maybe (\_ -> pure ()) (. uncurry Notification) sendNotification
|
||||
serverNtf (SMPServer host _ _) str = sendNtf ("server " <> str, safeDecodeUtf8 $ strEncode host)
|
||||
|
||||
msgText :: MsgContent -> Maybe MarkdownList -> Text
|
||||
msgText (MCFile _) _ = "wants to send a file"
|
||||
msgText mc md_ = maybe (msgContentText mc) (mconcat . map hideSecret) md_
|
||||
where
|
||||
hideSecret :: FormattedText -> Text
|
||||
hideSecret FormattedText {format = Just Secret} = "..."
|
||||
hideSecret FormattedText {text} = text
|
||||
|
||||
chatActiveTo :: ChatName -> String
|
||||
chatActiveTo (ChatName cType name) = case cType of
|
||||
CTDirect -> T.unpack $ "@" <> viewName name <> " "
|
||||
CTGroup -> T.unpack $ "#" <> viewName name <> " "
|
||||
_ -> ""
|
||||
|
||||
chatInfoActiveTo :: ChatInfo c -> String
|
||||
chatInfoActiveTo = \case
|
||||
DirectChat c -> contactActiveTo c
|
||||
GroupChat g -> groupActiveTo g
|
||||
_ -> ""
|
||||
|
||||
contactActiveTo :: Contact -> String
|
||||
contactActiveTo c = T.unpack $ "@" <> viewContactName c <> " "
|
||||
|
||||
groupActiveTo :: GroupInfo -> String
|
||||
groupActiveTo g = T.unpack $ "#" <> viewGroupName g <> " "
|
||||
|
||||
setActiveChat :: ChatTerminal -> ChatInfo c -> IO ()
|
||||
setActiveChat t = setActive t . chatInfoActiveTo
|
||||
|
||||
setActiveContact :: ChatTerminal -> Contact -> IO ()
|
||||
setActiveContact t = setActive t . contactActiveTo
|
||||
|
||||
setActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
|
||||
setActiveGroup t = setActive t . groupActiveTo
|
||||
|
||||
setActive :: ChatTerminal -> String -> IO ()
|
||||
setActive ChatTerminal {activeTo} to = atomically $ writeTVar activeTo to
|
||||
|
||||
unsetActiveContact :: ChatTerminal -> Contact -> IO ()
|
||||
unsetActiveContact t = unsetActive t . contactActiveTo
|
||||
|
||||
unsetActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
|
||||
unsetActiveGroup t = unsetActive t . groupActiveTo
|
||||
|
||||
unsetActive :: ChatTerminal -> String -> IO ()
|
||||
unsetActive ChatTerminal {activeTo} to' = atomically $ modifyTVar activeTo unset
|
||||
where
|
||||
unset to = if to == to' then "" else to
|
||||
|
||||
whenCurrUser :: ChatController -> User -> IO () -> IO ()
|
||||
whenCurrUser cc u a = do
|
||||
u_ <- readTVarIO $ currentUser cc
|
||||
when (sameUser u u_) a
|
||||
where
|
||||
sameUser User {userId = uId} = maybe False $ \User {userId} -> userId == uId
|
||||
|
||||
printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> ChatResponse -> IO ()
|
||||
printRespToTerminal ct cc liveItems r = responseString cc liveItems r >>= printToTerminal ct
|
||||
|
||||
|
|
|
|||
|
|
@ -1424,8 +1424,6 @@ serializeIntroStatus = \case
|
|||
GMIntroToConnected -> "to-con"
|
||||
GMIntroConnected -> "con"
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
|
||||
textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode
|
||||
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
|||
CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView
|
||||
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
|
||||
CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewChatItem chat item False ts tz <> viewItemReactions item
|
||||
CRChatItems u chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
|
||||
CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
|
||||
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
|
||||
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
|
||||
CRChatItemStatusUpdated u ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ withBroadcastBot :: BroadcastBotOpts -> IO () -> IO ()
|
|||
withBroadcastBot opts test =
|
||||
bracket (forkIO bot) killThread (\_ -> threadDelay 500000 >> test)
|
||||
where
|
||||
bot = simplexChatCore testCfg (mkChatOpts opts) Nothing $ broadcastBot opts
|
||||
bot = simplexChatCore testCfg (mkChatOpts opts) $ broadcastBot opts
|
||||
|
||||
broadcastBotProfile :: Profile
|
||||
broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", image = Nothing, contactLink = Nothing, preferences = Nothing}
|
||||
|
|
|
|||
|
|
@ -827,7 +827,7 @@ runDirectory cfg opts@DirectoryOpts {directoryLog} action = do
|
|||
threadDelay 500000
|
||||
action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t)
|
||||
where
|
||||
bot st = simplexChatCore cfg (mkChatOpts opts) Nothing $ directoryService st opts
|
||||
bot st = simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts
|
||||
|
||||
registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
|
||||
registerGroup su u n fn = registerGroupId su u n fn 1 1
|
||||
|
|
|
|||
|
|
@ -161,8 +161,8 @@ startTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefi
|
|||
startTestChat_ :: ChatDatabase -> ChatConfig -> ChatOpts -> User -> IO TestCC
|
||||
startTestChat_ db cfg opts user = do
|
||||
t <- withVirtualTerminal termSettings pure
|
||||
ct <- newChatTerminal t
|
||||
cc <- newChatController db (Just user) cfg opts Nothing -- no notifications
|
||||
ct <- newChatTerminal t opts
|
||||
cc <- newChatController db (Just user) cfg opts
|
||||
chatAsync <- async . runSimplexChat opts user cc . const $ runChatTerminal ct
|
||||
atomically . unless (maintenance opts) $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry
|
||||
termQ <- newTQueueIO
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue