dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-06-04 10:21:50 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into group-knocking

Browse Source
This commit is contained in:
Evgeny Poberezkin
2025-05-05 12:53:05 +01:00
parent 3aa6d6c3b3 24b0f0290b
commit c3bb1e660d
54 changed files with 2194 additions and 2244 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Bot.hs
+7 -7
View File
@@ -35,10 +35,10 @@ chatBotRepl welcome answer _user cc = do
race_ (forever $ void getLine) . forever $ do
(_, event) <- atomically . readTBQueue $ outputQ cc
case event of
CEvtContactConnected _ contact _ -> do
Right (CEvtContactConnected _ contact _) -> do
contactConnected contact
void $ sendMessage cc contact $ T.pack welcome
CEvtNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do
Right CEvtNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat contact) ChatItem {content = mc@CIRcvMsgContent {}}) : _} -> do
let msg = T.unpack $ ciContentToText mc
void $ sendMessage cc contact . T.pack =<< answer contact msg
_ -> pure ()
@@ -51,12 +51,12 @@ initializeBotAddress = initializeBotAddress' True
initializeBotAddress' :: Bool -> ChatController -> IO ()
initializeBotAddress' logAddress cc = do
sendChatCmd cc ShowMyAddress >>= \case
CRUserContactLink _ UserContactLink {connLinkContact} -> showBotAddress connLinkContact
CRChatCmdError _ (ChatErrorStore SEUserContactLinkNotFound) -> do
Right (CRUserContactLink _ UserContactLink {connLinkContact}) -> showBotAddress connLinkContact
Left (ChatErrorStore SEUserContactLinkNotFound) -> do
when logAddress $ putStrLn "No bot address, creating..."
-- TODO [short links] create short link by default
sendChatCmd cc (CreateMyAddress False) >>= \case
CRUserContactLinkCreated _ ccLink -> showBotAddress ccLink
Right (CRUserContactLinkCreated _ ccLink) -> showBotAddress ccLink
_ -> putStrLn "can't create bot address" >> exitFailure
_ -> putStrLn "unexpected response" >> exitFailure
where
@@ -84,14 +84,14 @@ sendComposedMessages_ :: ChatController -> SendRef -> NonEmpty (Maybe ChatItemId
sendComposedMessages_ cc sendRef qmcs = do
let cms = L.map (\(qiId, mc) -> ComposedMessage {fileSource = Nothing, quotedItemId = qiId, msgContent = mc, mentions = M.empty}) qmcs
sendChatCmd cc (APISendMessages sendRef False Nothing cms) >>= \case
CRNewChatItems {} -> printLog cc CLLInfo $ "sent " <> show (length cms) <> " messages to " <> show sendRef
Right (CRNewChatItems {}) -> printLog cc CLLInfo $ "sent " <> show (length cms) <> " messages to " <> show sendRef
r -> putStrLn $ "unexpected send message response: " <> show r
deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()
deleteMessage cc ct chatItemId = do
let cmd = APIDeleteChatItem (contactRef ct) [chatItemId] CIDMInternal
sendChatCmd cc cmd >>= \case
CRChatItemsDeleted {} -> printLog cc CLLInfo $ "deleted message(s) from " <> contactInfo ct
Right (CRChatItemsDeleted {}) -> printLog cc CLLInfo $ "deleted message(s) from " <> contactInfo ct
r -> putStrLn $ "unexpected delete message response: " <> show r
contactRef :: Contact -> ChatRef
src/Simplex/Chat/Controller.hs
+28 -14
View File
@@ -172,10 +172,10 @@ data ChatHooks = ChatHooks
{ -- preCmdHook can be used to process or modify the commands before they are processed.
-- This hook should be used to process CustomChatCommand.
-- if this hook returns ChatResponse, the command processing will be skipped.
preCmdHook :: Maybe (ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand)),
preCmdHook :: Maybe (ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand)),
-- eventHook can be used to additionally process or modify events,
-- it is called before the event is sent to the user (or to the UI).
eventHook :: Maybe (ChatController -> ChatEvent -> IO ChatEvent),
eventHook :: Maybe (ChatController -> Either ChatError ChatEvent -> IO (Either ChatError ChatEvent)),
-- acceptMember hook can be used to accept or reject member connecting via group link without API calls
acceptMember :: Maybe (GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
}
@@ -223,7 +223,7 @@ data ChatController = ChatController
random :: TVar ChaChaDRG,
eventSeq :: TVar Int,
inputQ :: TBQueue String,
outputQ :: TBQueue (Maybe RemoteHostId, ChatEvent),
outputQ :: TBQueue (Maybe RemoteHostId, Either ChatError ChatEvent),
connNetworkStatuses :: TMap AgentConnId NetworkStatus,
subscriptionMode :: TVar SubscriptionMode,
chatLock :: Lock,
@@ -739,7 +739,6 @@ data ChatResponse
| CRAgentSubs {activeSubs :: Map Text Int, pendingSubs :: Map Text Int, removedSubs :: Map Text [String]}
| CRAgentSubsDetails {agentSubs :: SubscriptionsInfo}
| CRAgentQueuesInfo {agentQueuesInfo :: AgentQueuesInfo}
| CRChatCmdError {user_ :: Maybe User, chatError :: ChatError}
| CRAppSettings {appSettings :: AppSettings}
| CRCustomChatResponse {user_ :: Maybe User, response :: Text}
deriving (Show)
@@ -848,8 +847,7 @@ data ChatEvent
| CEvtAgentConnsDeleted {agentConnIds :: NonEmpty AgentConnId}
| CEvtAgentUserDeleted {agentUserId :: Int64}
| CEvtMessageError {user :: User, severity :: Text, errorMessage :: Text}
| CEvtChatError {user_ :: Maybe User, chatError :: ChatError}
| CEvtChatErrors {user_ :: Maybe User, chatErrors :: [ChatError]}
| CEvtChatErrors {chatErrors :: [ChatError]}
| CEvtTimedAction {action :: String, durationMilliseconds :: Int64}
| CEvtTerminalEvent TerminalEvent
deriving (Show)
@@ -878,7 +876,6 @@ data DeletedRcvQueue = DeletedRcvQueue
}
deriving (Show)
-- some of these can only be used as command responses
allowRemoteEvent :: ChatEvent -> Bool
allowRemoteEvent = \case
CEvtChatSuspended -> False
@@ -902,8 +899,7 @@ logEventToFile = \case
CEvtAgentRcvQueuesDeleted {} -> True
CEvtAgentConnsDeleted {} -> True
CEvtAgentUserDeleted {} -> True
-- CEvtChatCmdError {} -> True -- TODO this should be separately logged to file
CEvtChatError {} -> True
-- CRChatCmdError {} -> True -- TODO this should be separately logged to file as command error
CEvtMessageError {} -> True
CEvtTerminalEvent te -> case te of
TEMemberSubError {} -> True
@@ -1416,7 +1412,7 @@ data RemoteCtrlSession
tls :: TLS,
rcsSession :: RCCtrlSession,
http2Server :: Async (),
remoteOutputQ :: TBQueue ChatEvent
remoteOutputQ :: TBQueue (Either ChatError ChatEvent)
}
data RemoteCtrlSessionState
@@ -1515,11 +1511,17 @@ mkStoreError :: SomeException -> StoreError
mkStoreError = SEInternalError . show
{-# INLINE mkStoreError #-}
chatCmdError :: Maybe User -> String -> ChatResponse
chatCmdError user = CRChatCmdError user . ChatError . CECommandError
throwCmdError :: String -> CM a
throwCmdError = throwError . ChatError . CECommandError
{-# INLINE throwCmdError #-}
chatCmdError :: String -> Either ChatError ChatResponse
chatCmdError = Left . ChatError . CECommandError
{-# INLINE chatCmdError #-}
throwChatError :: ChatErrorType -> CM a
throwChatError = throwError . ChatError
{-# INLINE throwChatError #-}
toViewTE :: TerminalEvent -> CM ()
toViewTE = toView . CEvtTerminalEvent
@@ -1531,7 +1533,19 @@ toView = lift . toView'
{-# INLINE toView #-}
toView' :: ChatEvent -> CM' ()
toView' ev = do
toView' = toView_ . Right
{-# INLINE toView' #-}
eToView :: ChatError -> CM ()
eToView = lift . eToView'
{-# INLINE eToView #-}
eToView' :: ChatError -> CM' ()
eToView' = toView_ . Left
{-# INLINE eToView' #-}
toView_ :: Either ChatError ChatEvent -> CM' ()
toView_ ev = do
cc@ChatController {outputQ = localQ, remoteCtrlSession = session, config = ChatConfig {chatHooks}} <- ask
event <- case eventHook chatHooks of
Just hook -> liftIO $ hook cc ev
@@ -1539,7 +1553,7 @@ toView' ev = do
atomically $
readTVar session >>= \case
Just (_, RCSessionConnected {remoteOutputQ})
| allowRemoteEvent event -> writeTBQueue remoteOutputQ event
| either (const True) allowRemoteEvent event -> writeTBQueue remoteOutputQ event
-- TODO potentially, it should hold some events while connecting
_ -> writeTBQueue localQ (Nothing, event)
src/Simplex/Chat/Core.hs
+16 -9
View File
@@ -8,6 +8,7 @@ module Simplex.Chat.Core
runSimplexChat,
sendChatCmdStr,
sendChatCmd,
printResponseEvent,
)
where
@@ -23,9 +24,10 @@ import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands
import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
import Simplex.Chat.Remote.Types (RemoteHostId)
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Types
import Simplex.Chat.View (serializeChatResponse)
import Simplex.Chat.View (ChatResponseEvent, serializeChatError, serializeChatResponse)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
import System.Exit (exitFailure)
@@ -62,10 +64,10 @@ runSimplexChat ChatOpts {maintenance} u cc chat
a2 <- async $ chat u cc
waitEither_ a1 a2
sendChatCmdStr :: ChatController -> String -> IO ChatResponse
sendChatCmdStr :: ChatController -> String -> IO (Either ChatError ChatResponse)
sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc
sendChatCmd :: ChatController -> ChatCommand -> IO ChatResponse
sendChatCmd :: ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc
getSelectActiveUser :: DBStore -> IO (Maybe User)
@@ -107,12 +109,17 @@ createActiveUser cc = do
displayName <- T.pack <$> getWithPrompt "display name"
let profile = Just Profile {displayName, fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing}
execChatCommand' (CreateActiveUser NewUser {profile, pastTimestamp = False}) `runReaderT` cc >>= \case
CRActiveUser user -> pure user
r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
putStrLn $ serializeChatResponse (Nothing, Nothing) ts tz Nothing r
loop
Right (CRActiveUser user) -> pure user
r -> printResponseEvent (Nothing, Nothing) (config cc) r >> loop
printResponseEvent :: ChatResponseEvent r => (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Either ChatError r -> IO ()
printResponseEvent hu cfg = \case
Right r -> do
ts <- getCurrentTime
tz <- getCurrentTimeZone
putStrLn $ serializeChatResponse hu cfg ts tz (fst hu) r
Left e -> do
putStrLn $ serializeChatError True cfg e
getWithPrompt :: String -> IO String
getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
src/Simplex/Chat/Library/Commands.hs
+150 -153
View File
@@ -225,7 +225,7 @@ startReceiveUserFiles :: User -> CM ()
startReceiveUserFiles user = do
filesToReceive <- withStore' (`getRcvFilesToReceive` user)
forM_ filesToReceive $ \ft ->
flip catchChatError (toView . CEvtChatError (Just user)) $
flip catchChatError eToView $
toView =<< receiveFileEvt' user ft False Nothing Nothing
restoreCalls :: CM' ()
@@ -267,32 +267,28 @@ useServers as opDomains uss =
xftp' = useServerCfgs SPXFTP as opDomains $ concatMap (servers' SPXFTP) uss
in (smp', xftp')
execChatCommand :: Maybe RemoteHostId -> ByteString -> CM' ChatResponse
execChatCommand rh s = do
u <- readTVarIO =<< asks currentUser
execChatCommand :: Maybe RemoteHostId -> ByteString -> CM' (Either ChatError ChatResponse)
execChatCommand rh s =
case parseChatCommand s of
Left e -> pure $ chatCmdError u e
Left e -> pure $ chatCmdError e
Right cmd -> case rh of
Just rhId
| allowRemoteCommand cmd -> execRemoteCommand u rhId cmd s
| otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand
| allowRemoteCommand cmd -> execRemoteCommand rhId cmd s
| otherwise -> pure $ Left $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand
_ -> do
cc@ChatController {config = ChatConfig {chatHooks}} <- ask
case preCmdHook chatHooks of
Just hook -> liftIO (hook cc cmd) >>= either pure (execChatCommand_ u)
Nothing -> execChatCommand_ u cmd
Just hook -> liftIO (hook cc cmd) >>= either pure execChatCommand'
Nothing -> execChatCommand' cmd
execChatCommand' :: ChatCommand -> CM' ChatResponse
execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
execChatCommand' :: ChatCommand -> CM' (Either ChatError ChatResponse)
execChatCommand' cmd = handleCommandError $ processChatCommand cmd
execChatCommand_ :: Maybe User -> ChatCommand -> CM' ChatResponse
execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd
execRemoteCommand :: RemoteHostId -> ChatCommand -> ByteString -> CM' (Either ChatError ChatResponse)
execRemoteCommand rhId cmd s = handleCommandError $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s
execRemoteCommand :: Maybe User -> RemoteHostId -> ChatCommand -> ByteString -> CM' ChatResponse
execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s
handleCommandError :: Maybe User -> CM ChatResponse -> CM' ChatResponse
handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catches` ioErrors)
handleCommandError :: CM ChatResponse -> CM' (Either ChatError ChatResponse)
handleCommandError a = runExceptT a `E.catches` ioErrors
where
ioErrors =
[ E.Handler $ \(e :: ExitCode) -> E.throwIO e,
@@ -502,23 +498,23 @@ processChatCommand' vr = \case
pure $ CRChatTags user tags
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user pendingConnections pagination query)
unless (null errs) $ toView $ CEvtChatErrors (Just user) (map ChatErrorStore errs)
unless (null errs) $ toView $ CEvtChatErrors (map ChatErrorStore errs)
pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId scope_) contentFilter pagination search -> withUser $ \user -> case cType of
-- TODO optimize queries calculating ChatStats, currently they're disabled
CTDirect -> do
when (isJust contentFilter) $ throwChatError $ CECommandError "content filter not supported"
when (isJust contentFilter) $ throwCmdError "content filter not supported"
(directChat, navInfo) <- withFastStore (\db -> getDirectChat db vr user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat) navInfo
CTGroup -> do
(groupChat, navInfo) <- withFastStore (\db -> getGroupChat db vr user cId scope_ contentFilter pagination search)
pure $ CRApiChat user (AChat SCTGroup groupChat) navInfo
CTLocal -> do
when (isJust contentFilter) $ throwChatError $ CECommandError "content filter not supported"
when (isJust contentFilter) $ throwCmdError "content filter not supported"
(localChat, navInfo) <- withFastStore (\db -> getLocalChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTLocal localChat) navInfo
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> throwCmdError "not implemented"
CTContactConnection -> throwCmdError "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do
chatItems <- withFastStore $ \db -> getAllChatItems db vr user pagination search
pure $ CRChatItems user Nothing chatItems
@@ -554,14 +550,14 @@ processChatCommand' vr = \case
APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
_ <- createChatTag db user emoji text
CRChatTags user <$> getUserChatTags db user
APISetChatTags (ChatRef cType chatId scope) tagIds -> withUser $ \user -> withFastStore' $ \db -> case cType of
CTDirect -> do
APISetChatTags (ChatRef cType chatId scope) tagIds -> withUser $ \user -> case cType of
CTDirect -> withFastStore' $ \db -> do
updateDirectChatTags db chatId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> getUserChatTags db user <*> getDirectChatTags db chatId
CTGroup | isNothing scope -> do
CTGroup | isNothing scope -> withFastStore' $ \db -> do
updateGroupChatTags db chatId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> getUserChatTags db user <*> getGroupChatTags db chatId
_ -> pure $ chatCmdError (Just user) "not supported"
_ -> throwCmdError "not supported"
APIDeleteChatTag tagId -> withUser $ \user -> do
withFastStore' $ \db -> deleteChatTag db user tagId
ok user
@@ -587,7 +583,7 @@ processChatCommand' vr = \case
processChatCommand $ APIReportMessage gId reportedItemId reportReason ""
APIUpdateChatItem (ChatRef cType chatId scope) itemId live (UpdatedMessage mc mentions) -> withUser $ \user -> assertAllowedContent mc >> case cType of
CTDirect -> withContactLock "updateChatItem" chatId $ do
unless (null mentions) $ throwChatError $ CECommandError "mentions are not supported in this chat"
unless (null mentions) $ throwCmdError "mentions are not supported in this chat"
ct@Contact {contactId} <- withFastStore $ \db -> getContact db vr user chatId
assertDirectAllowed user MDSnd ct XMsgUpdate_
cci <- withFastStore $ \db -> getDirectCIWithReactions db user ct itemId
@@ -616,7 +612,7 @@ processChatCommand' vr = \case
when (isNothing scope) $ assertUserGroupRole gInfo GRAuthor
let (_, ft_) = msgContentTexts mc
if prohibitedSimplexLinks gInfo membership ft_
then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks))
then throwCmdError ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks))
else do
-- TODO [knocking] check chat item scope?
cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId
@@ -646,7 +642,7 @@ processChatCommand' vr = \case
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTLocal -> do
unless (null mentions) $ throwChatError $ CECommandError "mentions are not supported in this chat"
unless (null mentions) $ throwCmdError "mentions are not supported in this chat"
(nf@NoteFolder {noteFolderId}, cci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId
case cci of
CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent oldMC}
@@ -657,8 +653,8 @@ processChatCommand' vr = \case
ci' <- updateLocalChatItem' db user noteFolderId ci (CISndMsgContent mc) True
pure $ CRChatItemUpdated user (AChatItem SCTLocal SMDSnd (LocalChat nf) ci')
_ -> throwChatError CEInvalidChatItemUpdate
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
APIDeleteChatItem (ChatRef cType chatId scope) itemIds mode -> withUser $ \user -> case cType of
CTDirect -> withContactLock "deleteChatItem" chatId $ do
(ct, items) <- getCommandDirectChatItems user chatId itemIds
@@ -698,8 +694,8 @@ processChatCommand' vr = \case
CTLocal -> do
(nf, items) <- getCommandLocalChatItems user chatId itemIds
deleteLocalCIs user nf items True False
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
assertDeletable :: forall c. ChatTypeI c => [CChatItem c] -> CM ()
assertDeletable items = do
@@ -728,7 +724,7 @@ processChatCommand' vr = \case
pure $ CRGroupChatItemsDeleted user g ciIds True (Just $ membership g)
APIDeleteReceivedReports gId itemIds mode -> withUser $ \user -> withGroupLock "deleteReports" gId $ do
(gInfo, items) <- getCommandGroupChatItems user gId itemIds
unless (all isRcvReport items) $ throwChatError $ CECommandError "some items are not received reports"
unless (all isRcvReport items) $ throwCmdError "some items are not received reports"
-- TODO [knocking] scope can be different for each item if reports are from different members
-- TODO (currently we pass Nothing as scope which is wrong)
deletions <- case mode of
@@ -749,9 +745,9 @@ processChatCommand' vr = \case
withFastStore (\db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId) >>= \case
(ct, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do
unless (featureAllowed SCFReactions forUser ct) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions))
throwCmdError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)
unless (ciReactionAllowed ci) $
throwChatError (CECommandError "reaction not allowed - chat item has no content")
throwCmdError "reaction not allowed - chat item has no content"
rs <- withFastStore' $ \db -> getDirectReactions db ct itemSharedMId True
checkReactionAllowed rs
(SndMessage {msgId}, _) <- sendDirectContactMessage user ct $ XMsgReact itemSharedMId Nothing reaction add
@@ -762,7 +758,7 @@ processChatCommand' vr = \case
let ci' = CChatItem md ci {reactions}
r = ACIReaction SCTDirect SMDSnd (DirectChat ct) $ CIReaction CIDirectSnd ci' createdAt reaction
pure $ CRChatItemReaction user add r
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
_ -> throwCmdError "reaction not possible - no shared item ID"
CTGroup ->
withGroupLock "chatItemReaction" chatId $ do
-- TODO [knocking] check chat item scope?
@@ -773,9 +769,9 @@ processChatCommand' vr = \case
case ci of
ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}} -> do
unless (groupFeatureAllowed SGFReactions g) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions))
throwCmdError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)
unless (ciReactionAllowed ci) $
throwChatError (CECommandError "reaction not allowed - chat item has no content")
throwCmdError "reaction not allowed - chat item has no content"
let GroupMember {memberId = itemMemberId} = chatItemMember g ci
rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True
checkReactionAllowed rs
@@ -787,16 +783,16 @@ processChatCommand' vr = \case
let ci' = CChatItem md ci {reactions}
r = ACIReaction SCTGroup SMDSnd (GroupChat g chatScopeInfo) $ CIReaction CIGroupSnd ci' createdAt reaction
pure $ CRChatItemReaction user add r
_ -> throwChatError $ CECommandError "invalid reaction"
CTLocal -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
_ -> throwCmdError "invalid reaction"
CTLocal -> throwCmdError "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
checkReactionAllowed rs = do
when ((reaction `elem` rs) == add) $
throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed")
throwCmdError $ "reaction already " <> if add then "added" else "removed"
when (add && length rs >= maxMsgReactions) $
throwChatError (CECommandError "too many reactions")
throwCmdError "too many reactions"
APIGetReactionMembers userId groupId itemId reaction -> withUserId userId $ \user -> do
memberReactions <- withStore $ \db -> do
CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}} <- getGroupChatItem db user groupId itemId
@@ -807,8 +803,8 @@ processChatCommand' vr = \case
CTDirect -> planForward user . snd =<< getCommandDirectChatItems user fromChatId itemIds
CTGroup -> planForward user . snd =<< getCommandGroupChatItems user fromChatId itemIds
CTLocal -> planForward user . snd =<< getCommandLocalChatItems user fromChatId itemIds
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
planForward :: User -> [CChatItem c] -> CM ChatResponse
planForward user items = do
@@ -872,8 +868,8 @@ processChatCommand' vr = \case
Just cmrs' ->
createNoteFolderContentItems user toChatId cmrs'
Nothing -> pure $ CRNewChatItems user []
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
prepareForward :: User -> CM [ComposedMessageReq]
prepareForward user = case fromCType of
@@ -917,8 +913,8 @@ processChatCommand' vr = \case
ciComposeMsgReq (CChatItem _ ci) (mc', file) =
let ciff = forwardCIFF ci Nothing
in (composedMessage file mc', ciff, msgContentTexts mc', M.empty)
CTContactRequest -> throwChatError $ CECommandError "not supported"
CTContactConnection -> throwChatError $ CECommandError "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
where
prepareMsgReq :: CChatItem c -> CM (Maybe (MsgContent, Maybe CryptoFile))
prepareMsgReq (CChatItem _ ci) = forwardMsgContent ci $>>= forwardContent ci
@@ -1017,8 +1013,8 @@ processChatCommand' vr = \case
user <- withFastStore $ \db -> getUserByNoteFolderId db chatId
withFastStore' $ \db -> updateLocalChatItemsRead db user chatId
ok user
CTContactRequest -> pure $ chatCmdError Nothing "not supported"
CTContactConnection -> pure $ chatCmdError Nothing "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
APIChatItemsRead chatRef@(ChatRef cType chatId scope) itemIds -> withUser $ \_ -> case cType of
CTDirect -> do
user <- withFastStore $ \db -> getUserByContactId db chatId
@@ -1037,9 +1033,9 @@ processChatCommand' vr = \case
setGroupChatItemsDeleteAt db user chatId timedItems =<< getCurrentTime
forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt
ok user
CTLocal -> pure $ chatCmdError Nothing "not supported"
CTContactRequest -> pure $ chatCmdError Nothing "not supported"
CTContactConnection -> pure $ chatCmdError Nothing "not supported"
CTLocal -> throwCmdError "not supported"
CTContactRequest -> throwCmdError "not supported"
CTContactConnection -> throwCmdError "not supported"
APIChatUnread (ChatRef cType chatId scope) unreadChat -> withUser $ \user -> case cType of
CTDirect -> do
withFastStore $ \db -> do
@@ -1057,7 +1053,7 @@ processChatCommand' vr = \case
nf <- getNoteFolder db user chatId
liftIO $ updateNoteFolderUnreadChat db user nf unreadChat
ok user
_ -> pure $ chatCmdError (Just user) "not supported"
_ -> throwCmdError "not supported"
APIDeleteChat cRef@(ChatRef cType chatId scope) cdm -> withUser $ \user@User {userId} -> case cType of
CTDirect -> do
ct <- withFastStore $ \db -> getContact db vr user chatId
@@ -1091,10 +1087,10 @@ processChatCommand' vr = \case
let doSendDel = contactReady ct && contactActive ct && notify
when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchChatError` const (pure ())
contactConnIds <- map aConnId <$> withFastStore' (\db -> getContactConnections db vr userId ct)
deleteAgentConnectionsAsync' user contactConnIds doSendDel
deleteAgentConnectionsAsync' contactConnIds doSendDel
CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId . procCmd $ do
conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withFastStore $ \db -> getPendingContactConnection db userId chatId
deleteAgentConnectionAsync user acId
deleteAgentConnectionAsync acId
withFastStore' $ \db -> deletePendingContactConnection db userId chatId
pure $ CRContactConnectionDeleted user conn
CTGroup | isNothing scope -> do
@@ -1117,7 +1113,7 @@ processChatCommand' vr = \case
withFastStore' $ \db -> deleteGroupMembers db user gInfo
withFastStore' $ \db -> deleteGroup db user gInfo
pure $ CRGroupDeletedUser user gInfo
_ -> pure $ chatCmdError (Just user) "not supported"
_ -> throwCmdError "not supported"
APIClearChat (ChatRef cType chatId scope) -> withUser $ \user@User {userId} -> case cType of
CTDirect -> do
ct <- withFastStore $ \db -> getContact db vr user chatId
@@ -1140,7 +1136,7 @@ processChatCommand' vr = \case
withFastStore' $ \db -> deleteNoteFolderFiles db userId nf
withFastStore' $ \db -> deleteNoteFolderCIs db user nf
pure $ CRChatCleared user (AChatInfo SCTLocal $ LocalChat nf)
_ -> pure $ chatCmdError (Just user) "not supported"
_ -> throwCmdError "not supported"
APIAcceptContact incognito connReqId -> withUser $ \_ -> do
userContactLinkId <- withFastStore $ \db -> getUserContactLinkIdByCReq db connReqId
withUserContactLock "acceptContact" userContactLinkId $ do
@@ -1187,7 +1183,7 @@ processChatCommand' vr = \case
forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci]
ok user
else pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFCalls))
else throwCmdError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFCalls)
SendCallInvitation cName callType -> withUser $ \user -> do
contactId <- withFastStore $ \db -> getContactIdByName db user cName
processChatCommand $ APISendCallInvitation contactId callType
@@ -1301,7 +1297,7 @@ processChatCommand' vr = \case
g <- getGroupInfo db vr user chatId
liftIO $ setGroupUIThemes db user g uiThemes
ok user
_ -> pure $ chatCmdError (Just user) "not supported"
_ -> throwCmdError "not supported"
APIGetNtfToken -> withUser' $ \_ -> crNtfToken <$> withAgent getNtfToken
APIRegisterToken token mode -> withUser $ \_ ->
CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a token mode)
@@ -1309,10 +1305,10 @@ processChatCommand' vr = \case
APICheckToken token -> withUser $ \_ ->
CRNtfTokenStatus <$> withAgent (`checkNtfToken` token)
APIDeleteToken token -> withUser $ \_ -> withAgent (`deleteNtfToken` token) >> ok_
APIGetNtfConns nonce encNtfInfo -> withUser $ \user -> do
APIGetNtfConns nonce encNtfInfo -> withUser $ \_ -> do
ntfInfos <- withAgent $ \a -> getNotificationConns a nonce encNtfInfo
(errs, ntfMsgs) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (getMsgConn db) (L.toList ntfInfos))
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRNtfConns $ catMaybes ntfMsgs
where
getMsgConn :: DB.Connection -> NotificationInfo -> IO (Maybe NtfConn)
@@ -1331,9 +1327,9 @@ processChatCommand' vr = \case
SetUserProtoServers (AProtocolType (p :: SProtocolType p)) srvs -> withUser $ \user@User {userId} -> withServerProtocol p $ do
userServers_ <- liftIO . groupByOperator =<< withFastStore (`getUserServers` user)
case L.nonEmpty userServers_ of
Nothing -> throwChatError $ CECommandError "no servers"
Nothing -> throwCmdError "no servers"
Just userServers -> case srvs of
[] -> throwChatError $ CECommandError "no servers"
[] -> throwCmdError "no servers"
_ -> do
srvs' <- mapM aUserServer srvs
processChatCommand $ APISetUserServers userId $ L.map (updatedServers p srvs') userServers
@@ -1341,7 +1337,7 @@ processChatCommand' vr = \case
aUserServer :: AProtoServerWithAuth -> CM (AUserServer p)
aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of
Just Refl -> pure $ AUS SDBNew $ newUserServer srv
Nothing -> throwChatError $ CECommandError $ "incorrect server protocol: " <> B.unpack (strEncode srv)
Nothing -> throwCmdError $ "incorrect server protocol: " <> B.unpack (strEncode srv)
APITestProtoServer userId srv@(AProtoServerWithAuth _ server) -> withUserId userId $ \user ->
lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a (aUserId user) server)
TestProtoServer srv -> withUser $ \User {userId} ->
@@ -1381,7 +1377,7 @@ processChatCommand' vr = \case
CRUserServers user <$> (liftIO . groupByOperator =<< getUserServers db user)
APISetUserServers userId userServers -> withUserId userId $ \user -> do
errors <- validateAllUsersServers userId $ L.toList userServers
unless (null errors) $ throwChatError (CECommandError $ "user servers validation error(s): " <> show errors)
unless (null errors) $ throwCmdError $ "user servers validation error(s): " <> show errors
uss <- withFastStore $ \db -> do
ts <- liftIO getCurrentTime
mapM (setUserServers db user ts) userServers
@@ -1423,7 +1419,7 @@ processChatCommand' vr = \case
oldTTL = fromMaybe globalTTL oldTTL_
when (newTTL > 0 && (newTTL < oldTTL || oldTTL == 0)) $ do
lift $ setExpireCIFlag user False
expireChat user globalTTL `catchChatError` (toView . CEvtChatError (Just user))
expireChat user globalTTL `catchChatError` eToView
lift $ setChatItemsExpiration user globalTTL ttlCount
ok user
where
@@ -1438,7 +1434,7 @@ processChatCommand' vr = \case
CTGroup | isNothing scope ->
let createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
in expireGroupChatItems user vr globalTTL createdAtCutoff chatId
_ -> throwChatError $ CECommandError "not supported"
_ -> throwCmdError "not supported"
SetChatTTL chatName newTTL -> withUser' $ \user@User {userId} -> do
chatRef <- getChatRef user chatName
processChatCommand $ APISetChatTTL userId chatRef newTTL
@@ -1448,7 +1444,7 @@ processChatCommand' vr = \case
ttl <- case cType of
CTDirect -> withFastStore' (`getDirectChatTTL` chatId)
CTGroup -> withFastStore' (`getGroupChatTTL` chatId)
_ -> throwChatError $ CECommandError "not supported"
_ -> throwCmdError "not supported"
pure $ CRChatItemTTL user ttl
APISetChatItemTTL userId newTTL -> withUserId userId $ \user ->
checkStoreNotChanged $
@@ -1494,15 +1490,15 @@ processChatCommand' vr = \case
liftIO $ updateGroupSettings db user chatId chatSettings
pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId $ chatHasNtfs chatSettings) `catchChatError` (toView . CEvtChatError (Just user))
withAgent (\a -> toggleConnectionNtfs a connId $ chatHasNtfs chatSettings) `catchChatError` eToView
ok user
_ -> pure $ chatCmdError (Just user) "not supported"
_ -> throwCmdError "not supported"
APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do
m <- withFastStore $ \db -> do
liftIO $ updateGroupMemberSettings db user gId gMemberId settings
getGroupMember db vr user gId gMemberId
let ntfOn = showMessages $ memberSettings m
toggleNtf user m ntfOn
toggleNtf m ntfOn
ok user
APIContactInfo contactId -> withUser $ \user@User {userId} -> do
-- [incognito] print user's incognito profile for this contact
@@ -1721,7 +1717,7 @@ processChatCommand' vr = \case
forM_ customUserProfileId $ \profileId ->
deletePCCIncognitoProfile db user profileId
createDirectConnection db newUser agConnId ccLink' ConnNew Nothing subMode initialChatVersion PQSupportOn
deleteAgentConnectionAsync user (aConnId' conn)
deleteAgentConnectionAsync (aConnId' conn)
pure conn'
APIConnectPlan userId cLink -> withUserId userId $ \user ->
uncurry (CRConnectionPlan user) <$> connectPlan user cLink
@@ -1744,7 +1740,7 @@ processChatCommand' vr = \case
-- retrying join after error
pcc <- withFastStore $ \db -> getPendingContactConnection db userId connId
joinPreparedConn (aConnId conn) pcc dm
Just ent -> throwChatError $ CECommandError $ "connection exists: " <> show (connEntityInfo ent)
Just ent -> throwCmdError $ "connection exists: " <> show (connEntityInfo ent)
where
joinNewConn chatV dm = do
connId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup'
@@ -1767,13 +1763,13 @@ processChatCommand' vr = \case
Connect _ Nothing -> throwChatError CEInvalidConnReq
APIConnectContactViaAddress userId incognito contactId -> withUserId userId $ \user -> do
ct@Contact {activeConn, profile = LocalProfile {contactLink}} <- withFastStore $ \db -> getContact db vr user contactId
when (isJust activeConn) $ throwChatError (CECommandError "contact already has connection")
when (isJust activeConn) $ throwCmdError "contact already has connection"
ccLink <- case contactLink of
Just (CLFull cReq) -> pure $ CCLink cReq Nothing
Just (CLShort sLnk) -> do
cReq <- getShortLinkConnReq user sLnk
pure $ CCLink cReq $ Just sLnk
Nothing -> throwChatError (CECommandError "no address in contact profile")
Nothing -> throwCmdError "no address in contact profile"
connectContactViaAddress user incognito ct ccLink
ConnectSimplex incognito -> withUser $ \user -> do
plan <- contactRequestPlan user adminContactReq `catchChatError` const (pure $ CPContactAddress CAPOk)
@@ -1796,7 +1792,7 @@ processChatCommand' vr = \case
APIDeleteMyAddress userId -> withUserId userId $ \user@User {profile = p} -> do
conns <- withFastStore $ \db -> getUserAddressConnections db vr user
withChatLock "deleteMyAddress" $ do
deleteAgentConnectionsAsync user $ map aConnId conns
deleteAgentConnectionsAsync $ map aConnId conns
withFastStore' (`deleteUserAddress` user)
let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing}
r <- updateProfile_ user p' $ withFastStore' $ \db -> setUserProfileContactLink db user Nothing
@@ -1822,7 +1818,7 @@ processChatCommand' vr = \case
processChatCommand $ APISetProfileAddress userId onOff
APIAddressAutoAccept userId autoAccept_ -> withUserId userId $ \user -> do
forM_ autoAccept_ $ \AutoAccept {businessAddress, acceptIncognito} ->
when (businessAddress && acceptIncognito) $ throwChatError $ CECommandError "requests to business address cannot be accepted incognito"
when (businessAddress && acceptIncognito) $ throwCmdError "requests to business address cannot be accepted incognito"
contactLink <- withFastStore (\db -> updateUserAddressAutoAccept db user autoAccept_)
pure $ CRUserContactLinkUpdated user contactLink
AddressAutoAccept autoAccept_ -> withUser $ \User {userId} ->
@@ -1876,8 +1872,8 @@ processChatCommand' vr = \case
| name == "" -> do
folderId <- withFastStore (`getUserNoteFolderId` user)
processChatCommand $ APICreateChatItems folderId [composedMessage Nothing mc]
| otherwise -> throwChatError $ CECommandError "not supported"
_ -> throwChatError $ CECommandError "not supported"
| otherwise -> throwCmdError "not supported"
_ -> throwCmdError "not supported"
SendMemberContactMessage gName mName msg -> withUser $ \user -> do
(gId, mId) <- getGroupAndMemberId user gName mName
m <- withFastStore $ \db -> getGroupMember db vr user gId mId
@@ -1885,7 +1881,7 @@ processChatCommand' vr = \case
case memberContactId m of
Nothing -> do
g <- withFastStore $ \db -> getGroupInfo db vr user gId
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed"
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwCmdError "direct messages not allowed"
toView $ CEvtNoMemberContactCreating user g m
processChatCommand (APICreateMemberContact gId mId) >>= \case
CRNewMemberContact _ ct@Contact {contactId} _ _ -> do
@@ -2036,7 +2032,7 @@ processChatCommand' vr = \case
updateGroupMemberStatus db userId fromMember GSMemInvited
updateGroupMemberStatus db userId membership GSMemInvited
throwError e
updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` (toView . CEvtChatError (Just user))
updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` eToView
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing
Nothing -> throwChatError $ CEContactNotActive ct
APIAcceptMember groupId gmId role -> withUser $ \user@User {userId} -> do
@@ -2073,22 +2069,22 @@ processChatCommand' vr = \case
newMemberStatus = case memberConn m of
Just c | connReady c -> GSMemConnected
_ -> GSMemAnnounced
_ -> throwChatError $ CECommandError "member should be pending approval and invitee, or pending review and not invitee"
_ -> throwCmdError "member should be pending approval and invitee, or pending review and not invitee"
APIMembersRole groupId memberIds newRole -> withUser $ \user ->
withGroupLock "memberRole" groupId . procCmd $ do
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
when (selfSelected gInfo) $ throwChatError $ CECommandError "can't change role for self"
when (selfSelected gInfo) $ throwCmdError "can't change role for self"
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members
when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $
throwChatError $ CECommandError "can't change role of multiple members when admins selected, or new role is admin"
when anyPending $ throwChatError $ CECommandError "can't change role of members pending approval"
throwCmdError "can't change role of multiple members when admins selected, or new role is admin"
when anyPending $ throwCmdError "can't change role of members pending approval"
assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole])
(errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems
(errs2, changed2, acis) <- changeRoleCurrentMems user g currentMems
unless (null acis) $ toView $ CEvtNewChatItems user acis
let errs = errs1 <> errs2
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole} -- same order is not guaranteed
where
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
@@ -2145,11 +2141,11 @@ processChatCommand' vr = \case
APIBlockMembersForAll groupId memberIds blockFlag -> withUser $ \user ->
withGroupLock "blockForAll" groupId . procCmd $ do
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
when (selfSelected gInfo) $ throwChatError $ CECommandError "can't block/unblock self"
when (selfSelected gInfo) $ throwCmdError "can't block/unblock self"
let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members
when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't block/unblock multiple members when admins selected"
when anyPending $ throwChatError $ CECommandError "can't block/unblock members pending approval"
when (length memberIds > 1 && anyAdmin) $ throwCmdError "can't block/unblock multiple members when admins selected"
when anyPending $ throwCmdError "can't block/unblock members pending approval"
assertUserGroupRole gInfo $ max GRModerator maxRole
blockMembers user gInfo blockMems remainingMems
where
@@ -2166,7 +2162,7 @@ processChatCommand' vr = \case
| otherwise = (block, m : remaining, maxRole, anyAdmin, anyPending)
blockMembers :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ChatResponse
blockMembers user gInfo blockMems remainingMems = case L.nonEmpty blockMems of
Nothing -> throwChatError $ CECommandError "no members to block/unblock"
Nothing -> throwCmdError "no members to block/unblock"
Just blockMems' -> do
let mrs = if blockFlag then MRSBlocked else MRSUnrestricted
events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems'
@@ -2178,9 +2174,9 @@ processChatCommand' vr = \case
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
unless (null acis) $ toView $ CEvtNewChatItems user acis
(errs, blocked) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updateGroupMemberBlocked db user gInfo mrs) blockMems)
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
-- TODO not batched - requires agent batch api
forM_ blocked $ \m -> toggleNtf user m (not blockFlag)
forM_ blocked $ \m -> toggleNtf m (not blockFlag)
pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag}
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
@@ -2194,7 +2190,7 @@ processChatCommand' vr = \case
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin) = selectMembers members
memCount = S.size groupMemberIds
when (count /= memCount) $ throwChatError CEGroupMemberNotFound
when (memCount > 1 && anyAdmin) $ throwChatError $ CECommandError "can't remove multiple members when admins selected"
when (memCount > 1 && anyAdmin) $ throwCmdError "can't remove multiple members when admins selected"
assertUserGroupRole gInfo $ max GRAdmin maxRole
(errs1, deleted1) <- deleteInvitedMems user invitedMems
let recipients = filter memberCurrent members
@@ -2208,7 +2204,7 @@ processChatCommand' vr = \case
errs = errs1 <> errs2 <> errs3 <> errs4
deleted = deleted1 <> deleted2 <> deleted3 <> deleted4
unless (null acis) $ toView $ CEvtNewChatItems user acis
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
when withMessages $ deleteMessages user gInfo deleted
pure $ CRUserDeletedMembers user gInfo deleted withMessages -- same order is not guaranteed
where
@@ -2367,11 +2363,11 @@ processChatCommand' vr = \case
APICreateMemberContact gId gMemberId -> withUser $ \user -> do
(g, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId
assertUserGroupRole g GRAuthor
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed"
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwCmdError "direct messages not allowed"
case memberConn m of
Just mConn@Connection {peerChatVRange} -> do
unless (maxVersion peerChatVRange >= groupDirectInvVersion) $ throwChatError CEPeerChatVRangeIncompatible
when (isJust $ memberContactId m) $ throwChatError $ CECommandError "member contact already exists"
when (isJust $ memberContactId m) $ throwCmdError "member contact already exists"
subMode <- chatReadVar subscriptionMode
-- TODO PQ should negotitate contact connection with PQSupportOn?
(connId, CCLink cReq _) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing Nothing IKPQOff subMode
@@ -2383,7 +2379,7 @@ processChatCommand' vr = \case
_ -> throwChatError CEGroupMemberNotActive
APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do
(g@GroupInfo {groupId}, m, ct, cReq) <- withFastStore $ \db -> getMemberContact db vr user contactId
when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent"
when (contactGrpInvSent ct) $ throwCmdError "x.grp.direct.inv already sent"
case memberConn m of
Just mConn -> do
let msg = XGrpDirectInv cReq msgContent_
@@ -2421,7 +2417,7 @@ processChatCommand' vr = \case
LastChats count_ -> withUser' $ \user -> do
let count = fromMaybe 5000 count_
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters)
unless (null errs) $ toView $ CEvtChatErrors (Just user) (map ChatErrorStore errs)
unless (null errs) $ toView $ CEvtChatErrors (map ChatErrorStore errs)
pure $ CRChats previews
LastMessages (Just chatName) count search -> withUser $ \user -> do
chatRef <- getChatRef user chatName
@@ -2467,7 +2463,7 @@ processChatCommand' vr = \case
processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
SendFileDescription _chatName _f -> throwCmdError "TODO"
-- TODO to use priority transactions we need a parameter that differentiates manual and automatic acceptance
ReceiveFile fileId userApprovedRelays encrypted_ rcvInline_ filePath_ -> withUser $ \_ ->
withFileLock "receiveFile" fileId . procCmd $ do
@@ -2490,7 +2486,7 @@ processChatCommand' vr = \case
throwChatError $ CEFileCancel fileId "file transfer is complete"
| otherwise -> do
fileAgentConnIds <- cancelSndFile user ftm fts True
deleteAgentConnectionsAsync user fileAgentConnIds
deleteAgentConnectionsAsync fileAgentConnIds
cref_ <- withFastStore' $ \db -> lookupChatRefByFileId db user fileId
aci_ <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId
case (cref_, aci_) of
@@ -2514,7 +2510,7 @@ processChatCommand' vr = \case
| rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete"
| otherwise -> case xftpRcvFile of
Nothing -> do
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user)
cancelRcvFileTransfer user ftr >>= mapM_ deleteAgentConnectionAsync
ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr
Just XFTPRcvFile {agentRcvFileId} -> do
@@ -2532,7 +2528,7 @@ processChatCommand' vr = \case
pure $ CRFileTransferStatus user fileStatus
Just ci@(AChatItem _ _ _ ChatItem {file}) -> case file of
Just CIFile {fileProtocol = FPLocal} ->
throwChatError $ CECommandError "not supported for local files"
throwCmdError "not supported for local files"
Just CIFile {fileProtocol = FPXFTP} ->
pure $ CRFileTransferStatusXFTP user ci
_ -> do
@@ -2667,8 +2663,9 @@ processChatCommand' vr = \case
GetAgentSubsDetails -> lift $ CRAgentSubsDetails <$> withAgent' getAgentSubscriptions
GetAgentQueuesInfo -> lift $ CRAgentQueuesInfo <$> withAgent' getAgentQueuesInfo
-- CustomChatCommand is unsupported, it can be processed in preCmdHook
-- in a modified CLI app or core - the hook should return Either ChatResponse ChatCommand
CustomChatCommand _cmd -> withUser $ \user -> pure $ chatCmdError (Just user) "not supported"
-- in a modified CLI app or core - the hook should return Either (Either ChatError ChatResponse) ChatCommand,
-- where Left means command result, and Right – some other command to be processed by this function.
CustomChatCommand _cmd -> withUser $ \_ -> throwCmdError "not supported"
where
procCmd :: CM ChatResponse -> CM ChatResponse
procCmd = id
@@ -2682,8 +2679,8 @@ processChatCommand' vr = \case
CTGroup -> withFastStore $ \db -> getGroupIdByName db user name
CTLocal
| name == "" -> withFastStore (`getUserNoteFolderId` user)
| otherwise -> throwChatError $ CECommandError "not supported"
_ -> throwChatError $ CECommandError "not supported"
| otherwise -> throwCmdError "not supported"
_ -> throwCmdError "not supported"
pure $ ChatRef cType chatId Nothing
getChatRefAndMentions :: User -> ChatName -> Text -> CM (ChatRef, Map MemberName GroupMemberId)
getChatRefAndMentions user cName msg = do
@@ -2726,13 +2723,13 @@ processChatCommand' vr = \case
CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg
CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg
CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText db user cId SMDSnd msg
_ -> throwChatError $ CECommandError "not supported"
_ -> throwCmdError "not supported"
getChatItemIdByText :: User -> ChatRef -> Text -> CM Int64
getChatItemIdByText user (ChatRef cType cId _scope) msg = case cType of
CTDirect -> withFastStore $ \db -> getDirectChatItemIdByText' db user cId msg
CTGroup -> withFastStore $ \db -> getGroupChatItemIdByText' db user cId msg
CTLocal -> withFastStore $ \db -> getLocalChatItemIdByText' db user cId msg
_ -> throwChatError $ CECommandError "not supported"
_ -> throwCmdError "not supported"
connectViaContact :: User -> IncognitoEnabled -> CreatedLinkContact -> CM ChatResponse
connectViaContact user@User {userId} incognito (CCLink cReq@(CRContactUri ConnReqUriData {crClientData}) sLnk) = withInvitationLock "connectViaContact" (strEncode cReq) $ do
let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
@@ -2835,7 +2832,7 @@ processChatCommand' vr = \case
let idsEvts = L.map ctSndEvent changedCts
msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts
(errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
let changedCts' = filter (\ChangedProfileContact {ct, ct'} -> directOrUsed ct' && mergedPreferences ct' /= mergedPreferences ct) cts
lift $ createContactsSndFeatureItems user' changedCts'
pure
@@ -2875,7 +2872,7 @@ processChatCommand' vr = \case
mergedProfile' = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') False
when (mergedProfile' /= mergedProfile) $
withContactLock "updateProfile" (contactId' ct) $ do
void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchChatError` (toView . CEvtChatError (Just user))
void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchChatError` eToView
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
pure $ CRContactPrefsUpdated user ct ct'
runUpdateGroupProfile :: User -> Group -> GroupProfile -> CM ChatResponse
@@ -3079,7 +3076,7 @@ processChatCommand' vr = \case
deleteCIFiles user filesInfo
withAgent (\a -> deleteUser a (aUserId user) delSMPQueues)
`catchChatError` \case
e@(ChatErrorAgent NO_USER _) -> toView $ CEvtChatError (Just user) e
e@(ChatErrorAgent NO_USER _) -> eToView e
e -> throwError e
withFastStore' (`deleteUserRecord` user)
when (activeUser user) $ chatWriteVar currentUser Nothing
@@ -3096,7 +3093,7 @@ processChatCommand' vr = \case
gId <- getGroupIdByName db user name
GroupInfo {chatSettings} <- getGroupInfo db vr user gId
pure (gId, chatSettings)
_ -> throwChatError $ CECommandError "not supported"
_ -> throwCmdError "not supported"
processChatCommand $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings
connectPlan :: User -> AConnectionLink -> CM (ACreatedConnLink, ConnectionPlan)
connectPlan user (ACL SCMInvitation cLink) = case cLink of
@@ -3124,7 +3121,7 @@ processChatCommand' vr = \case
withFastStore' (\db -> getGroupInfoViaUserShortLink db vr user l') >>= \case
Just (cReq, g) -> pure (ACCL SCMContact $ CCLink cReq (Just l'), CPGroupLink (GLPOwnLink g))
Nothing -> getShortLinkConnReq user l' >>= (`contactReqAndPlan` Just l')
CCTChannel -> throwChatError $ CECommandError "channel links are not supported in this version"
CCTChannel -> throwCmdError "channel links are not supported in this version"
where
contactReqAndPlan cReq sLnk_ = do
plan <- contactRequestPlan user cReq `catchChatError` (pure . CPError)
@@ -3132,7 +3129,7 @@ processChatCommand' vr = \case
connectWithPlan :: User -> IncognitoEnabled -> ACreatedConnLink -> ConnectionPlan -> CM ChatResponse
connectWithPlan user@User {userId} incognito ccLink plan
| connectionPlanProceed plan = do
case plan of CPError e -> toView $ CEvtChatError (Just user) e; _ -> pure ()
case plan of CPError e -> eToView e; _ -> pure ()
case plan of
CPContactAddress (CAPContactViaAddress Contact {contactId}) ->
processChatCommand $ APIConnectContactViaAddress userId incognito contactId
@@ -3163,7 +3160,7 @@ processChatCommand' vr = \case
| otherwise -> case ct_ of
Just ct -> pure $ CPInvitationLink (ILPKnown ct)
Nothing -> throwChatError $ CEInternalError "ready RcvDirectMsgConnection connection should have associated contact"
_ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
_ -> throwCmdError "found connection entity is not RcvDirectMsgConnection"
contactRequestPlan :: User -> ConnReqContact -> CM ConnectionPlan
contactRequestPlan user (CRContactUri crData) = do
let ConnReqUriData {crClientData} = crData
@@ -3186,7 +3183,7 @@ processChatCommand' vr = \case
| contactDeleted ct -> pure $ CPContactAddress CAPOk
| otherwise -> pure $ CPContactAddress (CAPKnown ct)
Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection"
Just _ -> throwCmdError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection"
-- group link
Just _ ->
withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case
@@ -3200,7 +3197,7 @@ processChatCommand' vr = \case
(Nothing, Just (RcvDirectMsgConnection _ (Just ct)))
| not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnectingProhibit gInfo_)
| otherwise -> pure $ CPGroupLink GLPOk
(Nothing, Just _) -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
(Nothing, Just _) -> throwCmdError "found connection entity is not RcvDirectMsgConnection"
(Just gInfo, _) -> groupPlan gInfo
where
groupPlan gInfo@GroupInfo {membership}
@@ -3253,14 +3250,14 @@ processChatCommand' vr = \case
_ -> pure () -- prohibited
assertAllowedContent :: MsgContent -> CM ()
assertAllowedContent = \case
MCReport {} -> throwChatError $ CECommandError "sending reports via this API is not supported"
MCReport {} -> throwCmdError "sending reports via this API is not supported"
_ -> pure ()
assertAllowedContent' :: ComposedMessage -> CM ()
assertAllowedContent' ComposedMessage {msgContent} = assertAllowedContent msgContent
assertNoMentions :: ComposedMessage -> CM ()
assertNoMentions ComposedMessage {mentions}
| null mentions = pure ()
| otherwise = throwChatError $ CECommandError "mentions are not supported in this chat"
| otherwise = throwCmdError "mentions are not supported in this chat"
sendContactContentMessages :: User -> ContactId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendContactContentMessages user contactId live itemTTL cmrs = do
assertMultiSendable live cmrs
@@ -3272,7 +3269,7 @@ processChatCommand' vr = \case
assertVoiceAllowed :: Contact -> CM ()
assertVoiceAllowed ct =
when (not (featureAllowed SCFVoice forUser ct) && any (\(ComposedMessage {msgContent}, _, _, _) -> isVoice msgContent) cmrs) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFVoice))
throwCmdError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)
processComposedMessages :: Contact -> CM ChatResponse
processComposedMessages ct = do
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers
@@ -3282,7 +3279,7 @@ processChatCommand' vr = \case
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch"
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live
processSendErrs user r
processSendErrs r
forM_ (timed_ >>= timedDeleteAt') $ \deleteAt ->
forM_ cis $ \ci ->
startProximateTimedItemThread user (ChatRef CTDirect contactId Nothing, chatItemId' ci) deleteAt
@@ -3341,7 +3338,7 @@ processChatCommand' vr = \case
assertGroupContentAllowed :: CM ()
assertGroupContentAllowed =
case findProhibited (L.toList cmrs) of
Just f -> throwChatError (CECommandError $ "feature not allowed " <> T.unpack (groupFeatureNameText f))
Just f -> throwCmdError $ "feature not allowed " <> T.unpack (groupFeatureNameText f)
Nothing -> pure ()
where
findProhibited :: [ComposedMessageReq] -> Maybe GroupFeature
@@ -3360,7 +3357,7 @@ processChatCommand' vr = \case
when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
createMemberSndStatuses cis_ msgs_ gsr
let r@(_, cis) = partitionEithers cis_
processSendErrs user r
processSendErrs r
forM_ (timed_ >>= timedDeleteAt') $ \deleteAt ->
forM_ cis $ \ci ->
startProximateTimedItemThread user (ChatRef CTGroup groupId scope, chatItemId' ci) deleteAt
@@ -3424,14 +3421,14 @@ processChatCommand' vr = \case
-- UI doesn't allow composing with multiple quotes, so api prohibits it as well, and doesn't bother
-- batching retrieval of quoted messages (prepareMsgs).
when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _, _, _) -> isJust quotedItemId) cmrs) > 1) $
throwChatError (CECommandError "invalid multi send: live and more than one quote not supported")
throwCmdError "invalid multi send: live and more than one quote not supported"
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd)
xftpSndFileTransfer user file fileSize n contactOrGroup = do
(fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup
case contactOrGroup of
CGContact Contact {activeConn} -> forM_ activeConn $ \conn ->
withFastStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr
CGGroup _ ms -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CEvtChatError (Just user))
CGGroup _ ms -> forM_ ms $ \m -> saveMemberFD m `catchChatError` eToView
where
-- we are not sending files to pending members, same as with inline files
saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} =
@@ -3450,23 +3447,23 @@ processChatCommand' vr = \case
zipWith4 $ \(ComposedMessage {msgContent}, itemForwarded, ts, mm) f q -> \case
Right msg -> Right $ NewSndChatItemData msg (CISndMsgContent msgContent) ts mm f q itemForwarded
Left e -> Left e -- step over original error
processSendErrs :: User -> ([ChatError], [ChatItem c d]) -> CM ()
processSendErrs user = \case
processSendErrs :: ([ChatError], [ChatItem c d]) -> CM ()
processSendErrs = \case
-- no errors
([], _) -> pure ()
-- at least one item is successfully created
(errs, _ci : _) -> toView $ CEvtChatErrors (Just user) errs
(errs, _ci : _) -> toView $ CEvtChatErrors errs
-- single error
([err], []) -> throwError err
-- multiple errors
(errs@(err : _), []) -> do
toView $ CEvtChatErrors (Just user) errs
toView $ CEvtChatErrors errs
throwError err
getCommandDirectChatItems :: User -> Int64 -> NonEmpty ChatItemId -> CM (Contact, [CChatItem 'CTDirect])
getCommandDirectChatItems user ctId itemIds = do
ct <- withFastStore $ \db -> getContact db vr user ctId
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds))
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure (ct, items)
where
getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect))
@@ -3475,7 +3472,7 @@ processChatCommand' vr = \case
getCommandGroupChatItems user gId itemIds = do
gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db gInfo) (L.toList itemIds))
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure (gInfo, items)
where
getGroupCI :: DB.Connection -> GroupInfo -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup))
@@ -3484,7 +3481,7 @@ processChatCommand' vr = \case
getCommandLocalChatItems user nfId itemIds = do
nf <- withStore $ \db -> getNoteFolder db user nfId
(errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds))
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure (nf, items)
where
getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal))
@@ -3507,7 +3504,7 @@ processChatCommand' vr = \case
assertNoQuotes :: CM ()
assertNoQuotes =
when (any (\(ComposedMessage {quotedItemId}, _, _, _) -> isJust quotedItemId) cmrs) $
throwChatError (CECommandError "createNoteFolderContentItems: quotes not supported")
throwCmdError "createNoteFolderContentItems: quotes not supported"
createLocalFiles :: NoteFolder -> UTCTime -> CM (NonEmpty (Maybe (CIFile 'MDSnd)))
createLocalFiles nf createdAt =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) ->
@@ -3532,7 +3529,7 @@ processChatCommand' vr = \case
withSendRef chatRef a = case chatRef of
ChatRef CTDirect cId _ -> a $ SRDirect cId
ChatRef CTGroup gId scope -> a $ SRGroup gId scope
_ -> throwChatError $ CECommandError "not supported"
_ -> throwCmdError "not supported"
protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
protocolServers p (operators, smpServers, xftpServers) = case p of
@@ -3609,7 +3606,7 @@ startExpireCIThread user@User {userId} = do
liftIO $ threadDelay' delay
interval <- asks $ ciExpirationInterval . config
forever $ do
flip catchChatError' (toView' . CEvtChatError (Just user)) $ do
flip catchChatError' (eToView') $ do
expireFlags <- asks expireCIFlags
atomically $ TM.lookup userId expireFlags >>= \b -> unless (b == Just True) retry
lift waitChatStartedAndActivated
@@ -3641,7 +3638,7 @@ agentSubscriber = do
q <- asks $ subQ . smpAgent
forever (atomically (readTBQueue q) >>= process)
`E.catchAny` \e -> do
toView' $ CEvtChatError Nothing $ ChatErrorAgent (CRITICAL True $ "Message reception stopped: " <> show e) Nothing
eToView' $ ChatErrorAgent (CRITICAL True $ "Message reception stopped: " <> show e) Nothing
E.throwIO e
where
process :: (ACorrId, AEntityId, AEvt) -> CM' ()
@@ -3651,7 +3648,7 @@ agentSubscriber = do
SAERcvFile -> processAgentMsgRcvFile corrId entId msg
SAESndFile -> processAgentMsgSndFile corrId entId msg
where
run action = action `catchChatError'` (toView' . CEvtChatError Nothing)
run action = action `catchChatError'` (eToView')
type AgentBatchSubscribe = AgentClient -> [ConnId] -> ExceptT AgentErrorType IO (Map ConnId (Either AgentErrorType ()))
@@ -3812,7 +3809,7 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> CM ()
pendingConnSubsToView rs = toViewTE . TEPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs
withStore_ :: (DB.Connection -> User -> IO [a]) -> CM [a]
withStore_ a = withStore' (`a` user) `catchChatError` \e -> toView (CEvtChatError (Just user) e) $> []
withStore_ a = withStore' (`a` user) `catchChatError` \e -> eToView e $> []
filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)]
filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_)
resultsFor :: Map ConnId (Either AgentErrorType ()) -> Map ConnId a -> [(a, Maybe ChatError)]
@@ -3834,28 +3831,28 @@ cleanupManager = do
liftIO $ threadDelay' initialDelay
stepDelay <- asks (cleanupManagerStepDelay . config)
forever $ do
flip catchChatError (toView . CEvtChatError Nothing) $ do
flip catchChatError eToView $ do
lift waitChatStartedAndActivated
users <- withStore' getUsers
let (us, us') = partition activeUser users
forM_ us $ cleanupUser interval stepDelay
forM_ us' $ cleanupUser interval stepDelay
cleanupMessages `catchChatError` (toView . CEvtChatError Nothing)
cleanupMessages `catchChatError` eToView
-- TODO possibly, also cleanup async commands
cleanupProbes `catchChatError` (toView . CEvtChatError Nothing)
cleanupProbes `catchChatError` eToView
liftIO $ threadDelay' $ diffToMicroseconds interval
where
runWithoutInitialDelay cleanupInterval = flip catchChatError (toView . CEvtChatError Nothing) $ do
runWithoutInitialDelay cleanupInterval = flip catchChatError eToView $ do
lift waitChatStartedAndActivated
users <- withStore' getUsers
let (us, us') = partition activeUser users
forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CEvtChatError (Just u))
forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` (toView . CEvtChatError (Just u))
forM_ us $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` eToView
forM_ us' $ \u -> cleanupTimedItems cleanupInterval u `catchChatError` eToView
cleanupUser cleanupInterval stepDelay user = do
cleanupTimedItems cleanupInterval user `catchChatError` (toView . CEvtChatError (Just user))
cleanupTimedItems cleanupInterval user `catchChatError` eToView
liftIO $ threadDelay' stepDelay
-- TODO remove in future versions: legacy step - contacts are no longer marked as deleted
cleanupDeletedContacts user `catchChatError` (toView . CEvtChatError (Just user))
cleanupDeletedContacts user `catchChatError` eToView
liftIO $ threadDelay' stepDelay
cleanupTimedItems cleanupInterval user = do
ts <- liftIO getCurrentTime
@@ -3867,7 +3864,7 @@ cleanupManager = do
contacts <- withStore' $ \db -> getDeletedContacts db vr user
forM_ contacts $ \ct ->
withStore (\db -> deleteContactWithoutGroups db user ct)
`catchChatError` (toView . CEvtChatError (Just user))
`catchChatError` eToView
cleanupMessages = do
ts <- liftIO getCurrentTime
let cutoffTs = addUTCTime (-(30 * nominalDay)) ts
@@ -3893,7 +3890,7 @@ expireChatItems user@User {userId} globalTTL sync = do
loop :: [Int64] -> (Int64 -> CM ()) -> CM ()
loop [] _ = pure ()
loop (a : as) process = continue $ do
process a `catchChatError` (toView . CEvtChatError (Just user))
process a `catchChatError` eToView
loop as process
continue :: CM () -> CM ()
continue a =
src/Simplex/Chat/Library/Internal.hs
+47 -47
View File
@@ -184,11 +184,11 @@ callTimed ct aciContent =
aciContentCallStatus (ACIContent _ (CIRcvCall st _)) = Just st
aciContentCallStatus _ = Nothing
toggleNtf :: User -> GroupMember -> Bool -> CM ()
toggleNtf user m ntfOn =
toggleNtf :: GroupMember -> Bool -> CM ()
toggleNtf m ntfOn =
when (memberActive m) $
forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CEvtChatError (Just user))
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` eToView
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
prepareGroupMsg db user g@GroupInfo {membership} msgScope mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
@@ -388,8 +388,8 @@ cancelFilesInProgress user filesInfo = do
lift $ agentXFTPDeleteRcvFiles xrfIds
let smpSFConnIds = concatMap (\(ft, sfts) -> mapMaybe (smpSndFileConnId ft) sfts) sfs
smpRFConnIds = mapMaybe smpRcvFileConnId rfs
deleteAgentConnectionsAsync user smpSFConnIds
deleteAgentConnectionsAsync user smpRFConnIds
deleteAgentConnectionsAsync smpSFConnIds
deleteAgentConnectionsAsync smpRFConnIds
where
fileEnded CIFileInfo {fileStatus} = case fileStatus of
Just (AFS _ status) -> ciFileEnded status
@@ -446,7 +446,7 @@ deleteDirectCIs user ct items = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
deleteCIFiles user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure deletions
where
deleteItem db (CChatItem md ci) = do
@@ -458,7 +458,7 @@ deleteGroupCIs user gInfo chatScopeInfo items byGroupMember_ deletedTs = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
deleteCIFiles user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure deletions
where
deleteItem :: DB.Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion
@@ -491,7 +491,7 @@ deleteLocalCIs user nf items byUser timed = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
deleteFilesLocally ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRChatItemsDeleted user deletions byUser timed
where
deleteItem db (CChatItem md ci) = do
@@ -510,7 +510,7 @@ markDirectCIsDeleted user ct items deletedTs = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
cancelFilesInProgress user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items)
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure deletions
where
markDeleted db (CChatItem md ci) = do
@@ -522,7 +522,7 @@ markGroupCIsDeleted user gInfo chatScopeInfo items byGroupMember_ deletedTs = do
let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items
cancelFilesInProgress user ciFilesInfo
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items)
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure deletions
-- pure $ CRChatItemsDeleted user deletions byUser False
where
@@ -1026,7 +1026,7 @@ introduceMember vr user gInfo@GroupInfo {groupId} m@GroupMember {activeConn = Ju
forM_ (L.nonEmpty events) $ \events' ->
sendGroupMemberMessages user conn events' groupId
else forM_ shuffledIntros $ \intro ->
processIntro intro `catchChatError` (toView . CEvtChatError (Just user))
processIntro intro `catchChatError` eToView
memberIntro :: GroupMember -> ChatMsgEvent 'Json
memberIntro reMember =
let mInfo = memberInfo reMember
@@ -1052,7 +1052,7 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn
(errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100)
(errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items
let errors = map ChatErrorStore errs <> errs'
unless (null errors) $ toView $ CEvtChatErrors (Just user) errors
unless (null errors) $ toView $ CEvtChatErrors errors
let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_
forM_ (L.nonEmpty events') $ \events'' ->
sendGroupMemberMessages user conn events'' groupId
@@ -1154,7 +1154,7 @@ deleteGroupLinkIfExists user gInfo = do
deleteGroupLink_ :: User -> GroupInfo -> Connection -> CM ()
deleteGroupLink_ user gInfo conn = do
deleteAgentConnectionAsync user $ aConnId conn
deleteAgentConnectionAsync $ aConnId conn
withStore' $ \db -> deleteGroupLink db user gInfo
startProximateTimedItemThread :: User -> (ChatRef, ChatItemId) -> UTCTime -> CM ()
@@ -1196,7 +1196,7 @@ deleteTimedItem user (ChatRef cType chatId scope, itemId) deleteAt = do
chatScopeInfo <- mapM (getChatScopeInfo vr user) scope
deletions <- deleteGroupCIs user gInfo chatScopeInfo [ci] Nothing deletedTs
toView $ CEvtChatItemsDeleted user deletions True True
_ -> toView . CEvtChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
_ -> eToView $ ChatError $ CEInternalError "bad deleteTimedItem cType"
startUpdatedTimedItemThread :: User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM ()
startUpdatedTimedItemThread user chatRef ci ci' =
@@ -1420,7 +1420,7 @@ sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentCo
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
toView $ CEvtSndFileComplete user ci ft
lift $ closeFileHandle fileId sndFiles
deleteAgentConnectionAsync user acId
deleteAgentConnectionAsync acId
sendFileChunkNo :: SndFileTransfer -> Integer -> CM ()
sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do
@@ -1468,7 +1468,7 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs, fileInvitati
removeFile fsFilePath `catchChatError` \_ -> pure ()
renameFile tmpFile fsFilePath
Left e -> do
toView $ CEvtChatError Nothing e
eToView e
removeFile tmpFile `catchChatError` \_ -> pure ()
withStore' (`removeFileCryptoArgs` fileId)
where
@@ -1493,7 +1493,7 @@ isFileActive fileId files = do
cancelRcvFileTransfer :: User -> RcvFileTransfer -> CM (Maybe ConnId)
cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInline} =
cancel' `catchChatError` (\e -> toView (CEvtChatError (Just user) e) $> fileConnId)
cancel' `catchChatError` (\e -> eToView e $> fileConnId)
where
cancel' = do
lift $ closeFileHandle fileId rcvFiles
@@ -1511,13 +1511,13 @@ cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, xftpRcvFile, rcvFileInlin
cancelSndFile :: User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> CM [ConnId]
cancelSndFile user FileTransferMeta {fileId, xftpSndFile} fts sendCancel = do
withStore' (\db -> updateFileCancelled db user fileId CIFSSndCancelled)
`catchChatError` (toView . CEvtChatError (Just user))
`catchChatError` eToView
case xftpSndFile of
Nothing ->
catMaybes <$> forM fts (\ft -> cancelSndFileTransfer user ft sendCancel)
Just xsf -> do
forM_ fts (\ft -> cancelSndFileTransfer user ft False)
lift (agentXFTPDeleteSndFileRemote user xsf fileId) `catchChatError` (toView . CEvtChatError (Just user))
lift (agentXFTPDeleteSndFileRemote user xsf fileId) `catchChatError` eToView
pure []
-- TODO v6.0 remove
@@ -1525,7 +1525,7 @@ cancelSndFileTransfer :: User -> SndFileTransfer -> Bool -> CM (Maybe ConnId)
cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, agentConnId = AgentConnId acId, fileStatus, fileInline} sendCancel =
if fileStatus == FSCancelled || fileStatus == FSComplete
then pure Nothing
else cancel' `catchChatError` (\e -> toView (CEvtChatError (Just user) e) $> fileConnId)
else cancel' `catchChatError` (\e -> eToView e $> fileConnId)
where
cancel' = do
withStore' $ \db -> do
@@ -1552,16 +1552,16 @@ deleteMembersConnections user members = deleteMembersConnections' user members F
deleteMembersConnections' :: User -> [GroupMember] -> Bool -> CM ()
deleteMembersConnections' user members waitDelivery = do
let memberConns = mapMaybe (\GroupMember {activeConn} -> activeConn) members
deleteAgentConnectionsAsync' user (map aConnId memberConns) waitDelivery
deleteAgentConnectionsAsync' (map aConnId memberConns) waitDelivery
lift . void . withStoreBatch' $ \db -> map (\Connection {connId} -> deleteConnectionRecord db user connId) memberConns
deleteMemberConnection :: User -> GroupMember -> CM ()
deleteMemberConnection user mem = deleteMemberConnection' user mem False
deleteMemberConnection :: GroupMember -> CM ()
deleteMemberConnection mem = deleteMemberConnection' mem False
deleteMemberConnection' :: User -> GroupMember -> Bool -> CM ()
deleteMemberConnection' user GroupMember {activeConn} waitDelivery = do
deleteMemberConnection' :: GroupMember -> Bool -> CM ()
deleteMemberConnection' GroupMember {activeConn} waitDelivery = do
forM_ activeConn $ \conn -> do
deleteAgentConnectionAsync' user (aConnId conn) waitDelivery
deleteAgentConnectionAsync' (aConnId conn) waitDelivery
withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
deleteOrUpdateMemberRecord :: User -> GroupMember -> CM ()
@@ -1646,7 +1646,7 @@ sendGroupMemberMessages user conn events groupId = do
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
let idsEvts = L.map (GroupId groupId,) events
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
forM_ (L.nonEmpty msgs) $ \msgs' ->
batchSendConnMessages user conn MsgFlags {notification = True} msgs'
@@ -1775,7 +1775,7 @@ sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope
sendGroupMessages user gInfo scope members events = do
-- TODO [knocking] send current profile to pending member after approval?
when shouldSendProfileUpdate $
sendProfileUpdate `catchChatError` (toView . CEvtChatError (Just user))
sendProfileUpdate `catchChatError` eToView
sendGroupMessages_ user gInfo members events
where
User {profile = p, userMemberProfileUpdatedAt} = user
@@ -1929,10 +1929,10 @@ memberSendAction gInfo events members m@GroupMember {memberRole, memberStatus} =
XGrpMsgForward {} -> True
_ -> False
sendGroupMemberMessage :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> ChatMsgEvent e -> Maybe Int64 -> CM () -> CM ()
sendGroupMemberMessage user gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} chatMsgEvent introId_ postDeliver = do
sendGroupMemberMessage :: MsgEncodingI e => GroupInfo -> GroupMember -> ChatMsgEvent e -> Maybe Int64 -> CM () -> CM ()
sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} chatMsgEvent introId_ postDeliver = do
msg <- createSndMessage chatMsgEvent (GroupId groupId)
messageMember msg `catchChatError` (toView . CEvtChatError (Just user))
messageMember msg `catchChatError` eToView
where
messageMember :: SndMessage -> CM ()
messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo (chatMsgEvent :| []) [m] m) $ \case
@@ -2121,20 +2121,22 @@ agentAcceptContactAsync user enableNtfs invId msg subMode pqSup chatV = do
connId <- withAgent $ \a -> acceptContactAsync a (aCorrId cmdId) enableNtfs invId dm pqSup subMode
pure (cmdId, connId)
deleteAgentConnectionAsync :: User -> ConnId -> CM ()
deleteAgentConnectionAsync user acId = deleteAgentConnectionAsync' user acId False
deleteAgentConnectionAsync :: ConnId -> CM ()
deleteAgentConnectionAsync acId = deleteAgentConnectionAsync' acId False
{-# INLINE deleteAgentConnectionAsync #-}
deleteAgentConnectionAsync' :: User -> ConnId -> Bool -> CM ()
deleteAgentConnectionAsync' user acId waitDelivery = do
withAgent (\a -> deleteConnectionAsync a waitDelivery acId) `catchChatError` (toView . CEvtChatError (Just user))
deleteAgentConnectionAsync' :: ConnId -> Bool -> CM ()
deleteAgentConnectionAsync' acId waitDelivery = do
withAgent (\a -> deleteConnectionAsync a waitDelivery acId) `catchChatError` eToView
deleteAgentConnectionsAsync :: User -> [ConnId] -> CM ()
deleteAgentConnectionsAsync user acIds = deleteAgentConnectionsAsync' user acIds False
deleteAgentConnectionsAsync :: [ConnId] -> CM ()
deleteAgentConnectionsAsync acIds = deleteAgentConnectionsAsync' acIds False
{-# INLINE deleteAgentConnectionsAsync #-}
deleteAgentConnectionsAsync' :: User -> [ConnId] -> Bool -> CM ()
deleteAgentConnectionsAsync' _ [] _ = pure ()
deleteAgentConnectionsAsync' user acIds waitDelivery = do
withAgent (\a -> deleteConnectionsAsync a waitDelivery acIds) `catchChatError` (toView . CEvtChatError (Just user))
deleteAgentConnectionsAsync' :: [ConnId] -> Bool -> CM ()
deleteAgentConnectionsAsync' [] _ = pure ()
deleteAgentConnectionsAsync' acIds waitDelivery = do
withAgent (\a -> deleteConnectionsAsync a waitDelivery acIds) `catchChatError` eToView
agentXFTPDeleteRcvFile :: RcvFileId -> FileTransferId -> CM ()
agentXFTPDeleteRcvFile aFileId fileId = do
@@ -2235,7 +2237,7 @@ createContactsFeatureItems ::
createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
let dirsCIContents = map contactChangedFeatures cts
(errs, acis) <- partitionEithers <$> createInternalItemsForChats user Nothing dirsCIContents
unless (null errs) $ toView' $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView' $ CEvtChatErrors errs
toView' $ CEvtNewChatItems user acis
where
contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, [CIContent d])
@@ -2331,7 +2333,7 @@ createLocalChatItems ::
createLocalChatItems user cd itemsData createdAt = do
withStore' $ \db -> updateChatTsStats db user cd createdAt Nothing
(errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) $ L.toList itemsData)
unless (null errs) $ toView $ CEvtChatErrors (Just user) errs
unless (null errs) $ toView $ CEvtChatErrors errs
pure items
where
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
@@ -2344,9 +2346,7 @@ withUser' :: (User -> CM ChatResponse) -> CM ChatResponse
withUser' action =
asks currentUser
>>= readTVarIO
>>= maybe (throwChatError CENoActiveUser) run
where
run u = action u `catchChatError` (pure . CRChatCmdError (Just u))
>>= maybe (throwChatError CENoActiveUser) action
withUser :: (User -> CM ChatResponse) -> CM ChatResponse
withUser action = withUser' $ \user ->
src/Simplex/Chat/Library/Subscriber.hs
+41 -41
View File
@@ -96,14 +96,14 @@ processAgentMessage _ _ (DEL_RCVQS delQs) =
processAgentMessage _ _ (DEL_CONNS connIds) =
toView $ CEvtAgentConnsDeleted $ L.map AgentConnId connIds
processAgentMessage _ "" (ERR e) =
toView $ CEvtChatError Nothing $ ChatErrorAgent e Nothing
eToView $ ChatErrorAgent e Nothing
processAgentMessage corrId connId msg = do
lockEntity <- critical (withStore (`getChatLockEntity` AgentConnId connId))
withEntityLock "processAgentMessage" lockEntity $ do
vr <- chatVersionRange
-- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
critical (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case
Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CEvtChatError (Just user))
Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` eToView
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
@@ -144,7 +144,7 @@ processAgentMessageNoConn = \case
errsEvent cErrs = do
vr <- chatVersionRange
errs <- lift $ rights <$> withStoreBatch' (\db -> map (getChatErr vr db) cErrs)
toView $ CEvtChatErrors Nothing errs
toView $ CEvtChatErrors errs
where
getChatErr :: VersionRangeChat -> DB.Connection -> (ConnId, AgentErrorType) -> IO ChatError
getChatErr vr db (connId, err) =
@@ -156,7 +156,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
(cRef_, fileId) <- withStore (`getXFTPSndFileDBIds` AgentSndFileId aFileId)
withEntityLock_ cRef_ . withFileLock "processAgentMsgSndFile" fileId $
withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case
Just user -> process user fileId `catchChatError` (toView . CEvtChatError (Just user))
Just user -> process user fileId `catchChatError` eToView
_ -> do
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId
@@ -208,9 +208,9 @@ processAgentMsgSndFile _corrId aFileId msg = do
Just rs -> case L.last rs of
Right ([msgDeliveryId], _) ->
withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
Right (deliveryIds, _) -> toView $ CEvtChatError (Just user) $ ChatError $ CEInternalError $ "SFDONE, sendFileDescriptions: expected 1 delivery id, got " <> show (length deliveryIds)
Left e -> toView $ CEvtChatError (Just user) e
Nothing -> toView $ CEvtChatError (Just user) $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result"
Right (deliveryIds, _) -> eToView $ ChatError $ CEInternalError $ "SFDONE, sendFileDescriptions: expected 1 delivery id, got " <> show (length deliveryIds)
Left e -> eToView e
Nothing -> eToView $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result"
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
(_, _, SMDSnd, GroupChat g@GroupInfo {groupId} _scope) -> do
ms <- withStore' $ \db -> getGroupMembers db vr user g
@@ -259,7 +259,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
let (errs, msgReqs) = partitionEithers . L.toList $ L.zipWith (fmap . toMsgReq) connsIdsEvts sndMsgs_
delivered <- mapM deliverMessages (L.nonEmpty msgReqs)
let errs' = errs <> maybe [] (lefts . L.toList) delivered
unless (null errs') $ toView $ CEvtChatErrors (Just user) errs'
unless (null errs') $ toView $ CEvtChatErrors errs'
pure delivered
where
connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
@@ -298,7 +298,7 @@ processAgentMsgRcvFile _corrId aFileId msg = do
(cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId)
withEntityLock_ cRef_ . withFileLock "processAgentMsgRcvFile" fileId $
withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case
Just user -> process user fileId `catchChatError` (toView . CEvtChatError (Just user))
Just user -> process user fileId `catchChatError` eToView
_ -> do
lift $ withAgent' (`xftpDeleteRcvFile` aFileId)
throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId
@@ -438,13 +438,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
MWARN _ err ->
processConnMWARN connEntity conn err
MERR _ err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
processConnMERR connEntity conn err
MERRS _ err -> do
-- error cannot be AUTH error here
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
ERR err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
@@ -468,11 +468,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchChatError` \_ -> pure ()
forM_ aChatMsgs $ \case
Right (ACMsg _ chatMsg) ->
processEvent ct' conn' tags eInfo chatMsg `catchChatError` \e -> toView $ CEvtChatError (Just user) e
processEvent ct' conn' tags eInfo chatMsg `catchChatError` \e -> eToView e
Left e -> do
atomically $ modifyTVar' tags ("error" :)
logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e
toView $ CEvtChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
eToView (ChatError . CEException $ "error parsing chat message: " <> e)
checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent
where
aChatMsgs = parseChatMessages msgBody
@@ -655,14 +655,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
processConnMWARN connEntity conn err
MERR msgId err -> do
updateDirectItemStatus ct conn msgId (CISSndError $ agentSndError err)
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
processConnMERR connEntity conn err
MERRS msgIds err -> do
-- error cannot be AUTH error here
updateDirectItemsStatusMsgs ct conn (L.toList msgIds) (CISSndError $ agentSndError err)
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
ERR err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
@@ -757,7 +757,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
XInfo _ ->
-- TODO Keep rejected member to allow them to appeal against rejection.
when (memberStatus m == GSMemRejected) $ do
deleteMemberConnection' user m True
deleteMemberConnection' m True
withStore' $ \db -> deleteGroupMember db user m
XOk -> pure ()
_ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok"
@@ -848,12 +848,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchChatError` \_ -> pure ()
forM_ aChatMsgs $ \case
Right (ACMsg _ chatMsg) ->
processEvent gInfo' m' tags eInfo chatMsg `catchChatError` \e -> toView $ CEvtChatError (Just user) e
processEvent gInfo' m' tags eInfo chatMsg `catchChatError` \e -> eToView e
Left e -> do
atomically $ modifyTVar' tags ("error" :)
logInfo $ "group msg=error " <> eInfo <> " " <> tshow e
toView $ CEvtChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
forwardMsgs (rights aChatMsgs) `catchChatError` (toView . CEvtChatError (Just user))
eToView (ChatError . CEException $ "error parsing chat message: " <> e)
forwardMsgs (rights aChatMsgs) `catchChatError` eToView
checkSendRcpt $ rights aChatMsgs
where
aChatMsgs = parseChatMessages msgBody
@@ -985,16 +985,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
MERR msgId err -> do
withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSError $ agentSndError err)
-- group errors are silenced to reduce load on UI event log
-- toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
-- eToView (ChatErrorAgent err $ Just connEntity)
processConnMERR connEntity conn err
MERRS msgIds err -> do
let newStatus = GSSError $ agentSndError err
-- error cannot be AUTH error here
withStore' $ \db -> forM_ msgIds $ \msgId ->
updateGroupItemsErrorStatus db msgId (groupMemberId' m) newStatus `catchAll_` pure ()
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
ERR err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
@@ -1071,7 +1071,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
withStore' $ \db -> updateSndFileChunkSent db ft msgId
unless (fileStatus == FSCancelled) $ sendFileChunk user ft
MERR _ err -> do
cancelSndFileTransfer user ft True >>= mapM_ (deleteAgentConnectionAsync user)
cancelSndFileTransfer user ft True >>= mapM_ deleteAgentConnectionAsync
case err of
SMP _ SMP.AUTH -> unless (fileStatus == FSCancelled) $ do
ci <- withStore $ \db -> do
@@ -1090,7 +1090,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- [async agent commands] continuation on receiving JOINED
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
ERR err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
@@ -1139,10 +1139,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- [async agent commands] continuation on receiving JOINED
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
MERR _ err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
processConnMERR connEntity conn err
ERR err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
@@ -1151,7 +1151,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
receiveFileChunk ft@RcvFileTransfer {fileId, chunkSize} conn_ meta@MsgMeta {recipient = (msgId, _), integrity} = \case
FileChunkCancel ->
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CEvtRcvFileSndCancelled user ci ft
FileChunk {chunkNo, chunkBytes = chunk} -> do
@@ -1177,7 +1177,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
deleteRcvFileChunks db ft
getChatItemByFileId db vr user fileId
toView $ CEvtRcvFileComplete user ci
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
mapM_ (deleteAgentConnectionAsync . aConnId) conn_
RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure ()
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
@@ -1191,10 +1191,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- TODO show/log error, other events in contact request
_ -> pure ()
MERR _ err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
processConnMERR connEntity conn err
ERR err -> do
toView $ CEvtChatError (Just user) (ChatErrorAgent err $ Just connEntity)
eToView (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
@@ -1369,7 +1369,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
badRcvFileChunk :: RcvFileTransfer -> String -> CM ()
badRcvFileChunk ft err =
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
throwChatError $ CEFileRcvChunk err
memberConnectedChatItem :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
@@ -1839,7 +1839,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CEvtRcvFileSndCancelled user ci ft
@@ -1933,7 +1933,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
then do
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
toView $ CEvtRcvFileSndCancelled user ci ft
else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id
@@ -2020,7 +2020,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
then do
ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted
contactConns <- withStore' $ \db -> getContactConnections db vr userId ct'
deleteAgentConnectionsAsync user $ map aConnId contactConns
deleteAgentConnectionsAsync $ map aConnId contactConns
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
let ct'' = ct' {activeConn = activeConn'} :: Contact
@@ -2029,7 +2029,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toView $ CEvtContactDeletedByContact user ct''
else do
contactConns <- withStore' $ \db -> getContactConnections db vr userId c
deleteAgentConnectionsAsync user $ map aConnId contactConns
deleteAgentConnectionsAsync $ map aConnId contactConns
withStore $ \db -> deleteContact db user c
where
brokerTs = metaBrokerTs msgMeta
@@ -2521,7 +2521,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist"
Right reMember -> do
GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv
sendGroupMemberMessage user gInfo reMember (XGrpMemFwd (memberInfo m) introInv) (Just introId) $
sendGroupMemberMessage gInfo reMember (XGrpMemFwd (memberInfo m) introInv) (Just introId) $
withStore' $
\db -> updateIntroStatus db introId GMIntroInvForwarded
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
@@ -2597,7 +2597,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
| senderRole < GRModerator || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions"
| otherwise -> do
bm' <- setMemberBlocked bm
toggleNtf user bm' (not blocked)
toggleNtf bm' (not blocked)
let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent
@@ -2672,7 +2672,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
Right member@GroupMember {groupMemberId, memberProfile} ->
checkRole member $ do
-- ? prohibit deleting member if it's the sender - sender should use x.grp.leave
deleteMemberConnection user member
deleteMemberConnection member
-- undeleted "member connected" chat item will prevent deletion of member record
deleteOrUpdateMemberRecord user member
when withMessages $ deleteMessages member SMDRcv
@@ -2694,7 +2694,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
xGrpLeave gInfo m msg brokerTs = do
deleteMemberConnection user m
deleteMemberConnection m
-- member record is not deleted to allow creation of "member left" chat item
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
src/Simplex/Chat/Mobile.hs
+14 -8
View File
@@ -13,6 +13,7 @@ import Control.Concurrent.STM
import Control.Exception (SomeException, catch)
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson (ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Bifunctor (first)
@@ -72,13 +73,19 @@ data DBMigrationResult
$(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "DBM") ''DBMigrationResult)
data APIResponse = APIResponse {remoteHostId :: Maybe RemoteHostId, resp :: ChatResponse}
data APIResult r
= APIResult {remoteHostId :: Maybe RemoteHostId, result :: r}
| APIError {remoteHostId :: Maybe RemoteHostId, error :: ChatError}
data APIEvent = APIEvent {remoteHostId :: Maybe RemoteHostId, resp :: ChatEvent}
eitherToResult :: Maybe RemoteHostId -> Either ChatError r -> APIResult r
eitherToResult rhId = either (APIError rhId) (APIResult rhId)
{-# INLINE eitherToResult #-}
$(JQ.deriveToJSON defaultJSON ''APIResponse)
$(pure [])
$(JQ.deriveToJSON defaultJSON ''APIEvent)
instance ToJSON r => ToJSON (APIResult r) where
toEncoding = $(JQ.mkToEncoding (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''APIResult)
toJSON = $(JQ.mkToJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''APIResult)
foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString -> CString -> Ptr (StablePtr ChatController) -> IO CJSONString
@@ -290,15 +297,14 @@ chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
chatSendCmd cc = chatSendRemoteCmd cc Nothing
chatSendRemoteCmd :: ChatController -> Maybe RemoteHostId -> B.ByteString -> IO JSONByteString
chatSendRemoteCmd cc rh s = J.encode . APIResponse rh <$> runReaderT (execChatCommand rh s) cc
chatSendRemoteCmd cc rh s = J.encode . eitherToResult rh <$> runReaderT (execChatCommand rh s) cc
chatRecvMsg :: ChatController -> IO JSONByteString
chatRecvMsg ChatController {outputQ} = json <$> readChatResponse
chatRecvMsg ChatController {outputQ} = J.encode . uncurry eitherToResult <$> readChatResponse
where
json (remoteHostId, resp) = J.encode APIEvent {remoteHostId, resp}
readChatResponse =
atomically (readTBQueue outputQ) >>= \case
(_, CEvtTerminalEvent {}) -> readChatResponse
(_, Right CEvtTerminalEvent {}) -> readChatResponse
out -> pure out
chatRecvMsgWait :: ChatController -> Int -> IO JSONByteString
src/Simplex/Chat/Remote.hs
+11 -10
View File
@@ -370,16 +370,17 @@ processRemoteCommand :: RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteS
processRemoteCommand remoteHostId c cmd s = case cmd of
SendFile chatName f -> sendFile "/f" chatName f
SendImage chatName f -> sendFile "/img" chatName f
_ -> liftRH remoteHostId $ remoteSend c s
_ -> chatRemoteSend s
where
sendFile cmdName chatName (CryptoFile path cfArgs) = do
-- don't encrypt in host if already encrypted locally
CryptoFile path' cfArgs' <- storeRemoteFile remoteHostId (cfArgs $> False) path
let f = CryptoFile path' (cfArgs <|> cfArgs') -- use local or host encryption
liftRH remoteHostId $ remoteSend c $ B.unwords [cmdName, B.pack (chatNameStr chatName), cryptoFileStr f]
chatRemoteSend $ B.unwords [cmdName, B.pack (chatNameStr chatName), cryptoFileStr f]
cryptoFileStr CryptoFile {filePath, cryptoArgs} =
maybe "" (\(CFArgs key nonce) -> "key=" <> strEncode key <> " nonce=" <> strEncode nonce <> " ") cryptoArgs
<> encodeUtf8 (T.pack filePath)
chatRemoteSend = either throwError pure <=< liftRH remoteHostId . remoteSend c
liftRH :: RemoteHostId -> ExceptT RemoteProtocolError IO a -> CM a
liftRH rhId = liftError (ChatErrorRemoteHost (RHId rhId) . RHEProtocolError)
@@ -496,7 +497,7 @@ parseCtrlAppInfo :: JT.Value -> CM CtrlAppInfo
parseCtrlAppInfo ctrlAppInfo = do
liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo
handleRemoteCommand :: (ByteString -> CM' ChatResponse) -> RemoteCrypto -> TBQueue ChatEvent -> HTTP2Request -> CM' ()
handleRemoteCommand :: (ByteString -> CM' (Either ChatError ChatResponse)) -> RemoteCrypto -> TBQueue (Either ChatError ChatEvent) -> HTTP2Request -> CM' ()
handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
logDebug "handleRemoteCommand"
liftIO (tryRemoteError' parseRequest) >>= \case
@@ -510,7 +511,7 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque
parseRequest = do
(rfKN, header, getNext) <- parseDecryptHTTP2Body encryption request reqBody
(rfKN,getNext,) <$> liftEitherWith RPEInvalidJSON (J.eitherDecode header)
replyError = reply . RRChatResponse . CRChatCmdError Nothing
replyError = reply . RRChatResponse . RRError
processCommand :: User -> C.SbKeyNonce -> GetChunk -> RemoteCommand -> CM ()
processCommand user rfKN getNext = \case
RCSend {command} -> lift $ handleSend execChatCommand command >>= reply
@@ -527,7 +528,7 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque
send resp
attach sfKN send
flush
Left e -> toView' . CEvtChatError Nothing . ChatErrorRemoteCtrl $ RCEProtocolError e
Left e -> eToView' $ ChatErrorRemoteCtrl $ RCEProtocolError e
takeRCStep :: RCStepTMVar a -> CM a
takeRCStep = liftError' (\e -> ChatErrorAgent {agentError = RCP e, connectionEntity_ = Nothing}) . atomically . takeTMVar
@@ -549,17 +550,17 @@ tryRemoteError' :: ExceptT RemoteProtocolError IO a -> IO (Either RemoteProtocol
tryRemoteError' = tryAllErrors' (RPEException . tshow)
{-# INLINE tryRemoteError' #-}
handleSend :: (ByteString -> CM' ChatResponse) -> Text -> CM' RemoteResponse
handleSend :: (ByteString -> CM' (Either ChatError ChatResponse)) -> Text -> CM' RemoteResponse
handleSend execChatCommand command = do
logDebug $ "Send: " <> tshow command
-- execChatCommand checks for remote-allowed commands
-- convert errors thrown in execChatCommand into error responses to prevent aborting the protocol wrapper
RRChatResponse <$> execChatCommand (encodeUtf8 command)
RRChatResponse . eitherToResult <$> execChatCommand (encodeUtf8 command)
handleRecv :: Int -> TBQueue ChatEvent -> IO RemoteResponse
handleRecv :: Int -> TBQueue (Either ChatError ChatEvent) -> IO RemoteResponse
handleRecv time events = do
logDebug $ "Recv: " <> tshow time
RRChatEvent <$> (timeout time . atomically $ readTBQueue events)
RRChatEvent . fmap eitherToResult <$> (timeout time . atomically $ readTBQueue events)
-- TODO this command could remember stored files and return IDs to allow removing files that are not needed.
-- Also, there should be some process removing unused files uploaded to remote host (possibly, all unused files).
@@ -614,7 +615,7 @@ remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionState =
RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState}
-- | Take a look at emoji of tlsunique, commit pairing, and start session server
verifyRemoteCtrlSession :: (ByteString -> CM' ChatResponse) -> Text -> CM RemoteCtrlInfo
verifyRemoteCtrlSession :: (ByteString -> CM' (Either ChatError ChatResponse)) -> Text -> CM RemoteCtrlInfo
verifyRemoteCtrlSession execChatCommand sessCode' = do
(sseq, client, ctrlName, sessionCode, vars) <-
chatReadVar remoteCtrlSession >>= \case
src/Simplex/Chat/Remote/Protocol.hs
+36 -12
View File
@@ -16,11 +16,11 @@ import Control.Monad.Except
import Control.Monad.Reader
import Crypto.Hash (SHA512)
import qualified Crypto.Hash as CH
import Data.Aeson ((.=))
import Data.Aeson (FromJSON (..), ToJSON (..), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Key as JK
import qualified Data.Aeson.KeyMap as JM
import Data.Aeson.TH (deriveJSON)
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import qualified Data.ByteArray as BA
import Data.ByteString (ByteString)
@@ -42,7 +42,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (TSbChainKeys)
import Simplex.Messaging.Transport.Buffer (getBuffered)
@@ -64,16 +64,40 @@ data RemoteCommand
deriving (Show)
data RemoteResponse
= RRChatResponse {chatResponse :: ChatResponse}
| RRChatEvent {chatEvent :: Maybe ChatEvent} -- 'Nothing' on poll timeout
= RRChatResponse {chatResponse :: RRResult ChatResponse}
| RRChatEvent {chatEvent :: Maybe (RRResult ChatEvent)} -- 'Nothing' on poll timeout
| RRFileStored {filePath :: String}
| RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest
| RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- The protocol error happened on the server side
deriving (Show)
data RRResult r
= RRResult {result :: r}
| RRError {error :: ChatError}
deriving (Show)
resultToEither :: RRResult r -> Either ChatError r
resultToEither = \case
RRResult r -> Right r
RRError e -> Left e
{-# INLINE resultToEither #-}
eitherToResult :: Either ChatError r -> RRResult r
eitherToResult = either RRError RRResult
{-# INLINE eitherToResult #-}
$(pure [])
-- Force platform-independent encoding as the types aren't UI-visible
$(deriveJSON (taggedObjectJSON $ dropPrefix "RC") ''RemoteCommand)
$(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
instance ToJSON r => ToJSON (RRResult r) where
toEncoding = $(JQ.mkToEncoding (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''RRResult)
toJSON = $(JQ.mkToJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''RRResult)
instance FromJSON r => FromJSON (RRResult r) where
parseJSON = $(JQ.mkParseJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''RRResult)
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "RC") ''RemoteCommand)
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
-- * Client side / desktop
@@ -109,16 +133,16 @@ closeRemoteHostClient RemoteHostClient {httpClient} = closeHTTP2Client httpClien
-- ** Commands
remoteSend :: RemoteHostClient -> ByteString -> ExceptT RemoteProtocolError IO ChatResponse
remoteSend :: RemoteHostClient -> ByteString -> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
remoteSend c cmd =
sendRemoteCommand' c Nothing RCSend {command = decodeUtf8 cmd} >>= \case
RRChatResponse cr -> pure cr
RRChatResponse cr -> pure $ resultToEither cr
r -> badResponse r
remoteRecv :: RemoteHostClient -> Int -> ExceptT RemoteProtocolError IO (Maybe ChatEvent)
remoteRecv :: RemoteHostClient -> Int -> ExceptT RemoteProtocolError IO (Maybe (Either ChatError ChatEvent))
remoteRecv c ms =
sendRemoteCommand' c Nothing RCRecv {wait = ms} >>= \case
RRChatEvent cEvt_ -> pure cEvt_
RRChatEvent cEvt_ -> pure $ resultToEither <$> cEvt_
r -> badResponse r
remoteStoreFile :: RemoteHostClient -> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath
@@ -172,7 +196,7 @@ convertJSON :: PlatformEncoding -> PlatformEncoding -> J.Value -> J.Value
convertJSON _remote@PEKotlin _local@PEKotlin = id
convertJSON PESwift PESwift = id
convertJSON PESwift PEKotlin = owsf2tagged
convertJSON PEKotlin PESwift = error "unsupported convertJSON: K/S" -- guarded by handshake
convertJSON PEKotlin PESwift = Prelude.error "unsupported convertJSON: K/S" -- guarded by handshake
-- | Convert swift single-field sum encoding into tagged/discriminator-field
owsf2tagged :: J.Value -> J.Value
src/Simplex/Chat/Terminal/Input.hs
+8 -7
View File
@@ -64,12 +64,14 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
rh' = if either (const False) allowRemoteCommand cmd then rh else Nothing
unless (isMessage cmd) $ echo s
r <- runReaderT (execChatCommand rh' bs) cc
processResp s cmd rh r
case r of
Right r' -> processResp cmd rh r'
Left _ -> when (isMessage cmd) $ echo s
printRespToTerminal ct cc False rh r
startLiveMessage cmd r
mapM_ (startLiveMessage cmd) r
where
echo s = printToTerminal ct [plain s]
processResp s cmd rh = \case
processResp cmd rh = \case
CRActiveUser u -> case rh of
Nothing -> setActive ct ""
Just rhId -> updateRemoteUser ct u rhId
@@ -80,7 +82,6 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
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
CRCmdOk _ -> case cmd of
Right APIDeleteUser {} -> setActive ct ""
_ -> pure ()
@@ -132,7 +133,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
updateLiveMessage typedMsg lm = case liveMessageToSend typedMsg lm of
Just sentMsg ->
sendUpdatedLiveMessage cc sentMsg lm True >>= \case
CRChatItemUpdated {} -> setLiveMessage lm {sentMsg, typedMsg}
Right CRChatItemUpdated {} -> setLiveMessage lm {sentMsg, typedMsg}
_ -> do
-- TODO print error
setLiveMessage lm {typedMsg}
@@ -146,10 +147,10 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
| otherwise = (s <> reverse (c : w), "")
startLiveMessage _ _ = pure ()
sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO ChatResponse
sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO (Either ChatError ChatResponse)
sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do
let cmd = UpdateLiveMessage chatName chatItemId live $ T.pack sentMsg
either (CRChatCmdError Nothing) id <$> runExceptT (processChatCommand cmd) `runReaderT` cc
runExceptT (processChatCommand cmd) `runReaderT` cc
runTerminalInput :: ChatTerminal -> ChatController -> IO ()
runTerminalInput ct cc = withChatTerm ct $ do
src/Simplex/Chat/Terminal/Main.hs
+6 -9
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Chat.Terminal.Main where
@@ -7,15 +8,13 @@ import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Network.Socket
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatEvent (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError, ChatEvent (..), PresetServers (..), SimpleNetCfg (..), currentRemoteHost, versionNumber, versionString)
import Simplex.Chat.Core
import Simplex.Chat.Options
import Simplex.Chat.Options.DB
import Simplex.Chat.Terminal
import Simplex.Chat.View (ChatResponseEvent, serializeChatResponse, smpProxyModeStr)
import Simplex.Chat.View (ChatResponseEvent, smpProxyModeStr)
import Simplex.Messaging.Client (NetworkConfig (..), SocksMode (..))
import System.Directory (getAppUserDataDirectory)
import System.Exit (exitFailure)
@@ -45,17 +44,15 @@ simplexChatCLI' cfg opts@ChatOpts {chatCmd, chatCmdLog, chatCmdDelay, chatServer
when (chatCmdLog /= CCLNone) . void . forkIO . forever $ do
(_, r) <- atomically . readTBQueue $ outputQ cc
case r of
CEvtNewChatItems {} -> printResponse r
Right CEvtNewChatItems {} -> printResponse r
_ -> when (chatCmdLog == CCLAll) $ printResponse r
sendChatCmdStr cc chatCmd >>= printResponse
threadDelay $ chatCmdDelay * 1000000
where
printResponse :: ChatResponseEvent r => r -> IO ()
printResponse :: ChatResponseEvent r => Either ChatError r -> IO ()
printResponse r = do
ts <- getCurrentTime
tz <- getCurrentTimeZone
rh <- readTVarIO $ currentRemoteHost cc
putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
printResponseEvent (rh, Just user) cfg r
welcome :: ChatConfig -> ChatOpts -> IO ()
welcome ChatConfig {presetServers = PresetServers {netCfg}} ChatOpts {coreOptions = CoreChatOpts {dbOptions, simpleNetCfg = SimpleNetCfg {socksProxy, socksMode, smpProxyMode_, smpProxyFallback_}}} =
src/Simplex/Chat/Terminal/Output.hs
+16 -13
View File
@@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Terminal.Output where
@@ -146,19 +147,19 @@ withTermLock ChatTerminal {termLock} action = do
runTerminalOutput :: ChatTerminal -> ChatController -> ChatOpts -> IO ()
runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} ChatOpts {markRead} = do
forever $ do
(outputRH, r) <- atomically $ readTBQueue outputQ
case r of
(outputRH, r_) <- atomically $ readTBQueue outputQ
forM_ r_ $ \case
CEvtNewChatItems u (ci : _) -> when markRead $ markChatItemRead u ci -- At the moment of writing received items are created one at a time
CEvtChatItemUpdated u ci -> when markRead $ markChatItemRead u ci
CEvtRemoteHostConnected {remoteHost = RemoteHostInfo {remoteHostId}} -> getRemoteUser remoteHostId
CEvtRemoteHostStopped {remoteHostId_} -> mapM_ removeRemoteUser remoteHostId_
_ -> pure ()
let printEvent = case logFilePath of
Just path -> if logEventToFile r then logResponse path else printToTerminal ct
Just path -> if either (const True) logEventToFile r_ then logResponse path else printToTerminal ct
_ -> printToTerminal ct
liveItems <- readTVarIO showLiveItems
responseString ct cc liveItems outputRH r >>= printEvent
chatEventNotification ct cc r
responseString ct cc liveItems outputRH r_ >>= printEvent
mapM_ (chatEventNotification ct cc) r_
where
markChatItemRead u (AChatItem _ _ chat ci@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
case (chatDirNtf u chat chatDir (isUserMention ci), itemStatus) of
@@ -170,7 +171,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
getRemoteUser rhId =
runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
CRActiveUser {user} -> updateRemoteUser ct user rhId
Right CRActiveUser {user} -> updateRemoteUser ct user rhId
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr
removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)
@@ -273,15 +274,17 @@ whenCurrUser cc u a = do
where
sameUser User {userId = uId} = maybe False $ \User {userId} -> userId == uId
printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> ChatResponse -> IO ()
printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> Either ChatError ChatResponse -> IO ()
printRespToTerminal ct cc liveItems outputRH r = responseString ct cc liveItems outputRH r >>= printToTerminal ct
responseString :: ChatResponseEvent r => ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> r -> IO [StyledString]
responseString ct cc liveItems outputRH r = do
cu <- getCurrentUser ct cc
ts <- getCurrentTime
tz <- getCurrentTimeZone
pure $ responseToView cu (config cc) liveItems ts tz outputRH r
responseString :: forall r. ChatResponseEvent r => ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> Either ChatError r -> IO [StyledString]
responseString ct cc liveItems outputRH = \case
Right r -> do
cu <- getCurrentUser ct cc
ts <- getCurrentTime
tz <- getCurrentTimeZone
pure $ responseToView cu (config cc) liveItems ts tz outputRH r
Left e -> pure $ chatErrorToView (isCommandResponse @r) (config cc) e
updateRemoteUser :: ChatTerminal -> User -> RemoteHostId -> IO ()
updateRemoteUser ct user rhId = atomically $ TM.insert rhId user (currentRemoteUsers ct)
src/Simplex/Chat/View.hs
+17 -10
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
@@ -38,7 +39,6 @@ import Data.Time.Format (defaultTimeLocale, formatTime)
import qualified Data.Version as V
import qualified Network.HTTP.Types as Q
import Numeric (showFFloat)
import Simplex.Chat (defaultChatConfig)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Help
@@ -87,15 +87,26 @@ data WCallCommand
$(JQ.deriveToJSON (taggedObjectJSON $ dropPrefix "WCCall") ''WCallCommand)
serializeChatResponse :: ChatResponseEvent r => (Maybe RemoteHostId, Maybe User) -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> r -> String
serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_
serializeChatError :: Bool -> ChatConfig -> ChatError -> String
serializeChatError isCmd cfg = unlines . map unStyle . chatErrorToView isCmd cfg
serializeChatResponse :: ChatResponseEvent r => (Maybe RemoteHostId, Maybe User) -> ChatConfig -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> r -> String
serializeChatResponse hu cfg ts tz remoteHost_ = unlines . map unStyle . responseToView hu cfg False ts tz remoteHost_
class ChatResponseEvent r where
responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> r -> [StyledString]
isCommandResponse :: Bool
instance ChatResponseEvent ChatResponse where responseToView = chatResponseToView
instance ChatResponseEvent ChatResponse where
responseToView = chatResponseToView
isCommandResponse = True
instance ChatResponseEvent ChatEvent where responseToView = chatEventToView
instance ChatResponseEvent ChatEvent where
responseToView = chatEventToView
isCommandResponse = False
chatErrorToView :: Bool -> ChatConfig -> ChatError -> [StyledString]
chatErrorToView isCmd ChatConfig {logLevel, testView} = viewChatError isCmd logLevel testView
chatResponseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString]
chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveItems ts tz outputRH = \case
@@ -290,7 +301,6 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
[ "agent queues info:",
plain . LB.unpack $ J.encode agentQueuesInfo
]
CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError True logLevel testView e
CRAppSettings as -> ["app settings: " <> viewJSON as]
CRCustomChatResponse u r -> ttyUser' u $ map plain $ T.lines r
where
@@ -300,8 +310,6 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
| otherwise = []
ttyUser' :: Maybe User -> [StyledString] -> [StyledString]
ttyUser' = maybe id ttyUser
ttyUserPrefix' :: Maybe User -> [StyledString] -> [StyledString]
ttyUserPrefix' = maybe id $ ttyUserPrefix hu outputRH
testViewChats :: [AChat] -> [StyledString]
testViewChats chats = [sShow $ map toChatView chats]
where
@@ -504,8 +512,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
CEvtAgentConnsDeleted acIds -> ["completed deleting connections: " <> sShow (length acIds) | logLevel <= CLLInfo]
CEvtAgentUserDeleted auId -> ["completed deleting user" <> if logLevel <= CLLInfo then ", agent user id: " <> sShow auId else ""]
CEvtMessageError u prefix err -> ttyUser u [plain prefix <> ": " <> plain err | prefix == "error" || logLevel <= CLLWarning]
CEvtChatError u e -> ttyUser' u $ viewChatError False logLevel testView e
CEvtChatErrors u errs -> ttyUser' u $ concatMap (viewChatError False logLevel testView) errs
CEvtChatErrors errs -> concatMap (viewChatError False logLevel testView) errs
CEvtTimedAction _ _ -> []
CEvtTerminalEvent te -> case te of
TERejectingGroupJoinRequestMember _ g m reason -> [ttyFullMember m <> ": rejecting request to join group " <> ttyGroup' g <> ", reason: " <> sShow reason]