blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into ab/async-subs

Browse Source
This commit is contained in:
Evgeny Poberezkin
2024-06-24 16:52:36 +01:00
parent 41e6e6b54e 1af513c548
commit f856bb5faf
42 changed files with 422 additions and 195 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+58 -39
View File
@@ -104,7 +104,7 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), Migrati
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client (ProxyClientError (..), NetworkConfig (..), defaultNetworkConfig)
import Simplex.Messaging.Client (NetworkConfig (..), ProxyClientError (..), defaultNetworkConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
@@ -218,11 +218,12 @@ newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Boo
newChatController
ChatDatabase {chatStore, agentStore}
user
cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, deviceNameForRemote}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, deviceNameForRemote, confirmMigrations}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable, yesToUpMigrations}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
backgroundMode = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable}
confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
firstTime = dbNew chatStore
currentUser <- newTVarIO user
currentRemoteHost <- newTVarIO Nothing
@@ -762,28 +763,31 @@ processChatCommand' vr = \case
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTGroup -> withGroupLock "updateChatItem" chatId $ do
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db vr user chatId
Group gInfo@GroupInfo {groupId, membership} ms <- withStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
case (ciContent, itemSharedMsgId, editable) of
(CISndMsgContent oldMC, Just itemSharedMId, True) -> do
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withStore' $ \db -> do
currentTs <- liftIO getCurrentTime
when changed $
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
let edited = itemLive /= Just True
updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
if prohibitedSimplexLinks gInfo membership mc
then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks))
else do
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
case (ciContent, itemSharedMsgId, editable) of
(CISndMsgContent oldMC, Just itemSharedMId, True) -> do
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withStore' $ \db -> do
currentTs <- liftIO getCurrentTime
when changed $
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
let edited = itemLive /= Just True
updateGroupChatItem db user groupId ci (CISndMsgContent mc) edited live $ Just msgId
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
_ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTLocal -> do
(nf@NoteFolder {noteFolderId}, cci) <- withStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId
case cci of
@@ -1357,6 +1361,9 @@ processChatCommand' vr = \case
pure $ CRNetworkConfig cfg
APISetNetworkInfo info -> lift (withAgent' (`setUserNetworkInfo` info)) >> ok_
ReconnectAllServers -> withUser' $ \_ -> lift (withAgent' reconnectAllServers) >> ok_
ReconnectServer userId srv -> withUserId userId $ \user -> do
lift (withAgent' $ \a -> reconnectSMPServer a (aUserId user) srv)
ok_
APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user -> case cType of
CTDirect -> do
ct <- withStore $ \db -> do
@@ -2918,9 +2925,17 @@ prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe f -> M
prohibitedGroupContent gInfo m mc file_
| isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice
| not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles
| not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) && containsFormat isSimplexLink (parseMarkdown $ msgContentText mc) = Just GFSimplexLinks
| prohibitedSimplexLinks gInfo m mc = Just GFSimplexLinks
| otherwise = Nothing
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Bool
prohibitedSimplexLinks gInfo m mc =
not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo)
&& maybe False (any ftIsSimplexLink) (parseMaybeMarkdownList $ msgContentText mc)
where
ftIsSimplexLink :: FormattedText -> Bool
ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format
roundedFDCount :: Int -> Int
roundedFDCount n
| n <= 0 = 4
@@ -3214,7 +3229,7 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
forM_ aci_ $ \aci -> toView $ CRChatItemUpdated user aci
throwChatError $ CEFileNotApproved fileId unknownSrvs
getNetworkConfig :: CM' NetworkConfig
getNetworkConfig :: CM' NetworkConfig
getNetworkConfig = withAgent' $ liftIO . getNetworkConfig'
resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
@@ -5223,18 +5238,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
groupMsgToView gInfo ci' {reactions}
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} brokerTs ttl_ live_ =
updateRcvChatItem `catchCINotFound` \_ -> do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs content Nothing timed_ live
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
ci' <- updateGroupChatItem db user groupId ci content True live Nothing
blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci'
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} brokerTs ttl_ live_
| prohibitedSimplexLinks gInfo m mc =
messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks
| otherwise = do
updateRcvChatItem `catchCINotFound` \_ -> do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs content Nothing timed_ live
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
ci' <- updateGroupChatItem db user groupId ci content True live Nothing
blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci'
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
where
content = CIRcvMsgContent mc
live = fromMaybe False live_
@@ -7383,6 +7401,7 @@ chatCommandP =
"/_network " *> (APISetNetworkConfig <$> jsonP),
("/network " <|> "/net ") *> (SetNetworkConfig <$> netCfgP),
("/network" <|> "/net") $> APIGetNetworkConfig,
"/reconnect " *> (ReconnectServer <$> A.decimal <* A.space <*> strP),
"/reconnect" $> ReconnectAllServers,
"/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP),
"/_member settings #" *> (APISetMemberSettings <$> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP),
src/Simplex/Chat/Controller.hs
+1
View File
@@ -355,6 +355,7 @@ data ChatCommand
| SetNetworkConfig SimpleNetCfg
| APISetNetworkInfo UserNetworkInfo
| ReconnectAllServers
| ReconnectServer UserId SMPServer
| APISetChatSettings ChatRef ChatSettings
| APISetMemberSettings GroupId GroupMemberId GroupMemberSettings
| APIContactInfo ContactId
src/Simplex/Chat/Markdown.hs
-4
View File
@@ -144,10 +144,6 @@ markdownToList (m1 :|: m2) = markdownToList m1 <> markdownToList m2
parseMarkdown :: Text -> Markdown
parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
containsFormat :: (Format -> Bool) -> Markdown -> Bool
containsFormat p (Markdown f _) = maybe False p f
containsFormat p (m1 :|: m2) = containsFormat p m1 || containsFormat p m2
isSimplexLink :: Format -> Bool
isSimplexLink = \case
SimplexLink {} -> True;
src/Simplex/Chat/Mobile.hs
+2 -1
View File
@@ -198,7 +198,8 @@ mobileChatOpts dbFilePrefix =
logAgent = Nothing,
logFile = Nothing,
tbqSize = 1024,
highlyAvailable = False
highlyAvailable = False,
yesToUpMigrations = False
},
deviceName = Nothing,
chatCmd = "",
src/Simplex/Chat/Options.hs
+10 -2
View File
@@ -62,7 +62,8 @@ data CoreChatOpts = CoreChatOpts
logAgent :: Maybe LogLevel,
logFile :: Maybe FilePath,
tbqSize :: Natural,
highlyAvailable :: Bool
highlyAvailable :: Bool,
yesToUpMigrations :: Bool
}
data ChatCmdLog = CCLAll | CCLMessages | CCLNone
@@ -204,6 +205,12 @@ coreChatOptsP appDir defaultDbFileName = do
( long "ha"
<> help "Run as a highly available client (this may increase traffic in groups)"
)
yesToUpMigrations <-
switch
( long "--yes-migrate"
<> short 'y'
<> help "Automatically confirm \"up\" database migrations"
)
pure
CoreChatOpts
{ dbFilePrefix,
@@ -217,7 +224,8 @@ coreChatOptsP appDir defaultDbFileName = do
logAgent = if logAgent || logLevel == CLLDebug then Just $ agentLogLevel logLevel else Nothing,
logFile,
tbqSize,
highlyAvailable
highlyAvailable,
yesToUpMigrations
}
where
useTcpTimeout p t = 1000000 * if t > 0 then t else maybe 7 (const 15) p