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
2023-10-11 09:50:11 +01:00
committed by GitHub
parent a67b79952b
commit 4ecf94dfad
21 changed files with 249 additions and 181 deletions
+72 -111
View File
@@ -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 =