mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-10-23 04:22:13 +00:00
core: use longer timeouts for background network requests, support retries with increased timeouts (#6043)
* core: use longer timeouts for background network requests, support retries with increased timeouts * ios: update types * ios: allow user retry actions with failed network requests * build: add exporting API functions with retry * android, desktop: update types and C APIs * android, desktop: alert to retry action on network error * simplexmq
This commit is contained in:
Evgeny authored and GitHub committed
1 parent
f2e8545c0a
commit
88547ab704
41 files changed
+695
-408
No files matched your search
@@ -65,10 +65,10 @@ runSimplexChat ChatOpts {maintenance} u cc chat
|
||||
waitEither_ a1 a2
|
||||
|
||||
sendChatCmdStr :: ChatController -> String -> IO (Either ChatError ChatResponse)
|
||||
sendChatCmdStr cc s = runReaderT (execChatCommand Nothing . encodeUtf8 $ T.pack s) cc
|
||||
sendChatCmdStr cc s = runReaderT (execChatCommand Nothing (encodeUtf8 $ T.pack s) 0) cc
|
||||
|
||||
sendChatCmd :: ChatController -> ChatCommand -> IO (Either ChatError ChatResponse)
|
||||
sendChatCmd cc cmd = runReaderT (execChatCommand' cmd) cc
|
||||
sendChatCmd cc cmd = runReaderT (execChatCommand' cmd 0) cc
|
||||
|
||||
getSelectActiveUser :: DBStore -> IO (Maybe User)
|
||||
getSelectActiveUser st = do
|
||||
@@ -108,7 +108,7 @@ createActiveUser cc = do
|
||||
loop = 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
|
||||
execChatCommand' (CreateActiveUser NewUser {profile, pastTimestamp = False}) 0 `runReaderT` cc >>= \case
|
||||
Right (CRActiveUser user) -> pure user
|
||||
r -> printResponseEvent (Nothing, Nothing) (config cc) r >> loop
|
||||
|
||||
|
||||
@@ -95,7 +95,7 @@ import Simplex.Messaging.Agent.Store.Interface (execSQL)
|
||||
import Simplex.Messaging.Agent.Store.Shared (upMigration)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Interface (getCurrentMigrations)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), SMPWebPortServers (..), SocksMode (SMAlways), textToHostMode)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..), NetworkTimeout (..), SMPWebPortServers (..), SocksMode (SMAlways), textToHostMode)
|
||||
import Simplex.Messaging.Compression (compressionLevel)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
@@ -263,7 +263,8 @@ updateNetworkConfig :: NetworkConfig -> SimpleNetCfg -> NetworkConfig
|
||||
updateNetworkConfig cfg SimpleNetCfg {socksProxy, socksMode, hostMode, requiredHostMode, smpProxyMode_, smpProxyFallback_, smpWebPortServers, tcpTimeout_, logTLSErrors} =
|
||||
let cfg1 = maybe cfg (\smpProxyMode -> cfg {smpProxyMode}) smpProxyMode_
|
||||
cfg2 = maybe cfg1 (\smpProxyFallback -> cfg1 {smpProxyFallback}) smpProxyFallback_
|
||||
cfg3 = maybe cfg2 (\tcpTimeout -> cfg2 {tcpTimeout, tcpConnectTimeout = (tcpTimeout * 3) `div` 2}) tcpTimeout_
|
||||
cfg3 = maybe cfg2 (\t -> cfg2 {tcpTimeout = nt t, tcpConnectTimeout = nt ((t * 3) `div` 2)}) tcpTimeout_
|
||||
nt t = NetworkTimeout {backgroundTimeout = t * 3, interactiveTimeout = t}
|
||||
in cfg3 {socksProxy, socksMode, hostMode, requiredHostMode, smpWebPortServers, logTLSErrors}
|
||||
|
||||
useServers :: Foldable f => RandomAgentServers -> [(Text, ServerOperator)] -> f UserOperatorServers -> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))
|
||||
@@ -272,25 +273,27 @@ useServers as opDomains uss =
|
||||
xftp' = useServerCfgs SPXFTP as opDomains $ concatMap (servers' SPXFTP) uss
|
||||
in (smp', xftp')
|
||||
|
||||
execChatCommand :: Maybe RemoteHostId -> ByteString -> CM' (Either ChatError ChatResponse)
|
||||
execChatCommand rh s =
|
||||
execChatCommand :: Maybe RemoteHostId -> ByteString -> Int -> CM' (Either ChatError ChatResponse)
|
||||
execChatCommand rh s retryNum =
|
||||
case parseChatCommand s of
|
||||
Left e -> pure $ chatCmdError e
|
||||
Right cmd -> case rh of
|
||||
Just rhId
|
||||
| allowRemoteCommand cmd -> execRemoteCommand rhId cmd s
|
||||
| allowRemoteCommand cmd -> execRemoteCommand rhId cmd s retryNum
|
||||
| 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'
|
||||
Nothing -> execChatCommand' cmd
|
||||
Just hook -> liftIO (hook cc cmd) >>= either pure (`execChatCommand'` retryNum)
|
||||
Nothing -> execChatCommand' cmd retryNum
|
||||
|
||||
execChatCommand' :: ChatCommand -> CM' (Either ChatError ChatResponse)
|
||||
execChatCommand' cmd = handleCommandError $ processChatCommand cmd
|
||||
execChatCommand' :: ChatCommand -> Int -> CM' (Either ChatError ChatResponse)
|
||||
execChatCommand' cmd retryNum = handleCommandError $ do
|
||||
vr <- chatVersionRange
|
||||
processChatCommand vr (NRMInteractive' retryNum) cmd
|
||||
|
||||
execRemoteCommand :: RemoteHostId -> ChatCommand -> ByteString -> CM' (Either ChatError ChatResponse)
|
||||
execRemoteCommand rhId cmd s = handleCommandError $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s
|
||||
execRemoteCommand :: RemoteHostId -> ChatCommand -> ByteString -> Int -> CM' (Either ChatError ChatResponse)
|
||||
execRemoteCommand rhId cmd s retryNum = handleCommandError $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s retryNum
|
||||
|
||||
handleCommandError :: CM ChatResponse -> CM' (Either ChatError ChatResponse)
|
||||
handleCommandError a = runExceptT a `E.catches` ioErrors
|
||||
@@ -304,13 +307,8 @@ parseChatCommand :: ByteString -> Either String ChatCommand
|
||||
parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
|
||||
|
||||
-- | Chat API commands interpreted in context of a local zone
|
||||
processChatCommand :: ChatCommand -> CM ChatResponse
|
||||
processChatCommand cmd =
|
||||
chatVersionRange >>= (`processChatCommand'` cmd)
|
||||
{-# INLINE processChatCommand #-}
|
||||
|
||||
processChatCommand' :: VersionRangeChat -> ChatCommand -> CM ChatResponse
|
||||
processChatCommand' vr = \case
|
||||
processChatCommand :: VersionRangeChat -> NetworkRequestMode -> ChatCommand -> CM ChatResponse
|
||||
processChatCommand vr nm = \case
|
||||
ShowActiveUser -> withUser' $ pure . CRActiveUser
|
||||
CreateActiveUser NewUser {profile, pastTimestamp} -> do
|
||||
forM_ profile $ \Profile {displayName} -> checkValidName displayName
|
||||
@@ -367,20 +365,20 @@ processChatCommand' vr = \case
|
||||
SetActiveUser uName viewPwd_ -> do
|
||||
tryChatError (withFastStore (`getUserIdByName` uName)) >>= \case
|
||||
Left _ -> throwChatError CEUserUnknown
|
||||
Right userId -> processChatCommand $ APISetActiveUser userId viewPwd_
|
||||
Right userId -> processChatCommand vr nm $ APISetActiveUser userId viewPwd_
|
||||
SetAllContactReceipts onOff -> withUser $ \_ -> withFastStore' (`updateAllContactReceipts` onOff) >> ok_
|
||||
APISetUserContactReceipts userId' settings -> withUser $ \user -> do
|
||||
user' <- privateGetUser userId'
|
||||
validateUserPassword user user' Nothing
|
||||
withFastStore' $ \db -> updateUserContactReceipts db user' settings
|
||||
ok user
|
||||
SetUserContactReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserContactReceipts userId settings
|
||||
SetUserContactReceipts settings -> withUser $ \User {userId} -> processChatCommand vr nm $ APISetUserContactReceipts userId settings
|
||||
APISetUserGroupReceipts userId' settings -> withUser $ \user -> do
|
||||
user' <- privateGetUser userId'
|
||||
validateUserPassword user user' Nothing
|
||||
withFastStore' $ \db -> updateUserGroupReceipts db user' settings
|
||||
ok user
|
||||
SetUserGroupReceipts settings -> withUser $ \User {userId} -> processChatCommand $ APISetUserGroupReceipts userId settings
|
||||
SetUserGroupReceipts settings -> withUser $ \User {userId} -> processChatCommand vr nm $ APISetUserGroupReceipts userId settings
|
||||
APIHideUser userId' (UserPwd viewPwd) -> withUser $ \user -> do
|
||||
user' <- privateGetUser userId'
|
||||
case viewPwdHash user' of
|
||||
@@ -406,15 +404,15 @@ processChatCommand' vr = \case
|
||||
setUserPrivacy user user' {viewPwdHash = Nothing, showNtfs = True}
|
||||
APIMuteUser userId' -> setUserNotifications userId' False
|
||||
APIUnmuteUser userId' -> setUserNotifications userId' True
|
||||
HideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIHideUser userId viewPwd
|
||||
UnhideUser viewPwd -> withUser $ \User {userId} -> processChatCommand $ APIUnhideUser userId viewPwd
|
||||
MuteUser -> withUser $ \User {userId} -> processChatCommand $ APIMuteUser userId
|
||||
UnmuteUser -> withUser $ \User {userId} -> processChatCommand $ APIUnmuteUser userId
|
||||
HideUser viewPwd -> withUser $ \User {userId} -> processChatCommand vr nm $ APIHideUser userId viewPwd
|
||||
UnhideUser viewPwd -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUnhideUser userId viewPwd
|
||||
MuteUser -> withUser $ \User {userId} -> processChatCommand vr nm $ APIMuteUser userId
|
||||
UnmuteUser -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUnmuteUser userId
|
||||
APIDeleteUser userId' delSMPQueues viewPwd_ -> withUser $ \user -> do
|
||||
user' <- privateGetUser userId'
|
||||
validateUserPassword user user' viewPwd_
|
||||
checkDeleteChatUser user'
|
||||
withChatLock "deleteUser" . procCmd $ deleteChatUser user' delSMPQueues
|
||||
withChatLock "deleteUser" $ deleteChatUser user' delSMPQueues
|
||||
DeleteUser uName delSMPQueues viewPwd_ -> withUserName uName $ \userId -> APIDeleteUser userId delSMPQueues viewPwd_
|
||||
StartChat {mainApp, enableSndFiles, largeLinkData} -> withUser' $ \_ -> do
|
||||
chatWriteVar useLargeLinkData largeLinkData
|
||||
@@ -474,7 +472,7 @@ processChatCommand' vr = \case
|
||||
ExportArchive -> do
|
||||
ts <- liftIO getCurrentTime
|
||||
let filePath = "simplex-chat." <> formatTime defaultTimeLocale "%FT%H%M%SZ" ts <> ".zip"
|
||||
processChatCommand $ APIExportArchive $ ArchiveConfig filePath Nothing Nothing
|
||||
processChatCommand vr nm $ APIExportArchive $ ArchiveConfig filePath Nothing Nothing
|
||||
APIImportArchive cfg -> checkChatStopped $ do
|
||||
fileErrs <- lift $ importArchive cfg
|
||||
setStoreChanged
|
||||
@@ -586,7 +584,7 @@ processChatCommand' vr = \case
|
||||
ReportMessage {groupName, contactName_, reportReason, reportedMessage} -> withUser $ \user -> do
|
||||
gId <- withFastStore $ \db -> getGroupIdByName db user groupName
|
||||
reportedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId contactName_ reportedMessage
|
||||
processChatCommand $ APIReportMessage gId reportedItemId reportReason ""
|
||||
processChatCommand vr nm $ 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) $ throwCmdError "mentions are not supported in this chat"
|
||||
@@ -993,7 +991,7 @@ processChatCommand' vr = \case
|
||||
let ext = takeExtension fileName
|
||||
pure $ prefix <> formattedDate <> ext
|
||||
APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user
|
||||
UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId
|
||||
UserRead -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUserRead userId
|
||||
APIChatRead chatRef@(ChatRef cType chatId scope) -> withUser $ \_ -> case cType of
|
||||
CTDirect -> do
|
||||
user <- withFastStore $ \db -> getUserByContactId db chatId
|
||||
@@ -1070,7 +1068,7 @@ processChatCommand' vr = \case
|
||||
CTDirect -> do
|
||||
ct <- withFastStore $ \db -> getContact db vr user chatId
|
||||
filesInfo <- withFastStore' $ \db -> getContactFileInfo db user ct
|
||||
withContactLock "deleteChat direct" chatId . procCmd $
|
||||
withContactLock "deleteChat direct" chatId $
|
||||
case cdm of
|
||||
CDMFull notify -> do
|
||||
deleteCIFiles user filesInfo
|
||||
@@ -1091,7 +1089,7 @@ processChatCommand' vr = \case
|
||||
getContact db vr user chatId
|
||||
pure $ CRContactDeleted user ct'
|
||||
CDMMessages -> do
|
||||
void $ processChatCommand $ APIClearChat cRef
|
||||
void $ processChatCommand vr nm $ APIClearChat cRef
|
||||
withFastStore' $ \db -> setContactChatDeleted db user ct True
|
||||
pure $ CRContactDeleted user ct {chatDeleted = True}
|
||||
where
|
||||
@@ -1100,7 +1098,7 @@ processChatCommand' vr = \case
|
||||
when doSendDel $ void (sendDirectContactMessage user ct XDirectDel) `catchChatError` const (pure ())
|
||||
contactConnIds <- map aConnId <$> withFastStore' (\db -> getContactConnections db vr userId ct)
|
||||
deleteAgentConnectionsAsync' contactConnIds doSendDel
|
||||
CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId . procCmd $ do
|
||||
CTContactConnection -> withConnectionLock "deleteChat contactConnection" chatId $ do
|
||||
conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withFastStore $ \db -> getPendingContactConnection db userId chatId
|
||||
deleteAgentConnectionAsync acId
|
||||
withFastStore' $ \db -> deletePendingContactConnection db userId chatId
|
||||
@@ -1112,7 +1110,7 @@ processChatCommand' vr = \case
|
||||
canDelete = isOwner || not (memberCurrent membership)
|
||||
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
|
||||
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
withGroupLock "deleteChat group" chatId . procCmd $ do
|
||||
withGroupLock "deleteChat group" chatId $ do
|
||||
deleteCIFiles user filesInfo
|
||||
let doSendDel = memberActive membership && isOwner
|
||||
recipients = filter memberCurrentOrPending members
|
||||
@@ -1171,7 +1169,7 @@ processChatCommand' vr = \case
|
||||
pure $ CRAcceptingContactRequest user ct
|
||||
where
|
||||
acceptCReq user cReq contactUsed = do
|
||||
(ct, conn, sqSecured) <- acceptContactRequest user cReq incognito
|
||||
(ct, conn, sqSecured) <- acceptContactRequest nm user cReq incognito
|
||||
ct' <- withStore' $ \db -> do
|
||||
updateContactAccepted db user ct contactUsed
|
||||
conn' <-
|
||||
@@ -1230,7 +1228,7 @@ processChatCommand' vr = \case
|
||||
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
|
||||
processChatCommand vr nm $ APISendCallInvitation contactId callType
|
||||
APIRejectCall contactId ->
|
||||
-- party accepting call
|
||||
withCurrentCall contactId $ \user ct Call {chatItemId, callState} -> case callState of
|
||||
@@ -1344,10 +1342,10 @@ processChatCommand' vr = \case
|
||||
_ -> throwCmdError "not supported"
|
||||
APIGetNtfToken -> withUser' $ \_ -> crNtfToken <$> withAgent getNtfToken
|
||||
APIRegisterToken token mode -> withUser $ \_ ->
|
||||
CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a token mode)
|
||||
APIVerifyToken token nonce code -> withUser $ \_ -> withAgent (\a -> verifyNtfToken a token nonce code) >> ok_
|
||||
CRNtfTokenStatus <$> withAgent (\a -> registerNtfToken a nm token mode)
|
||||
APIVerifyToken token nonce code -> withUser $ \_ -> withAgent (\a -> verifyNtfToken a nm token nonce code) >> ok_
|
||||
APICheckToken token -> withUser $ \_ ->
|
||||
CRNtfTokenStatus <$> withAgent (`checkNtfToken` token)
|
||||
CRNtfTokenStatus <$> withAgent (\a -> checkNtfToken a nm token)
|
||||
APIDeleteToken token -> withUser $ \_ -> withAgent (`deleteNtfToken` token) >> ok_
|
||||
APIGetNtfConns nonce encNtfInfo -> withUser $ \_ -> do
|
||||
ntfInfos <- withAgent $ \a -> getNotificationConns a nonce encNtfInfo
|
||||
@@ -1376,16 +1374,16 @@ processChatCommand' vr = \case
|
||||
[] -> throwCmdError "no servers"
|
||||
_ -> do
|
||||
srvs' <- mapM aUserServer srvs
|
||||
processChatCommand $ APISetUserServers userId $ L.map (updatedServers p srvs') userServers
|
||||
processChatCommand vr nm $ APISetUserServers userId $ L.map (updatedServers p srvs') userServers
|
||||
where
|
||||
aUserServer :: AProtoServerWithAuth -> CM (AUserServer p)
|
||||
aUserServer (AProtoServerWithAuth p' srv) = case testEquality p p' of
|
||||
Just Refl -> pure $ AUS SDBNew $ newUserServer 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)
|
||||
lift $ CRServerTestResult user srv <$> withAgent' (\a -> testProtocolServer a nm (aUserId user) server)
|
||||
TestProtoServer srv -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APITestProtoServer userId srv
|
||||
processChatCommand vr nm $ APITestProtoServer userId srv
|
||||
APIGetServerOperators -> CRServerOperatorConditions <$> withFastStore getServerOperators
|
||||
APISetServerOperators operators -> do
|
||||
as <- asks randomAgentServers
|
||||
@@ -1410,7 +1408,7 @@ processChatCommand' vr = \case
|
||||
SetServerOperators operatorsRoles -> do
|
||||
ops <- serverOperators <$> withFastStore getServerOperators
|
||||
ops' <- mapM (updateOp ops) operatorsRoles
|
||||
processChatCommand $ APISetServerOperators ops'
|
||||
processChatCommand vr nm $ APISetServerOperators ops'
|
||||
where
|
||||
updateOp :: [ServerOperator] -> ServerOperatorRoles -> CM ServerOperator
|
||||
updateOp ops r =
|
||||
@@ -1481,7 +1479,7 @@ processChatCommand' vr = \case
|
||||
_ -> throwCmdError "not supported"
|
||||
SetChatTTL chatName newTTL -> withUser' $ \user@User {userId} -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
processChatCommand $ APISetChatTTL userId chatRef newTTL
|
||||
processChatCommand vr nm $ APISetChatTTL userId chatRef newTTL
|
||||
GetChatTTL chatName -> withUser' $ \user -> do
|
||||
-- TODO [knocking] support scope in CLI apis
|
||||
ChatRef cType chatId _ <- getChatRef user chatName
|
||||
@@ -1501,18 +1499,18 @@ processChatCommand' vr = \case
|
||||
lift $ setChatItemsExpiration user newTTL ttlCount
|
||||
ok user
|
||||
SetChatItemTTL newTTL_ -> withUser' $ \User {userId} -> do
|
||||
processChatCommand $ APISetChatItemTTL userId newTTL_
|
||||
processChatCommand vr nm $ APISetChatItemTTL userId newTTL_
|
||||
APIGetChatItemTTL userId -> withUserId' userId $ \user -> do
|
||||
ttl <- withFastStore' (`getChatItemTTL` user)
|
||||
pure $ CRChatItemTTL user (Just ttl)
|
||||
GetChatItemTTL -> withUser' $ \User {userId} -> do
|
||||
processChatCommand $ APIGetChatItemTTL userId
|
||||
processChatCommand vr nm $ APIGetChatItemTTL userId
|
||||
APISetNetworkConfig cfg -> withUser' $ \_ -> lift (withAgent' (`setNetworkConfig` cfg)) >> ok_
|
||||
APIGetNetworkConfig -> withUser' $ \_ ->
|
||||
CRNetworkConfig <$> lift getNetworkConfig
|
||||
SetNetworkConfig simpleNetCfg -> do
|
||||
cfg <- (`updateNetworkConfig` simpleNetCfg) <$> lift getNetworkConfig
|
||||
void . processChatCommand $ APISetNetworkConfig cfg
|
||||
void . processChatCommand vr nm $ APISetNetworkConfig cfg
|
||||
pure $ CRNetworkConfig cfg
|
||||
APISetNetworkInfo info -> lift (withAgent' (`setUserNetworkInfo` info)) >> ok_
|
||||
ReconnectAllServers -> withUser' $ \_ -> lift (withAgent' reconnectAllServers) >> ok_
|
||||
@@ -1677,11 +1675,11 @@ processChatCommand' vr = \case
|
||||
-- TODO GRModerator when most users migrate
|
||||
when (membershipRole >= GRAdmin) $ throwChatError $ CECantBlockMemberForSelf gInfo m showMessages
|
||||
let settings = (memberSettings m) {showMessages}
|
||||
processChatCommand $ APISetMemberSettings gId mId settings
|
||||
processChatCommand vr nm $ APISetMemberSettings gId mId settings
|
||||
ContactInfo cName -> withContactName cName APIContactInfo
|
||||
ShowGroupInfo gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIGroupInfo groupId
|
||||
processChatCommand vr nm $ APIGroupInfo groupId
|
||||
GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo
|
||||
ContactQueueInfo cName -> withContactName cName APIContactQueueInfo
|
||||
GroupMemberQueueInfo gName mName -> withMemberName gName mName APIGroupMemberQueueInfo
|
||||
@@ -1699,19 +1697,19 @@ processChatCommand' vr = \case
|
||||
EnableGroupMember gName mName -> withMemberName gName mName $ \gId mId -> APIEnableGroupMember gId mId
|
||||
ChatHelp section -> pure $ CRChatHelp section
|
||||
Welcome -> withUser $ pure . CRWelcome
|
||||
APIAddContact userId incognito -> withUserId userId $ \user -> procCmd $ do
|
||||
APIAddContact userId incognito -> withUserId userId $ \user -> do
|
||||
-- [incognito] generate profile for connection
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
userData <- contactShortLinkData (userProfileToSend user incognitoProfile Nothing False) Nothing
|
||||
-- TODO [certs rcv]
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation (Just userData) Nothing IKPQOn subMode
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True SCMInvitation (Just userData) Nothing IKPQOn subMode
|
||||
ccLink' <- shortenCreatedLink ccLink
|
||||
-- TODO PQ pass minVersion from the current range
|
||||
conn <- withFastStore' $ \db -> createDirectConnection db user connId ccLink' Nothing ConnNew incognitoProfile subMode initialChatVersion PQSupportOn
|
||||
pure $ CRInvitation user ccLink' conn
|
||||
AddContact incognito -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APIAddContact userId incognito
|
||||
processChatCommand vr nm $ APIAddContact userId incognito
|
||||
APISetConnectionIncognito connId incognito -> withUser $ \user@User {userId} -> do
|
||||
conn <- withFastStore $ \db -> getPendingContactConnection db userId connId
|
||||
let PendingContactConnection {pccConnStatus, customUserProfileId} = conn
|
||||
@@ -1748,7 +1746,7 @@ processChatCommand' vr = \case
|
||||
then Just <$> contactShortLinkData (userProfileToSend newUser Nothing Nothing False) Nothing
|
||||
else pure Nothing
|
||||
-- TODO [certs rcv]
|
||||
(agConnId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a (aUserId newUser) True SCMInvitation userData_ Nothing IKPQOn subMode
|
||||
(agConnId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId newUser) True SCMInvitation userData_ Nothing IKPQOn subMode
|
||||
ccLink' <- shortenCreatedLink ccLink
|
||||
conn' <- withFastStore' $ \db -> do
|
||||
deleteConnectionRecord db user connId
|
||||
@@ -1915,17 +1913,17 @@ processChatCommand' vr = \case
|
||||
APIListContacts userId -> withUserId userId $ \user ->
|
||||
CRContactsList user <$> withFastStore' (\db -> getUserContacts db vr user)
|
||||
ListContacts -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APIListContacts userId
|
||||
APICreateMyAddress userId -> withUserId userId $ \user -> procCmd $ do
|
||||
processChatCommand vr nm $ APIListContacts userId
|
||||
APICreateMyAddress userId -> withUserId userId $ \user -> do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
userData <- contactShortLinkData (userProfileToSend user Nothing Nothing False) Nothing
|
||||
-- TODO [certs rcv]
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact (Just userData) Nothing IKPQOn subMode
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True SCMContact (Just userData) Nothing IKPQOn subMode
|
||||
ccLink' <- shortenCreatedLink ccLink
|
||||
withFastStore $ \db -> createUserContactLink db user connId ccLink' subMode
|
||||
pure $ CRUserContactLinkCreated user ccLink'
|
||||
CreateMyAddress -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APICreateMyAddress userId
|
||||
processChatCommand vr nm $ APICreateMyAddress userId
|
||||
APIDeleteMyAddress userId -> withUserId userId $ \user@User {profile = p} -> do
|
||||
conn <- withFastStore $ \db -> getUserAddressConnection db vr user
|
||||
withChatLock "deleteMyAddress" $ do
|
||||
@@ -1938,11 +1936,11 @@ processChatCommand' vr = \case
|
||||
_ -> user
|
||||
pure $ CRUserContactLinkDeleted user'
|
||||
DeleteMyAddress -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APIDeleteMyAddress userId
|
||||
processChatCommand vr nm $ APIDeleteMyAddress userId
|
||||
APIShowMyAddress userId -> withUserId' userId $ \user ->
|
||||
CRUserContactLink user <$> withFastStore (`getUserAddress` user)
|
||||
ShowMyAddress -> withUser' $ \User {userId} ->
|
||||
processChatCommand $ APIShowMyAddress userId
|
||||
processChatCommand vr nm $ APIShowMyAddress userId
|
||||
APIAddMyAddressShortLink userId -> withUserId' userId $ \user ->
|
||||
CRUserContactLink user <$> (withFastStore (`getUserAddress` user) >>= setMyAddressData user)
|
||||
APISetProfileAddress userId False -> withUserId userId $ \user@User {profile = p} -> do
|
||||
@@ -1954,7 +1952,7 @@ processChatCommand' vr = \case
|
||||
let p' = (fromLocalProfile p :: Profile) {contactLink = Just $ profileContactLink ucl}
|
||||
updateProfile_ user p' True $ withFastStore' $ \db -> setUserProfileContactLink db user $ Just ucl
|
||||
SetProfileAddress onOff -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APISetProfileAddress userId onOff
|
||||
processChatCommand vr nm $ APISetProfileAddress userId onOff
|
||||
APISetAddressSettings userId settings@AddressSettings {businessAddress, autoAccept} -> withUserId userId $ \user -> do
|
||||
ucl@UserContactLink {userContactLinkId, shortLinkDataSet, addressSettings} <- withFastStore (`getUserAddress` user)
|
||||
forM_ autoAccept $ \AutoAccept {acceptIncognito} -> do
|
||||
@@ -1968,28 +1966,28 @@ processChatCommand' vr = \case
|
||||
withFastStore' $ \db -> updateUserAddressSettings db userContactLinkId settings
|
||||
pure $ CRUserContactLinkUpdated user ucl''
|
||||
SetAddressSettings settings -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APISetAddressSettings userId settings
|
||||
processChatCommand vr nm $ APISetAddressSettings userId settings
|
||||
AcceptContact incognito cName -> withUser $ \User {userId} -> do
|
||||
connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName
|
||||
processChatCommand $ APIAcceptContact incognito connReqId
|
||||
processChatCommand vr nm $ APIAcceptContact incognito connReqId
|
||||
RejectContact cName -> withUser $ \User {userId} -> do
|
||||
connReqId <- withFastStore $ \db -> getContactRequestIdByName db userId cName
|
||||
processChatCommand $ APIRejectContact connReqId
|
||||
processChatCommand vr nm $ APIRejectContact connReqId
|
||||
ForwardMessage toChatName fromContactName forwardedMsg -> withUser $ \user -> do
|
||||
contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName
|
||||
forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg
|
||||
toChatRef <- getChatRef user toChatName
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId Nothing) (forwardedItemId :| []) Nothing
|
||||
processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId Nothing) (forwardedItemId :| []) Nothing
|
||||
ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName
|
||||
forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg
|
||||
toChatRef <- getChatRef user toChatName
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId Nothing) (forwardedItemId :| []) Nothing
|
||||
processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId Nothing) (forwardedItemId :| []) Nothing
|
||||
ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg
|
||||
toChatRef <- getChatRef user toChatName
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing
|
||||
processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing
|
||||
SendMessage sendName msg -> withUser $ \user -> do
|
||||
let mc = MCText msg
|
||||
case sendName of
|
||||
@@ -1997,13 +1995,13 @@ processChatCommand' vr = \case
|
||||
withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case
|
||||
Right ctId -> do
|
||||
let sendRef = SRDirect ctId
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
Left _ ->
|
||||
withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
|
||||
Right [(gInfo, member)] -> do
|
||||
let GroupInfo {localDisplayName = gName} = gInfo
|
||||
GroupMember {localDisplayName = mName} = member
|
||||
processChatCommand $ SendMemberContactMessage gName mName msg
|
||||
processChatCommand vr nm $ SendMemberContactMessage gName mName msg
|
||||
Right (suspectedMember : _) ->
|
||||
throwChatError $ CEContactNotFound name (Just suspectedMember)
|
||||
_ ->
|
||||
@@ -2016,10 +2014,10 @@ processChatCommand' vr = \case
|
||||
GCSMemberSupport <$> mapM (getGroupMemberIdByName db user gId) mName_
|
||||
(gId,cScope_,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let sendRef = SRGroup gId cScope_
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
processChatCommand vr nm $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
SNLocal -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand $ APICreateChatItems folderId [composedMessage Nothing mc]
|
||||
processChatCommand vr nm $ APICreateChatItems folderId [composedMessage Nothing mc]
|
||||
SendMemberContactMessage gName mName msg -> withUser $ \user -> do
|
||||
(gId, mId) <- getGroupAndMemberId user gName mName
|
||||
m <- withFastStore $ \db -> getGroupMember db vr user gId mId
|
||||
@@ -2029,22 +2027,22 @@ processChatCommand' vr = \case
|
||||
g <- withFastStore $ \db -> getGroupInfo db vr user gId
|
||||
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwCmdError "direct messages not allowed"
|
||||
toView $ CEvtNoMemberContactCreating user g m
|
||||
processChatCommand (APICreateMemberContact gId mId) >>= \case
|
||||
processChatCommand vr nm (APICreateMemberContact gId mId) >>= \case
|
||||
CRNewMemberContact _ ct@Contact {contactId} _ _ -> do
|
||||
toViewTE $ TENewMemberContact user ct g m
|
||||
processChatCommand $ APISendMemberContactInvitation contactId (Just mc)
|
||||
processChatCommand vr nm $ APISendMemberContactInvitation contactId (Just mc)
|
||||
cr -> pure cr
|
||||
Just ctId -> do
|
||||
let sendRef = SRDirect ctId
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
SendLiveMessage chatName msg -> withUser $ \user -> do
|
||||
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
|
||||
withSendRef chatRef $ \sendRef -> do
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
processChatCommand vr nm $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
SendMessageBroadcast mc -> withUser $ \user -> do
|
||||
contacts <- withFastStore' $ \db -> getUserContacts db vr user
|
||||
withChatLock "sendMessageBroadcast" . procCmd $ do
|
||||
withChatLock "sendMessageBroadcast" $ do
|
||||
let ctConns_ = L.nonEmpty $ foldr addContactConn [] contacts
|
||||
case ctConns_ of
|
||||
Nothing -> do
|
||||
@@ -2085,28 +2083,28 @@ processChatCommand' vr = \case
|
||||
contactId <- withFastStore $ \db -> getContactIdByName db user cName
|
||||
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APISendMessages (SRDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
|
||||
processChatCommand vr nm $ APISendMessages (SRDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
|
||||
DeleteMessage chatName deletedMsg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
|
||||
processChatCommand $ APIDeleteChatItem chatRef (deletedItemId :| []) CIDMBroadcast
|
||||
processChatCommand vr nm $ APIDeleteChatItem chatRef (deletedItemId :| []) CIDMBroadcast
|
||||
DeleteMemberMessage gName mName deletedMsg -> withUser $ \user -> do
|
||||
gId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg
|
||||
processChatCommand $ APIDeleteMemberChatItem gId (deletedItemId :| [])
|
||||
processChatCommand vr nm $ APIDeleteMemberChatItem gId (deletedItemId :| [])
|
||||
EditMessage chatName editedMsg msg -> withUser $ \user -> do
|
||||
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
|
||||
editedItemId <- getSentChatItemIdByText user chatRef editedMsg
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APIUpdateChatItem chatRef editedItemId False $ UpdatedMessage mc mentions
|
||||
processChatCommand vr nm $ APIUpdateChatItem chatRef editedItemId False $ UpdatedMessage mc mentions
|
||||
UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do
|
||||
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APIUpdateChatItem chatRef chatItemId live $ UpdatedMessage mc mentions
|
||||
processChatCommand vr nm $ APIUpdateChatItem chatRef chatItemId live $ UpdatedMessage mc mentions
|
||||
ReactToMessage add reaction chatName msg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatItemId <- getChatItemIdByText user chatRef msg
|
||||
processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction
|
||||
processChatCommand vr nm $ APIChatItemReaction chatRef chatItemId add reaction
|
||||
APINewGroup userId incognito gProfile@GroupProfile {displayName} -> withUserId userId $ \user -> do
|
||||
checkValidName displayName
|
||||
gVar <- asks random
|
||||
@@ -2118,7 +2116,7 @@ processChatCommand' vr = \case
|
||||
createGroupFeatureItems user cd CISndGroupFeature gInfo
|
||||
pure $ CRGroupCreated user gInfo
|
||||
NewGroup incognito gProfile -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APINewGroup userId incognito gProfile
|
||||
processChatCommand vr nm $ APINewGroup userId incognito gProfile
|
||||
APIAddMember groupId contactId memRole -> withUser $ \user -> withGroupLock "addMember" groupId $ do
|
||||
-- TODO for large groups: no need to load all members to determine if contact is a member
|
||||
(group, contact) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db vr user contactId
|
||||
@@ -2136,7 +2134,7 @@ processChatCommand' vr = \case
|
||||
gVar <- asks random
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- TODO [certs rcv]
|
||||
(agentConnId, (CCLink cReq _, _serviceId)) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing Nothing IKPQOff subMode
|
||||
(agentConnId, (CCLink cReq _, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True SCMInvitation Nothing Nothing IKPQOff subMode
|
||||
member <- withFastStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode
|
||||
sendInvitation member cReq
|
||||
pure $ CRSentGroupInvitation user gInfo contact member
|
||||
@@ -2150,7 +2148,7 @@ processChatCommand' vr = \case
|
||||
Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName
|
||||
| otherwise -> throwChatError $ CEGroupDuplicateMember cName
|
||||
APIJoinGroup groupId enableNtfs -> withUser $ \user@User {userId} -> do
|
||||
withGroupLock "joinGroup" groupId . procCmd $ do
|
||||
withGroupLock "joinGroup" groupId $ do
|
||||
(invitation, ct) <- withFastStore $ \db -> do
|
||||
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId
|
||||
(inv,) <$> getContactViaMember db vr user fromMember
|
||||
@@ -2173,7 +2171,7 @@ processChatCommand' vr = \case
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
-- MFAll is default for new groups
|
||||
unless (enableNtfs == MFAll) $ updateGroupSettings db user groupId chatSettings {enableNtfs}
|
||||
void (withAgent $ \a -> joinConnection a (aUserId user) agentConnId (enableNtfs /= MFNone) connRequest dm PQSupportOff subMode)
|
||||
void (withAgent $ \a -> joinConnection a nm (aUserId user) agentConnId (enableNtfs /= MFNone) connRequest dm PQSupportOff subMode)
|
||||
`catchChatError` \e -> do
|
||||
withFastStore' $ \db -> do
|
||||
updateGroupMemberStatus db userId fromMember GSMemInvited
|
||||
@@ -2247,7 +2245,7 @@ processChatCommand' vr = \case
|
||||
(gInfo', m') <- withFastStore' $ \db -> deleteGroupMemberSupportChat db user gInfo m
|
||||
pure $ CRMemberSupportChatDeleted user gInfo' m'
|
||||
APIMembersRole groupId memberIds newRole -> withUser $ \user ->
|
||||
withGroupLock "memberRole" groupId . procCmd $ do
|
||||
withGroupLock "memberRole" groupId $ do
|
||||
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
when (selfSelected gInfo) $ throwCmdError "can't change role for self"
|
||||
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members
|
||||
@@ -2315,7 +2313,7 @@ processChatCommand' vr = \case
|
||||
updateGroupMemberRole db user m newRole
|
||||
pure (m :: GroupMember) {memberRole = newRole}
|
||||
APIBlockMembersForAll groupId memberIds blockFlag -> withUser $ \user ->
|
||||
withGroupLock "blockForAll" groupId . procCmd $ do
|
||||
withGroupLock "blockForAll" groupId $ do
|
||||
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
when (selfSelected gInfo) $ throwCmdError "can't block/unblock self"
|
||||
let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members
|
||||
@@ -2361,7 +2359,7 @@ processChatCommand' vr = \case
|
||||
ts = ciContentTexts content
|
||||
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
|
||||
APIRemoveMembers {groupId, groupMemberIds, withMessages} -> withUser $ \user ->
|
||||
withGroupLock "removeMembers" groupId . procCmd $ do
|
||||
withGroupLock "removeMembers" groupId $ do
|
||||
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin) = selectMembers members
|
||||
memCount = S.size groupMemberIds
|
||||
@@ -2447,7 +2445,7 @@ processChatCommand' vr = \case
|
||||
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
withGroupLock "leaveGroup" groupId . procCmd $ do
|
||||
withGroupLock "leaveGroup" groupId $ do
|
||||
cancelFilesInProgress user filesInfo
|
||||
let recipients = filter memberCurrentOrPending members
|
||||
msg <- sendGroupMessage' user gInfo recipients XGrpLeave
|
||||
@@ -2471,10 +2469,10 @@ processChatCommand' vr = \case
|
||||
-- ok_ -- CRGroupConversationsDeleted
|
||||
AddMember gName cName memRole -> withUser $ \user -> do
|
||||
(groupId, contactId) <- withFastStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName
|
||||
processChatCommand $ APIAddMember groupId contactId memRole
|
||||
processChatCommand vr nm $ APIAddMember groupId contactId memRole
|
||||
JoinGroup gName enableNtfs -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIJoinGroup groupId enableNtfs
|
||||
processChatCommand vr nm $ APIJoinGroup groupId enableNtfs
|
||||
AcceptMember gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIAcceptMember gId gMemberId memRole
|
||||
MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMembersRole gId [gMemberId] memRole
|
||||
BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMembersForAll gId [gMemberId] blocked
|
||||
@@ -2483,19 +2481,19 @@ processChatCommand' vr = \case
|
||||
gId <- getGroupIdByName db user gName
|
||||
gMemberIds <- S.fromList <$> mapM (getGroupMemberIdByName db user gId) (S.toList gMemberNames)
|
||||
pure (gId, gMemberIds)
|
||||
processChatCommand $ APIRemoveMembers gId gMemberIds withMessages
|
||||
processChatCommand vr nm $ APIRemoveMembers gId gMemberIds withMessages
|
||||
LeaveGroup gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APILeaveGroup groupId
|
||||
processChatCommand vr nm $ APILeaveGroup groupId
|
||||
DeleteGroup gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIDeleteChat (ChatRef CTGroup groupId Nothing) (CDMFull True)
|
||||
processChatCommand vr nm $ APIDeleteChat (ChatRef CTGroup groupId Nothing) (CDMFull True)
|
||||
ClearGroup gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIClearChat (ChatRef CTGroup groupId Nothing)
|
||||
processChatCommand vr nm $ APIClearChat (ChatRef CTGroup groupId Nothing)
|
||||
ListMembers gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIListMembers groupId
|
||||
processChatCommand vr nm $ APIListMembers groupId
|
||||
ListMemberSupportChats gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
@@ -2505,7 +2503,7 @@ processChatCommand' vr = \case
|
||||
CRGroupsList user <$> withFastStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_)
|
||||
ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
|
||||
ct_ <- forM cName_ $ \cName -> withFastStore $ \db -> getContactByName db vr user cName
|
||||
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
|
||||
processChatCommand vr nm $ APIListGroups userId (contactId' <$> ct_) search_
|
||||
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
|
||||
g <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
runUpdateGroupProfile user g p'
|
||||
@@ -2526,7 +2524,7 @@ processChatCommand' vr = \case
|
||||
userData <- groupShortLinkData groupProfile
|
||||
let crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
-- TODO [certs rcv]
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact (Just userData) (Just crClientData) IKPQOff subMode
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True SCMContact (Just userData) (Just crClientData) IKPQOff subMode
|
||||
ccLink' <- createdGroupLink <$> shortenCreatedLink ccLink
|
||||
gLink <- withFastStore $ \db -> createGroupLink db user gInfo connId ccLink' groupLinkId mRole subMode
|
||||
pure $ CRGroupLinkCreated user gInfo gLink
|
||||
@@ -2565,7 +2563,7 @@ processChatCommand' vr = \case
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- TODO PQ should negotitate contact connection with PQSupportOn?
|
||||
-- TODO [certs rcv]
|
||||
(connId, (CCLink cReq _, _serviceId)) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing Nothing IKPQOff subMode
|
||||
(connId, (CCLink cReq _, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True SCMInvitation Nothing Nothing IKPQOff subMode
|
||||
-- [incognito] reuse membership incognito profile
|
||||
ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode
|
||||
-- TODO not sure it is correct to set connections status here?
|
||||
@@ -2589,16 +2587,16 @@ processChatCommand' vr = \case
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
CreateGroupLink gName mRole -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APICreateGroupLink groupId mRole
|
||||
processChatCommand vr nm $ APICreateGroupLink groupId mRole
|
||||
GroupLinkMemberRole gName mRole -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIGroupLinkMemberRole groupId mRole
|
||||
processChatCommand vr nm $ APIGroupLinkMemberRole groupId mRole
|
||||
DeleteGroupLink gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIDeleteGroupLink groupId
|
||||
processChatCommand vr nm $ APIDeleteGroupLink groupId
|
||||
ShowGroupLink gName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIGetGroupLink groupId
|
||||
processChatCommand vr nm $ APIGetGroupLink groupId
|
||||
SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do
|
||||
(groupId, quotedItemId, mentions) <-
|
||||
withFastStore $ \db -> do
|
||||
@@ -2606,10 +2604,10 @@ processChatCommand' vr = \case
|
||||
qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
|
||||
(gId, qiId,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APISendMessages (SRGroup groupId Nothing) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
processChatCommand vr nm $ APISendMessages (SRGroup groupId Nothing) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
ClearNoteFolder -> withUser $ \user -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand $ APIClearChat (ChatRef CTLocal folderId Nothing)
|
||||
processChatCommand vr nm $ APIClearChat (ChatRef CTLocal folderId Nothing)
|
||||
LastChats count_ -> withUser' $ \user -> do
|
||||
let count = fromMaybe 5000 count_
|
||||
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters)
|
||||
@@ -2617,14 +2615,14 @@ processChatCommand' vr = \case
|
||||
pure $ CRChats previews
|
||||
LastMessages (Just chatName) count search -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatResp <- processChatCommand $ APIGetChat chatRef Nothing (CPLast count) search
|
||||
chatResp <- processChatCommand vr nm $ APIGetChat chatRef Nothing (CPLast count) search
|
||||
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
|
||||
LastMessages Nothing count search -> withUser $ \user -> do
|
||||
chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast count) search
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
LastChatItemId (Just chatName) index -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatResp <- processChatCommand (APIGetChat chatRef Nothing (CPLast $ index + 1) Nothing)
|
||||
chatResp <- processChatCommand vr nm $ APIGetChat chatRef Nothing (CPLast $ index + 1) Nothing
|
||||
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp)
|
||||
LastChatItemId Nothing index -> withUser $ \user -> do
|
||||
chatItems <- withFastStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing
|
||||
@@ -2640,14 +2638,14 @@ processChatCommand' vr = \case
|
||||
ShowChatItemInfo chatName msg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
itemId <- getChatItemIdByText user chatRef msg
|
||||
processChatCommand $ APIGetChatItemInfo chatRef itemId
|
||||
processChatCommand vr nm $ APIGetChatItemInfo chatRef itemId
|
||||
ShowLiveItems on -> withUser $ \_ ->
|
||||
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
|
||||
SendFile chatName f -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
case chatRef of
|
||||
ChatRef CTLocal folderId _ -> processChatCommand $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
|
||||
_ -> withSendRef chatRef $ \sendRef -> processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")]
|
||||
ChatRef CTLocal folderId _ -> processChatCommand vr nm $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
|
||||
_ -> withSendRef chatRef $ \sendRef -> processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")]
|
||||
SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
withSendRef chatRef $ \sendRef -> do
|
||||
@@ -2656,25 +2654,25 @@ processChatCommand' vr = \case
|
||||
fileSize <- getFileSize filePath
|
||||
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
||||
-- TODO include file description for preview
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
|
||||
processChatCommand vr nm $ 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 -> 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
|
||||
withFileLock "receiveFile" fileId $ do
|
||||
(user, ft@RcvFileTransfer {fileStatus}) <- withStore (`getRcvFileTransferById` fileId)
|
||||
encrypt <- (`fromMaybe` encrypted_) <$> chatReadVar encryptLocalFiles
|
||||
ft' <- (if encrypt && fileStatus == RFSNew then setFileToEncrypt else pure) ft
|
||||
receiveFile' user ft' userApprovedRelays rcvInline_ filePath_
|
||||
SetFileToReceive fileId userApprovedRelays encrypted_ -> withUser $ \_ -> do
|
||||
withFileLock "setFileToReceive" fileId . procCmd $ do
|
||||
withFileLock "setFileToReceive" fileId $ do
|
||||
encrypt <- (`fromMaybe` encrypted_) <$> chatReadVar encryptLocalFiles
|
||||
cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing
|
||||
withStore' $ \db -> setRcvFileToReceive db fileId userApprovedRelays cfArgs
|
||||
ok_
|
||||
CancelFile fileId -> withUser $ \user@User {userId} ->
|
||||
withFileLock "cancelFile" fileId . procCmd $
|
||||
withFileLock "cancelFile" fileId $
|
||||
withFastStore (\db -> getFileTransfer db user fileId) >>= \case
|
||||
FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts
|
||||
| cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled"
|
||||
@@ -2864,9 +2862,6 @@ processChatCommand' vr = \case
|
||||
-- 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
|
||||
{-# INLINE procCmd #-}
|
||||
ok_ = pure $ CRCmdOk Nothing
|
||||
ok = pure . CRCmdOk . Just
|
||||
getChatRef :: User -> ChatName -> CM ChatRef
|
||||
@@ -2896,13 +2891,13 @@ processChatCommand' vr = \case
|
||||
checkStoreNotChanged :: CM ChatResponse -> CM ChatResponse
|
||||
checkStoreNotChanged = ifM (asks chatStoreChanged >>= readTVarIO) (throwChatError CEChatStoreChanged)
|
||||
withUserName :: UserName -> (UserId -> ChatCommand) -> CM ChatResponse
|
||||
withUserName uName cmd = withFastStore (`getUserIdByName` uName) >>= processChatCommand . cmd
|
||||
withUserName uName cmd = withFastStore (`getUserIdByName` uName) >>= processChatCommand vr nm . cmd
|
||||
withContactName :: ContactName -> (ContactId -> ChatCommand) -> CM ChatResponse
|
||||
withContactName cName cmd = withUser $ \user ->
|
||||
withFastStore (\db -> getContactIdByName db user cName) >>= processChatCommand . cmd
|
||||
withFastStore (\db -> getContactIdByName db user cName) >>= processChatCommand vr nm . cmd
|
||||
withMemberName :: GroupName -> ContactName -> (GroupId -> GroupMemberId -> ChatCommand) -> CM ChatResponse
|
||||
withMemberName gName mName cmd = withUser $ \user ->
|
||||
getGroupAndMemberId user gName mName >>= processChatCommand . uncurry cmd
|
||||
getGroupAndMemberId user gName mName >>= processChatCommand vr nm . uncurry cmd
|
||||
getConnectionCode :: ConnId -> CM Text
|
||||
getConnectionCode connId = verificationCode <$> withAgent (`getConnectionRatchetAdHash` connId)
|
||||
verifyConnectionCode :: User -> Connection -> Maybe Text -> CM ChatResponse
|
||||
@@ -2955,7 +2950,7 @@ processChatCommand' vr = \case
|
||||
joinPreparedConn conn incognitoProfile chatV = do
|
||||
let profileToSend = userProfileToSend user incognitoProfile Nothing False
|
||||
dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend
|
||||
(sqSecured, _serviceId) <- withAgent $ \a -> joinConnection a (aUserId user) (aConnId conn) True cReq dm pqSup' subMode
|
||||
(sqSecured, _serviceId) <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode
|
||||
let newStatus = if sqSecured then ConnSndReady else ConnJoined
|
||||
conn' <- withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared newStatus
|
||||
pure (conn', incognitoProfile)
|
||||
@@ -3049,7 +3044,7 @@ processChatCommand' vr = \case
|
||||
let profileToSend = userProfileToSend user incognitoProfile Nothing inGroup
|
||||
dm <- encodeConnInfoPQ pqSup chatV (XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_)
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
void $ withAgent $ \a -> joinConnection a (aUserId user) (aConnId conn) True cReq dm pqSup subMode
|
||||
void $ withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup subMode
|
||||
withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared ConnJoined
|
||||
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
|
||||
contactMember Contact {contactId} =
|
||||
@@ -3073,7 +3068,7 @@ processChatCommand' vr = \case
|
||||
contacts <- withFastStore' $ \db -> getUserContacts db vr user
|
||||
user' <- updateUser
|
||||
asks currentUser >>= atomically . (`writeTVar` Just user')
|
||||
withChatLock "updateProfile" . procCmd $ do
|
||||
withChatLock "updateProfile" $ do
|
||||
when shouldUpdateAddressData $ setMyAddressData' user'
|
||||
summary <- sendUpdateToContacts user' contacts
|
||||
pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' summary
|
||||
@@ -3126,7 +3121,7 @@ processChatCommand' vr = \case
|
||||
let shortLinkProfile = userProfileToSend user Nothing Nothing False
|
||||
-- TODO [short links] do not save address to server if data did not change, spinners, error handling
|
||||
userData <- contactShortLinkData shortLinkProfile $ Just addressSettings
|
||||
sLnk <- shortenShortLink' =<< withAgent (\a -> setConnShortLink a (aConnId conn) SCMContact userData Nothing)
|
||||
sLnk <- shortenShortLink' =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userData Nothing)
|
||||
withFastStore' $ \db -> setUserContactLinkShortLink db userContactLinkId sLnk
|
||||
let autoAccept' = (\aa -> aa {acceptIncognito = False}) <$> autoAccept addressSettings
|
||||
ucl' = (ucl :: UserContactLink) {connLinkContact = CCLink connFullLink (Just sLnk), shortLinkDataSet = True, addressSettings = addressSettings {autoAccept = autoAccept'}}
|
||||
@@ -3186,7 +3181,7 @@ processChatCommand' vr = \case
|
||||
conn <- withFastStore $ \db -> getGroupLinkConnection db vr user gInfo
|
||||
userData <- groupShortLinkData groupProfile
|
||||
let crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
sLnk <- shortenShortLink' . toShortGroupLink =<< withAgent (\a -> setConnShortLink a (aConnId conn) SCMContact userData (Just crClientData))
|
||||
sLnk <- shortenShortLink' . toShortGroupLink =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userData (Just crClientData))
|
||||
gLink' <- withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk
|
||||
pure $ CRGroupLink user gInfo gLink'
|
||||
checkValidName :: GroupName -> CM ()
|
||||
@@ -3289,7 +3284,7 @@ processChatCommand' vr = \case
|
||||
FTSnd {fileTransferMeta = FileTransferMeta {filePath, xftpSndFile}} -> forward filePath $ xftpSndFile >>= \XFTPSndFile {cryptoArgs} -> cryptoArgs
|
||||
_ -> throwChatError CEFileNotReceived {fileId}
|
||||
where
|
||||
forward path cfArgs = processChatCommand . sendCommand chatName $ CryptoFile path cfArgs
|
||||
forward path cfArgs = processChatCommand vr nm $ sendCommand chatName $ CryptoFile path cfArgs
|
||||
getGroupAndMemberId :: User -> GroupName -> ContactName -> CM (GroupId, GroupMemberId)
|
||||
getGroupAndMemberId user gName groupMemberName =
|
||||
withStore $ \db -> do
|
||||
@@ -3381,7 +3376,7 @@ processChatCommand' vr = \case
|
||||
GroupInfo {chatSettings} <- getGroupInfo db vr user gId
|
||||
pure (gId, chatSettings)
|
||||
_ -> throwCmdError "not supported"
|
||||
processChatCommand $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings
|
||||
processChatCommand vr nm $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings
|
||||
connectPlan :: User -> AConnectionLink -> CM (ACreatedConnLink, ConnectionPlan)
|
||||
connectPlan user (ACL SCMInvitation cLink) = case cLink of
|
||||
CLFull cReq -> invitationReqAndPlan cReq Nothing Nothing
|
||||
@@ -3451,8 +3446,8 @@ processChatCommand' vr = \case
|
||||
case plan of CPError e -> eToView e; _ -> pure ()
|
||||
case plan of
|
||||
CPContactAddress (CAPContactViaAddress Contact {contactId}) ->
|
||||
processChatCommand $ APIConnectContactViaAddress userId incognito contactId
|
||||
_ -> processChatCommand $ APIConnect userId incognito ccLink
|
||||
processChatCommand vr nm $ APIConnectContactViaAddress userId incognito contactId
|
||||
_ -> processChatCommand vr nm $ APIConnect userId incognito ccLink
|
||||
| otherwise = pure $ CRConnectionPlan user ccLink plan
|
||||
invitationRequestPlan :: User -> ConnReqInvitation -> Maybe ContactShortLinkData -> CM ConnectionPlan
|
||||
invitationRequestPlan user cReq contactSLinkData_ = do
|
||||
@@ -3539,7 +3534,7 @@ processChatCommand' vr = \case
|
||||
getShortLinkConnReq :: User -> ConnShortLink m -> CM (ConnectionRequestUri m, ConnLinkData m)
|
||||
getShortLinkConnReq user l = do
|
||||
l' <- restoreShortLink' l
|
||||
(cReq, cData) <- withAgent (\a -> getConnShortLink a (aUserId user) l')
|
||||
(cReq, cData) <- withAgent $ \a -> getConnShortLink a nm (aUserId user) l'
|
||||
case cData of
|
||||
ContactLinkData {direct} | not direct -> throwChatError CEUnsupportedConnReq
|
||||
_ -> pure ()
|
||||
@@ -3593,7 +3588,7 @@ processChatCommand' vr = \case
|
||||
updatePCCShortLinkData conn@PendingContactConnection {connLinkInv} profile =
|
||||
forM (connShortLink =<< connLinkInv) $ \_ -> do
|
||||
userData <- contactShortLinkData profile Nothing
|
||||
shortenShortLink' =<< withAgent (\a -> setConnShortLink a (aConnId' conn) SCMInvitation userData Nothing)
|
||||
shortenShortLink' =<< withAgent (\a -> setConnShortLink a nm (aConnId' conn) SCMInvitation userData Nothing)
|
||||
shortenShortLink' :: ConnShortLink m -> CM (ConnShortLink m)
|
||||
shortenShortLink' l = (`shortenShortLink` l) <$> asks (shortLinkPresetServers . config)
|
||||
shortenCreatedLink :: CreatedConnLink m -> CM (CreatedConnLink m)
|
||||
@@ -3890,7 +3885,7 @@ processChatCommand' vr = \case
|
||||
(CISndMsgContent mc, f, itemForwarded, ts)
|
||||
getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do
|
||||
msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId)
|
||||
CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId)
|
||||
CRQueueInfo user msgInfo <$> withAgent (\a -> getConnectionQueueInfo a nm acId)
|
||||
withSendRef :: ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse
|
||||
withSendRef chatRef a = case chatRef of
|
||||
ChatRef CTDirect cId _ -> a $ SRDirect cId
|
||||
|
||||
@@ -84,7 +84,7 @@ import Simplex.Messaging.Agent.Lock (withLock)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Client (NetworkConfig (..))
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
@@ -881,8 +881,8 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
|
||||
-- - xContactId is set on the contact at the first acceptance attempt, not after accept success, which prevents profile updates after such attempt.
|
||||
-- It may be reasonable to set it when contact is first prepared, but then we can't use it to ignore requests after acceptance,
|
||||
-- and it may lead to race conditions with XInfo events.
|
||||
acceptContactRequest :: User -> UserContactRequest -> IncognitoEnabled -> CM (Contact, Connection, SndQueueSecured)
|
||||
acceptContactRequest user@User {userId} UserContactRequest {agentInvitationId = AgentInvId invId, contactId_, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId_, xContactId, pqSupport} incognito = do
|
||||
acceptContactRequest :: NetworkRequestMode -> User -> UserContactRequest -> IncognitoEnabled -> CM (Contact, Connection, SndQueueSecured)
|
||||
acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId = AgentInvId invId, contactId_, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId_, xContactId, pqSupport} incognito = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let pqSup = PQSupportOn
|
||||
pqSup' = pqSup `CR.pqSupportAnd` pqSupport
|
||||
@@ -912,7 +912,7 @@ acceptContactRequest user@User {userId} UserContactRequest {agentInvitationId =
|
||||
let profileToSend = userProfileToSend' user incognitoProfile (Just ct) False
|
||||
dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend
|
||||
-- TODO [certs rcv]
|
||||
(ct,conn,) . fst <$> withAgent (\a -> acceptContact a (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
|
||||
(ct,conn,) . fst <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
|
||||
|
||||
acceptContactRequestAsync :: User -> Int64 -> Contact -> UserContactRequest -> Maybe IncognitoProfile -> CM Contact
|
||||
acceptContactRequestAsync
|
||||
|
||||
@@ -97,8 +97,12 @@ foreign export ccall "chat_reopen_store" cChatReopenStore :: StablePtr ChatContr
|
||||
|
||||
foreign export ccall "chat_send_cmd" cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
|
||||
|
||||
foreign export ccall "chat_send_cmd_retry" cChatSendCmdRetry :: StablePtr ChatController -> CString -> CInt -> IO CJSONString
|
||||
|
||||
foreign export ccall "chat_send_remote_cmd" cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
|
||||
|
||||
foreign export ccall "chat_send_remote_cmd_retry" cChatSendRemoteCmdRetry :: StablePtr ChatController -> CInt -> CString -> CInt -> IO CJSONString
|
||||
|
||||
foreign export ccall "chat_recv_msg" cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
|
||||
|
||||
foreign export ccall "chat_recv_msg_wait" cChatRecvMsgWait :: StablePtr ChatController -> CInt -> IO CJSONString
|
||||
@@ -155,20 +159,30 @@ cChatReopenStore cPtr = do
|
||||
c <- deRefStablePtr cPtr
|
||||
newCAString =<< chatReopenStore c
|
||||
|
||||
-- | send command to chat (same syntax as in terminal for now)
|
||||
-- | send command to chat
|
||||
cChatSendCmd :: StablePtr ChatController -> CString -> IO CJSONString
|
||||
cChatSendCmd cPtr cCmd = do
|
||||
cChatSendCmd cPtr cCmd = cChatSendCmdRetry cPtr cCmd 0
|
||||
|
||||
-- | send command to chat with retry count
|
||||
cChatSendCmdRetry :: StablePtr ChatController -> CString -> CInt -> IO CJSONString
|
||||
cChatSendCmdRetry cPtr cCmd cRetryNum = do
|
||||
c <- deRefStablePtr cPtr
|
||||
cmd <- B.packCString cCmd
|
||||
newCStringFromLazyBS =<< chatSendCmd c cmd
|
||||
newCStringFromLazyBS =<< chatSendRemoteCmdRetry c Nothing cmd (fromIntegral cRetryNum)
|
||||
{-# INLINE cChatSendCmdRetry #-}
|
||||
|
||||
-- | send command to chat (same syntax as in terminal for now)
|
||||
-- | send remote command to chat
|
||||
cChatSendRemoteCmd :: StablePtr ChatController -> CInt -> CString -> IO CJSONString
|
||||
cChatSendRemoteCmd cPtr cRemoteHostId cCmd = do
|
||||
cChatSendRemoteCmd cPtr cRhId cCmd = cChatSendRemoteCmdRetry cPtr cRhId cCmd 0
|
||||
|
||||
-- | send remote command to chat with retry count
|
||||
cChatSendRemoteCmdRetry :: StablePtr ChatController -> CInt -> CString -> CInt -> IO CJSONString
|
||||
cChatSendRemoteCmdRetry cPtr cRemoteHostId cCmd cRetryNum = do
|
||||
c <- deRefStablePtr cPtr
|
||||
cmd <- B.packCString cCmd
|
||||
let rhId = Just $ fromIntegral cRemoteHostId
|
||||
newCStringFromLazyBS =<< chatSendRemoteCmd c rhId cmd
|
||||
newCStringFromLazyBS =<< chatSendRemoteCmdRetry c rhId cmd (fromIntegral cRetryNum)
|
||||
{-# INLINE cChatSendRemoteCmdRetry #-}
|
||||
|
||||
-- | receive message from chat (blocking)
|
||||
cChatRecvMsg :: StablePtr ChatController -> IO CJSONString
|
||||
@@ -294,10 +308,11 @@ handleErr :: IO () -> IO String
|
||||
handleErr a = (a $> "") `catch` (pure . show @SomeException)
|
||||
|
||||
chatSendCmd :: ChatController -> B.ByteString -> IO JSONByteString
|
||||
chatSendCmd cc = chatSendRemoteCmd cc Nothing
|
||||
chatSendCmd cc cmd = chatSendRemoteCmdRetry cc Nothing cmd 0
|
||||
{-# INLINE chatSendCmd #-}
|
||||
|
||||
chatSendRemoteCmd :: ChatController -> Maybe RemoteHostId -> B.ByteString -> IO JSONByteString
|
||||
chatSendRemoteCmd cc rh s = J.encode . eitherToResult rh <$> runReaderT (execChatCommand rh s) cc
|
||||
chatSendRemoteCmdRetry :: ChatController -> Maybe RemoteHostId -> B.ByteString -> Int -> IO JSONByteString
|
||||
chatSendRemoteCmdRetry cc rh s retryNum = J.encode . eitherToResult rh <$> runReaderT (execChatCommand rh s retryNum) cc
|
||||
|
||||
chatRecvMsg :: ChatController -> IO JSONByteString
|
||||
chatRecvMsg ChatController {outputQ} = J.encode . uncurry eitherToResult <$> readChatResponse
|
||||
@@ -312,6 +327,7 @@ chatRecvMsgWait cc time = fromMaybe "" <$> timeout time (chatRecvMsg cc)
|
||||
|
||||
chatParseMarkdown :: ByteString -> JSONByteString
|
||||
chatParseMarkdown = J.encode . ParsedMarkdown . parseMaybeMarkdownList . safeDecodeUtf8
|
||||
{-# INLINE chatParseMarkdown #-}
|
||||
|
||||
chatParseServer :: ByteString -> JSONByteString
|
||||
chatParseServer = J.encode . toServerAddress . strDecode
|
||||
|
||||
+14
-14
@@ -366,8 +366,8 @@ getRemoteFile rhId rf = do
|
||||
createDirectoryIfMissing True dir
|
||||
liftRH rhId $ remoteGetFile c dir rf
|
||||
|
||||
processRemoteCommand :: RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteString -> CM ChatResponse
|
||||
processRemoteCommand remoteHostId c cmd s = case cmd of
|
||||
processRemoteCommand :: RemoteHostId -> RemoteHostClient -> ChatCommand -> ByteString -> Int -> CM ChatResponse
|
||||
processRemoteCommand remoteHostId c cmd s retryNum = case cmd of
|
||||
SendFile chatName f -> sendFile "/f" chatName f
|
||||
SendImage chatName f -> sendFile "/img" chatName f
|
||||
_ -> chatRemoteSend s
|
||||
@@ -380,7 +380,7 @@ processRemoteCommand remoteHostId c cmd s = case cmd of
|
||||
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
|
||||
chatRemoteSend cmd' = either throwError pure =<< liftRH remoteHostId (remoteSend c cmd' retryNum)
|
||||
|
||||
liftRH :: RemoteHostId -> ExceptT RemoteProtocolError IO a -> CM a
|
||||
liftRH rhId = liftError (ChatErrorRemoteHost (RHId rhId) . RHEProtocolError)
|
||||
@@ -497,8 +497,8 @@ parseCtrlAppInfo :: JT.Value -> CM CtrlAppInfo
|
||||
parseCtrlAppInfo ctrlAppInfo = do
|
||||
liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo
|
||||
|
||||
handleRemoteCommand :: (ByteString -> CM' (Either ChatError ChatResponse)) -> RemoteCrypto -> TBQueue (Either ChatError ChatEvent) -> HTTP2Request -> CM' ()
|
||||
handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
|
||||
handleRemoteCommand :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> RemoteCrypto -> TBQueue (Either ChatError ChatEvent) -> HTTP2Request -> CM' ()
|
||||
handleRemoteCommand execCC encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
|
||||
logDebug "handleRemoteCommand"
|
||||
liftIO (tryRemoteError' parseRequest) >>= \case
|
||||
Right (rfKN, getNext, rc) -> do
|
||||
@@ -514,7 +514,7 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque
|
||||
replyError = reply . RRChatResponse . RRError
|
||||
processCommand :: User -> C.SbKeyNonce -> GetChunk -> RemoteCommand -> CM ()
|
||||
processCommand user rfKN getNext = \case
|
||||
RCSend {command} -> lift $ handleSend execChatCommand command >>= reply
|
||||
RCSend {command, retryNumber} -> lift $ handleSend execCC command retryNumber >>= reply
|
||||
RCRecv {wait = time} -> lift $ liftIO (handleRecv time remoteOutputQ) >>= reply
|
||||
RCStoreFile {fileName, fileSize, fileDigest} -> lift $ handleStoreFile rfKN fileName fileSize fileDigest getNext >>= reply
|
||||
RCGetFile {file} -> handleGetFile user file replyWith
|
||||
@@ -550,12 +550,12 @@ tryRemoteError' :: ExceptT RemoteProtocolError IO a -> IO (Either RemoteProtocol
|
||||
tryRemoteError' = tryAllErrors' (RPEException . tshow)
|
||||
{-# INLINE tryRemoteError' #-}
|
||||
|
||||
handleSend :: (ByteString -> CM' (Either ChatError ChatResponse)) -> Text -> CM' RemoteResponse
|
||||
handleSend execChatCommand command = do
|
||||
handleSend :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> Int -> CM' RemoteResponse
|
||||
handleSend execCC command retryNum = 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 . eitherToResult <$> execChatCommand (encodeUtf8 command)
|
||||
-- execCC checks for remote-allowed commands
|
||||
-- convert errors thrown in execCC into error responses to prevent aborting the protocol wrapper
|
||||
RRChatResponse . eitherToResult <$> execCC (encodeUtf8 command) retryNum
|
||||
|
||||
handleRecv :: Int -> TBQueue (Either ChatError ChatEvent) -> IO RemoteResponse
|
||||
handleRecv time events = do
|
||||
@@ -615,8 +615,8 @@ 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' (Either ChatError ChatResponse)) -> Text -> CM RemoteCtrlInfo
|
||||
verifyRemoteCtrlSession execChatCommand sessCode' = do
|
||||
verifyRemoteCtrlSession :: (ByteString -> Int -> CM' (Either ChatError ChatResponse)) -> Text -> CM RemoteCtrlInfo
|
||||
verifyRemoteCtrlSession execCC sessCode' = do
|
||||
(sseq, client, ctrlName, sessionCode, vars) <-
|
||||
chatReadVar remoteCtrlSession >>= \case
|
||||
Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
|
||||
@@ -631,7 +631,7 @@ verifyRemoteCtrlSession execChatCommand sessCode' = do
|
||||
remoteOutputQ <- asks (tbqSize . config) >>= newTBQueueIO
|
||||
encryption <- mkCtrlRemoteCrypto sessionKeys $ tlsUniq tls
|
||||
cc <- ask
|
||||
http2Server <- liftIO . async $ attachHTTP2Server tls $ \req -> handleRemoteCommand execChatCommand encryption remoteOutputQ req `runReaderT` cc
|
||||
http2Server <- liftIO . async $ attachHTTP2Server tls $ \req -> handleRemoteCommand execCC encryption remoteOutputQ req `runReaderT` cc
|
||||
void . forkIO $ monitor sseq http2Server
|
||||
updateRemoteCtrlSession sseq $ \case
|
||||
RCSessionPendingConfirmation {} -> Right RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, tls, http2Server, remoteOutputQ}
|
||||
|
||||
@@ -56,7 +56,7 @@ import System.FilePath (takeFileName, (</>))
|
||||
import UnliftIO
|
||||
|
||||
data RemoteCommand
|
||||
= RCSend {command :: Text} -- TODO maybe ChatCommand here?
|
||||
= RCSend {command :: Text, retryNumber :: Int}
|
||||
| RCRecv {wait :: Int} -- this wait should be less than HTTP timeout
|
||||
| -- local file encryption is determined by the host, but can be overridden for videos
|
||||
RCStoreFile {fileName :: String, fileSize :: Word32, fileDigest :: FileDigest} -- requires attachment
|
||||
@@ -133,9 +133,9 @@ closeRemoteHostClient RemoteHostClient {httpClient} = closeHTTP2Client httpClien
|
||||
|
||||
-- ** Commands
|
||||
|
||||
remoteSend :: RemoteHostClient -> ByteString -> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
|
||||
remoteSend c cmd =
|
||||
sendRemoteCommand' c Nothing RCSend {command = decodeUtf8 cmd} >>= \case
|
||||
remoteSend :: RemoteHostClient -> ByteString -> Int -> ExceptT RemoteProtocolError IO (Either ChatError ChatResponse)
|
||||
remoteSend c cmd retryNumber =
|
||||
sendRemoteCommand' c Nothing RCSend {command = decodeUtf8 cmd, retryNumber} >>= \case
|
||||
RRChatResponse cr -> pure $ resultToEither cr
|
||||
r -> badResponse r
|
||||
|
||||
|
||||
@@ -14,7 +14,6 @@ module Simplex.Chat.Terminal.Input where
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay)
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (second)
|
||||
@@ -63,7 +62,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
||||
cmd = parseChatCommand bs
|
||||
rh' = if either (const False) allowRemoteCommand cmd then rh else Nothing
|
||||
unless (isMessage cmd) $ echo s
|
||||
r <- runReaderT (execChatCommand rh' bs) cc
|
||||
r <- execChatCommand rh' bs 0 `runReaderT` cc
|
||||
case r of
|
||||
Right r' -> processResp cmd rh r'
|
||||
Left _ -> when (isMessage cmd) $ echo s
|
||||
@@ -150,7 +149,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
||||
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
|
||||
runExceptT (processChatCommand cmd) `runReaderT` cc
|
||||
execChatCommand' cmd 0 `runReaderT` cc
|
||||
|
||||
runTerminalInput :: ChatTerminal -> ChatController -> IO ()
|
||||
runTerminalInput ct cc = withChatTerm ct $ do
|
||||
|
||||
@@ -15,7 +15,6 @@ import Control.Concurrent (ThreadId)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.List (intercalate)
|
||||
import Data.Text (Text)
|
||||
@@ -23,7 +22,7 @@ import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Library.Commands (execChatCommand, processChatCommand)
|
||||
import Simplex.Chat.Library.Commands (execChatCommand, execChatCommand')
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))
|
||||
@@ -166,11 +165,11 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha
|
||||
(True, CISRcvNew) -> do
|
||||
let itemId = chatItemId' ci
|
||||
chatRef = chatInfoToRef chat
|
||||
void $ runReaderT (runExceptT $ processChatCommand (APIChatItemsRead chatRef [itemId])) cc
|
||||
void $ runReaderT (execChatCommand' (APIChatItemsRead chatRef [itemId]) 0) cc
|
||||
_ -> pure ()
|
||||
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
|
||||
getRemoteUser rhId =
|
||||
runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case
|
||||
runReaderT (execChatCommand (Just rhId) "/user" 0) cc >>= \case
|
||||
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)
|
||||
|
||||
Reference in new issue
Block a user