mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-31 01:05:55 +00:00
292 lines
13 KiB
Haskell
292 lines
13 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module Simplex.Chat where
|
|
|
|
import Control.Logger.Simple
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Unlift
|
|
import Data.Bifunctor (bimap, second)
|
|
import Data.List (partition, sortOn)
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
|
import qualified Data.List.NonEmpty as L
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe (fromMaybe, mapMaybe)
|
|
import Data.Text (Text)
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Simplex.Chat.Controller
|
|
import Simplex.Chat.Library.Commands
|
|
import Simplex.Chat.Operators
|
|
import Simplex.Chat.Operators.Presets
|
|
import Simplex.Chat.Options
|
|
import Simplex.Chat.Options.DB
|
|
import Simplex.Chat.Protocol
|
|
import Simplex.Chat.Store
|
|
import Simplex.Chat.Store.Profiles
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Util (shuffle)
|
|
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
|
import Simplex.Messaging.Agent as Agent
|
|
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), ServerCfg (..), allRoles, createAgentStore, defaultAgentConfig, presetServerCfg)
|
|
import Simplex.Messaging.Agent.Protocol
|
|
import Simplex.Messaging.Agent.Store.Common (DBStore (dbNew))
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import Simplex.Messaging.Agent.Store.Entity
|
|
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError)
|
|
import Simplex.Messaging.Client (defaultNetworkConfig)
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolType (..), SProtocolType (..), SubscriptionMode (..), UserProtocol)
|
|
import qualified Simplex.Messaging.TMap as TM
|
|
import qualified UnliftIO.Exception as E
|
|
import UnliftIO.STM
|
|
|
|
defaultChatConfig :: ChatConfig
|
|
defaultChatConfig =
|
|
ChatConfig
|
|
{ agentConfig =
|
|
defaultAgentConfig
|
|
{ tcpPort = Nothing, -- agent does not listen to TCP
|
|
tbqSize = 1024
|
|
},
|
|
chatVRange = supportedChatVRange,
|
|
confirmMigrations = MCConsole,
|
|
-- this property should NOT use operator = Nothing
|
|
-- non-operator servers can be passed via options
|
|
presetServers =
|
|
PresetServers
|
|
{ operators =
|
|
[ PresetOperator
|
|
{ operator = Just operatorSimpleXChat,
|
|
smp = simplexChatSMPServers,
|
|
useSMP = 4,
|
|
xftp = map (presetServer True) $ L.toList defaultXFTPServers,
|
|
useXFTP = 3
|
|
},
|
|
PresetOperator
|
|
{ operator = Just operatorFlux,
|
|
smp = fluxSMPServers,
|
|
useSMP = 3,
|
|
xftp = fluxXFTPServers,
|
|
useXFTP = 3
|
|
}
|
|
],
|
|
ntf = _defaultNtfServers,
|
|
netCfg = defaultNetworkConfig
|
|
},
|
|
-- please note: if these servers are changed, this option needs to be split to two,
|
|
-- to have a different set of servers on the receiving end and on the sending end.
|
|
-- To preserve backward compatibility receiving end should update before the sending.
|
|
shortLinkPresetServers = allPresetServers,
|
|
presetDomains = [".simplex.im", ".simplexonflux.com"],
|
|
tbqSize = 1024,
|
|
fileChunkSize = 15780, -- do not change
|
|
xftpDescrPartSize = 14000,
|
|
inlineFiles = defaultInlineFilesConfig,
|
|
autoAcceptFileSize = 0,
|
|
showReactions = False,
|
|
showReceipts = False,
|
|
logLevel = CLLImportant,
|
|
subscriptionEvents = False,
|
|
hostEvents = False,
|
|
testView = False,
|
|
initialCleanupManagerDelay = 30 * 1000000, -- 30 seconds
|
|
cleanupManagerInterval = 30 * 60, -- 30 minutes
|
|
cleanupManagerStepDelay = 3 * 1000000, -- 3 seconds
|
|
ciExpirationInterval = 30 * 60 * 1000000, -- 30 minutes
|
|
coreApi = False,
|
|
highlyAvailable = False,
|
|
deviceNameForRemote = "",
|
|
chatHooks = defaultChatHooks
|
|
}
|
|
|
|
logCfg :: LogConfig
|
|
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
|
|
|
createChatDatabase :: ChatDbOpts -> MigrationConfirmation -> IO (Either MigrationError ChatDatabase)
|
|
createChatDatabase chatDbOpts confirmMigrations = runExceptT $ do
|
|
chatStore <- ExceptT $ createChatStore (toDBOpts chatDbOpts chatSuffix False) confirmMigrations
|
|
agentStore <- ExceptT $ createAgentStore (toDBOpts chatDbOpts agentSuffix False) confirmMigrations
|
|
pure ChatDatabase {chatStore, agentStore}
|
|
|
|
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Bool -> IO ChatController
|
|
newChatController
|
|
ChatDatabase {chatStore, agentStore}
|
|
user
|
|
cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
|
|
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
|
|
backgroundMode = do
|
|
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
|
|
confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
|
|
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
|
|
firstTime = dbNew chatStore
|
|
currentUser <- newTVarIO user
|
|
randomPresetServers <- chooseRandomServers presetServers'
|
|
let rndSrvs = L.toList randomPresetServers
|
|
operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op
|
|
opDomains = operatorDomains $ mapMaybe operatorWithId $ zip [1 ..] rndSrvs
|
|
agentSMP <- randomServerCfgs "agent SMP servers" SPSMP opDomains rndSrvs
|
|
agentXFTP <- randomServerCfgs "agent XFTP servers" SPXFTP opDomains rndSrvs
|
|
let randomAgentServers = RandomAgentServers {smpServers = agentSMP, xftpServers = agentXFTP}
|
|
currentRemoteHost <- newTVarIO Nothing
|
|
servers <- withTransaction chatStore $ \db -> agentServers db config randomPresetServers randomAgentServers
|
|
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode
|
|
agentAsync <- newTVarIO Nothing
|
|
random <- liftIO C.newRandom
|
|
eventSeq <- newTVarIO 0
|
|
inputQ <- newTBQueueIO tbqSize
|
|
outputQ <- newTBQueueIO tbqSize
|
|
connNetworkStatuses <- TM.emptyIO
|
|
subscriptionMode <- newTVarIO SMSubscribe
|
|
chatLock <- newEmptyTMVarIO
|
|
entityLocks <- TM.emptyIO
|
|
sndFiles <- newTVarIO M.empty
|
|
rcvFiles <- newTVarIO M.empty
|
|
currentCalls <- TM.emptyIO
|
|
localDeviceName <- newTVarIO $ fromMaybe deviceNameForRemote deviceName
|
|
multicastSubscribers <- newTMVarIO 0
|
|
remoteSessionSeq <- newTVarIO 0
|
|
remoteHostSessions <- TM.emptyIO
|
|
remoteHostsFolder <- newTVarIO Nothing
|
|
remoteCtrlSession <- newTVarIO Nothing
|
|
filesFolder <- newTVarIO optFilesFolder
|
|
chatStoreChanged <- newTVarIO False
|
|
expireCIThreads <- TM.emptyIO
|
|
expireCIFlags <- TM.emptyIO
|
|
cleanupManagerAsync <- newTVarIO Nothing
|
|
timedItemThreads <- TM.emptyIO
|
|
chatActivated <- newTVarIO True
|
|
showLiveItems <- newTVarIO False
|
|
encryptLocalFiles <- newTVarIO False
|
|
tempDirectory <- newTVarIO optTempDirectory
|
|
assetsDirectory <- newTVarIO Nothing
|
|
contactMergeEnabled <- newTVarIO True
|
|
pure
|
|
ChatController
|
|
{ firstTime,
|
|
currentUser,
|
|
randomPresetServers,
|
|
randomAgentServers,
|
|
currentRemoteHost,
|
|
smpAgent,
|
|
agentAsync,
|
|
chatStore,
|
|
chatStoreChanged,
|
|
random,
|
|
eventSeq,
|
|
inputQ,
|
|
outputQ,
|
|
connNetworkStatuses,
|
|
subscriptionMode,
|
|
chatLock,
|
|
entityLocks,
|
|
sndFiles,
|
|
rcvFiles,
|
|
currentCalls,
|
|
localDeviceName,
|
|
multicastSubscribers,
|
|
remoteSessionSeq,
|
|
remoteHostSessions,
|
|
remoteHostsFolder,
|
|
remoteCtrlSession,
|
|
config,
|
|
filesFolder,
|
|
expireCIThreads,
|
|
expireCIFlags,
|
|
cleanupManagerAsync,
|
|
timedItemThreads,
|
|
chatActivated,
|
|
showLiveItems,
|
|
encryptLocalFiles,
|
|
tempDirectory,
|
|
assetsDirectory,
|
|
logFilePath = logFile,
|
|
contactMergeEnabled
|
|
}
|
|
where
|
|
presetServers' :: PresetServers
|
|
presetServers' = presetServers {operators = operators', netCfg = netCfg'}
|
|
where
|
|
PresetServers {operators, netCfg} = presetServers
|
|
netCfg' = updateNetworkConfig netCfg simpleNetCfg
|
|
operators' = case (smpServers, xftpServers) of
|
|
([], []) -> operators
|
|
(smpSrvs, []) -> L.map disableSMP operators <> [custom smpSrvs []]
|
|
([], xftpSrvs) -> L.map disableXFTP operators <> [custom [] xftpSrvs]
|
|
(smpSrvs, xftpSrvs) -> [custom smpSrvs xftpSrvs]
|
|
disableSMP op@PresetOperator {smp} = (op :: PresetOperator) {smp = map disableSrv smp}
|
|
disableXFTP op@PresetOperator {xftp} = (op :: PresetOperator) {xftp = map disableSrv xftp}
|
|
disableSrv :: forall p. NewUserServer p -> NewUserServer p
|
|
disableSrv srv = (srv :: NewUserServer p) {enabled = False}
|
|
custom smpSrvs xftpSrvs =
|
|
PresetOperator
|
|
{ operator = Nothing,
|
|
smp = map newUserServer smpSrvs,
|
|
useSMP = 0,
|
|
xftp = map newUserServer xftpSrvs,
|
|
useXFTP = 0
|
|
}
|
|
randomServerCfgs :: UserProtocol p => String -> SProtocolType p -> [(Text, ServerOperator)] -> [PresetOperator] -> IO (NonEmpty (ServerCfg p))
|
|
randomServerCfgs name p opDomains rndSrvs =
|
|
toJustOrError name $ L.nonEmpty $ agentServerCfgs p opDomains $ concatMap (pServers p) rndSrvs
|
|
agentServers :: DB.Connection -> ChatConfig -> NonEmpty PresetOperator -> RandomAgentServers -> IO InitialAgentServers
|
|
agentServers db ChatConfig {presetServers = PresetServers {ntf, netCfg}, presetDomains} presetOps as = do
|
|
users <- getUsers db
|
|
ops <- getUpdateServerOperators db presetOps (null users)
|
|
let opDomains = operatorDomains $ mapMaybe snd ops
|
|
(smp', xftp') <- unzip <$> mapM (getServers ops opDomains) users
|
|
pure InitialAgentServers {smp = M.fromList (optServers smp' smpServers), xftp = M.fromList (optServers xftp' xftpServers), ntf, netCfg, presetDomains}
|
|
where
|
|
optServers :: [(UserId, NonEmpty (ServerCfg p))] -> [ProtoServerWithAuth p] -> [(UserId, NonEmpty (ServerCfg p))]
|
|
optServers srvs overrides_ = case L.nonEmpty overrides_ of
|
|
Just overrides -> map (second $ const $ L.map (presetServerCfg True allRoles Nothing) overrides) srvs
|
|
Nothing -> srvs
|
|
getServers :: [(Maybe PresetOperator, Maybe ServerOperator)] -> [(Text, ServerOperator)] -> User -> IO ((UserId, NonEmpty (ServerCfg 'PSMP)), (UserId, NonEmpty (ServerCfg 'PXFTP)))
|
|
getServers ops opDomains user' = do
|
|
smpSrvs <- getProtocolServers db SPSMP user'
|
|
xftpSrvs <- getProtocolServers db SPXFTP user'
|
|
uss <- groupByOperator' (ops, smpSrvs, xftpSrvs)
|
|
ts <- getCurrentTime
|
|
uss' <- mapM (setUserServers' db user' ts . updatedUserServers) uss
|
|
let auId = aUserId user'
|
|
pure $ bimap (auId,) (auId,) $ useServers as opDomains uss'
|
|
|
|
chooseRandomServers :: PresetServers -> IO (NonEmpty PresetOperator)
|
|
chooseRandomServers PresetServers {operators} =
|
|
forM operators $ \op -> do
|
|
smp' <- opSrvs SPSMP op
|
|
xftp' <- opSrvs SPXFTP op
|
|
pure (op :: PresetOperator) {smp = smp', xftp = xftp'}
|
|
where
|
|
opSrvs :: forall p. UserProtocol p => SProtocolType p -> PresetOperator -> IO [NewUserServer p]
|
|
opSrvs p op = do
|
|
let srvs = pServers p op
|
|
toUse = operatorServersToUse p op
|
|
(enbldSrvs, dsbldSrvs) = partition (\UserServer {enabled} -> enabled) srvs
|
|
if toUse <= 0 || toUse >= length enbldSrvs
|
|
then pure srvs
|
|
else do
|
|
(enbldSrvs', srvsToDisable) <- splitAt toUse <$> shuffle enbldSrvs
|
|
let dsbldSrvs' = map (\srv -> (srv :: NewUserServer p) {enabled = False}) srvsToDisable
|
|
pure $ sortOn server' $ enbldSrvs' <> dsbldSrvs' <> dsbldSrvs
|
|
server' UserServer {server = ProtoServerWithAuth srv _} = srv
|
|
|
|
toJustOrError :: String -> Maybe a -> IO a
|
|
toJustOrError name = \case
|
|
Just a -> pure a
|
|
Nothing -> do
|
|
putStrLn $ name <> ": expected Just, exiting"
|
|
E.throwIO $ userError name
|