{-# 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
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 (MigrationConfig (..), 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
defaultChatConfig =
  ChatConfig
    { agentConfig :: AgentConfig
agentConfig =
        AgentConfig
defaultAgentConfig
          { tcpPort = Nothing, -- agent does not listen to TCP
            tbqSize = 1024
          },
      chatVRange :: VersionRangeChat
chatVRange = VersionRangeChat
supportedChatVRange,
      confirmMigrations :: MigrationConfirmation
confirmMigrations = MigrationConfirmation
MCConsole,
      -- this property should NOT use operator = Nothing
      -- non-operator servers can be passed via options
      presetServers :: PresetServers
presetServers =
        PresetServers
          { operators :: NonEmpty PresetOperator
operators =
              [ PresetOperator
                  { operator :: Maybe NewServerOperator
operator = NewServerOperator -> Maybe NewServerOperator
forall a. a -> Maybe a
Just NewServerOperator
operatorSimpleXChat,
                    smp :: [NewUserServer 'PSMP]
smp = [NewUserServer 'PSMP]
simplexChatSMPServers,
                    useSMP :: Int
useSMP = Int
4,
                    xftp :: [NewUserServer 'PXFTP]
xftp = (XFTPServerWithAuth -> NewUserServer 'PXFTP)
-> [XFTPServerWithAuth] -> [NewUserServer 'PXFTP]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> XFTPServerWithAuth -> NewUserServer 'PXFTP
forall (p :: ProtocolType).
Bool -> ProtoServerWithAuth p -> NewUserServer p
presetServer Bool
True) ([XFTPServerWithAuth] -> [NewUserServer 'PXFTP])
-> [XFTPServerWithAuth] -> [NewUserServer 'PXFTP]
forall a b. (a -> b) -> a -> b
$ NonEmpty XFTPServerWithAuth -> [XFTPServerWithAuth]
forall a. NonEmpty a -> [a]
L.toList NonEmpty XFTPServerWithAuth
defaultXFTPServers,
                    useXFTP :: Int
useXFTP = Int
3
                  },
                PresetOperator
                  { operator :: Maybe NewServerOperator
operator = NewServerOperator -> Maybe NewServerOperator
forall a. a -> Maybe a
Just NewServerOperator
operatorFlux,
                    smp :: [NewUserServer 'PSMP]
smp = [NewUserServer 'PSMP]
fluxSMPServers,
                    useSMP :: Int
useSMP = Int
3,
                    xftp :: [NewUserServer 'PXFTP]
xftp = [NewUserServer 'PXFTP]
fluxXFTPServers,
                    useXFTP :: Int
useXFTP = Int
3
                  }
              ],
            ntf :: [NtfServer]
ntf = [NtfServer]
_defaultNtfServers,
            netCfg :: NetworkConfig
netCfg = NetworkConfig
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 :: NonEmpty SMPServer
shortLinkPresetServers = NonEmpty SMPServer
allPresetServers,
      presetDomains :: [HostName]
presetDomains = [HostName
Item [HostName]
".simplex.im", HostName
Item [HostName]
".simplexonflux.com"],
      tbqSize :: Natural
tbqSize = Natural
1024,
      fileChunkSize :: Integer
fileChunkSize = Integer
15780, -- do not change
      xftpDescrPartSize :: Int
xftpDescrPartSize = Int
14000,
      inlineFiles :: InlineFilesConfig
inlineFiles = InlineFilesConfig
defaultInlineFilesConfig,
      autoAcceptFileSize :: Integer
autoAcceptFileSize = Integer
0,
      showReactions :: Bool
showReactions = Bool
False,
      showReceipts :: Bool
showReceipts = Bool
False,
      logLevel :: ChatLogLevel
logLevel = ChatLogLevel
CLLImportant,
      subscriptionEvents :: Bool
subscriptionEvents = Bool
False,
      hostEvents :: Bool
hostEvents = Bool
False,
      testView :: Bool
testView = Bool
False,
      initialCleanupManagerDelay :: UserId
initialCleanupManagerDelay = UserId
30 UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
* UserId
1000000, -- 30 seconds
      cleanupManagerInterval :: NominalDiffTime
cleanupManagerInterval = NominalDiffTime
30 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60, -- 30 minutes
      cleanupManagerStepDelay :: UserId
cleanupManagerStepDelay = UserId
3 UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
* UserId
1000000, -- 3 seconds
      ciExpirationInterval :: UserId
ciExpirationInterval = UserId
30 UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
* UserId
60 UserId -> UserId -> UserId
forall a. Num a => a -> a -> a
* UserId
1000000, -- 30 minutes
      highlyAvailable :: Bool
highlyAvailable = Bool
False,
      deliveryWorkerDelay :: UserId
deliveryWorkerDelay = UserId
0,
      deliveryBucketSize :: Int
deliveryBucketSize = Int
10000,
      deviceNameForRemote :: Text
deviceNameForRemote = Text
"",
      chatHooks :: ChatHooks
chatHooks = ChatHooks
defaultChatHooks
    }

logCfg :: LogConfig
logCfg :: LogConfig
logCfg = LogConfig {lc_file :: Maybe HostName
lc_file = Maybe HostName
forall a. Maybe a
Nothing, lc_stderr :: Bool
lc_stderr = Bool
True}

createChatDatabase :: ChatDbOpts -> MigrationConfig -> IO (Either MigrationError ChatDatabase)
createChatDatabase :: ChatDbOpts
-> MigrationConfig -> IO (Either MigrationError ChatDatabase)
createChatDatabase ChatDbOpts
chatDbOpts MigrationConfig
migrationConfig = ExceptT MigrationError IO ChatDatabase
-> IO (Either MigrationError ChatDatabase)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT MigrationError IO ChatDatabase
 -> IO (Either MigrationError ChatDatabase))
-> ExceptT MigrationError IO ChatDatabase
-> IO (Either MigrationError ChatDatabase)
forall a b. (a -> b) -> a -> b
$ do
  DBStore
chatStore <- IO (Either MigrationError DBStore)
-> ExceptT MigrationError IO DBStore
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either MigrationError DBStore)
 -> ExceptT MigrationError IO DBStore)
-> IO (Either MigrationError DBStore)
-> ExceptT MigrationError IO DBStore
forall a b. (a -> b) -> a -> b
$ DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
createChatStore (ChatDbOpts -> HostName -> Bool -> [SQLiteFuncDef] -> DBOpts
toDBOpts ChatDbOpts
chatDbOpts HostName
chatSuffix Bool
False [SQLiteFuncDef]
chatDBFunctions) MigrationConfig
migrationConfig
  DBStore
agentStore <- IO (Either MigrationError DBStore)
-> ExceptT MigrationError IO DBStore
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either MigrationError DBStore)
 -> ExceptT MigrationError IO DBStore)
-> IO (Either MigrationError DBStore)
-> ExceptT MigrationError IO DBStore
forall a b. (a -> b) -> a -> b
$ DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
createAgentStore (ChatDbOpts -> HostName -> Bool -> [SQLiteFuncDef] -> DBOpts
toDBOpts ChatDbOpts
chatDbOpts HostName
agentSuffix Bool
False []) MigrationConfig
migrationConfig
  ChatDatabase -> ExceptT MigrationError IO ChatDatabase
forall a. a -> ExceptT MigrationError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChatDatabase {DBStore
chatStore :: DBStore
chatStore :: DBStore
chatStore, DBStore
agentStore :: DBStore
agentStore :: DBStore
agentStore}

newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Bool -> IO ChatController
newChatController :: ChatDatabase
-> Maybe User
-> ChatConfig
-> ChatOpts
-> Bool
-> IO ChatController
newChatController
  ChatDatabase {DBStore
chatStore :: ChatDatabase -> DBStore
chatStore :: DBStore
chatStore, DBStore
agentStore :: ChatDatabase -> DBStore
agentStore :: DBStore
agentStore}
  Maybe User
user
  cfg :: ChatConfig
cfg@ChatConfig {agentConfig :: ChatConfig -> AgentConfig
agentConfig = AgentConfig
aCfg, PresetServers
presetServers :: ChatConfig -> PresetServers
presetServers :: PresetServers
presetServers, InlineFilesConfig
inlineFiles :: ChatConfig -> InlineFilesConfig
inlineFiles :: InlineFilesConfig
inlineFiles, Text
deviceNameForRemote :: ChatConfig -> Text
deviceNameForRemote :: Text
deviceNameForRemote, MigrationConfirmation
confirmMigrations :: ChatConfig -> MigrationConfirmation
confirmMigrations :: MigrationConfirmation
confirmMigrations}
  ChatOpts {coreOptions :: ChatOpts -> CoreChatOpts
coreOptions = CoreChatOpts {[SMPServerWithAuth]
smpServers :: [SMPServerWithAuth]
smpServers :: CoreChatOpts -> [SMPServerWithAuth]
smpServers, [XFTPServerWithAuth]
xftpServers :: [XFTPServerWithAuth]
xftpServers :: CoreChatOpts -> [XFTPServerWithAuth]
xftpServers, SimpleNetCfg
simpleNetCfg :: SimpleNetCfg
simpleNetCfg :: CoreChatOpts -> SimpleNetCfg
simpleNetCfg, ChatLogLevel
logLevel :: ChatLogLevel
logLevel :: CoreChatOpts -> ChatLogLevel
logLevel, Bool
logConnections :: Bool
logConnections :: CoreChatOpts -> Bool
logConnections, Bool
logServerHosts :: Bool
logServerHosts :: CoreChatOpts -> Bool
logServerHosts, Maybe HostName
logFile :: Maybe HostName
logFile :: CoreChatOpts -> Maybe HostName
logFile, Natural
tbqSize :: Natural
tbqSize :: CoreChatOpts -> Natural
tbqSize, Maybe Text
deviceName :: Maybe Text
deviceName :: CoreChatOpts -> Maybe Text
deviceName, Bool
highlyAvailable :: Bool
highlyAvailable :: CoreChatOpts -> Bool
highlyAvailable, Bool
yesToUpMigrations :: Bool
yesToUpMigrations :: CoreChatOpts -> Bool
yesToUpMigrations}, Maybe HostName
optFilesFolder :: Maybe HostName
optFilesFolder :: ChatOpts -> Maybe HostName
optFilesFolder, Maybe HostName
optTempDirectory :: Maybe HostName
optTempDirectory :: ChatOpts -> Maybe HostName
optTempDirectory, Bool
showReactions :: Bool
showReactions :: ChatOpts -> Bool
showReactions, Bool
allowInstantFiles :: Bool
allowInstantFiles :: ChatOpts -> Bool
allowInstantFiles, Integer
autoAcceptFileSize :: Integer
autoAcceptFileSize :: ChatOpts -> Integer
autoAcceptFileSize}
  Bool
backgroundMode = do
    let inlineFiles' :: InlineFilesConfig
inlineFiles' = if Bool
allowInstantFiles Bool -> Bool -> Bool
|| Integer
autoAcceptFileSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then InlineFilesConfig
inlineFiles else InlineFilesConfig
inlineFiles {sendChunks = 0, receiveInstant = False}
        confirmMigrations' :: MigrationConfirmation
confirmMigrations' = if MigrationConfirmation
confirmMigrations MigrationConfirmation -> MigrationConfirmation -> Bool
forall a. Eq a => a -> a -> Bool
== MigrationConfirmation
MCConsole Bool -> Bool -> Bool
&& Bool
yesToUpMigrations then MigrationConfirmation
MCYesUp else MigrationConfirmation
confirmMigrations
        config :: ChatConfig
config = ChatConfig
cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
        firstTime :: Bool
firstTime = DBStore -> Bool
dbNew DBStore
chatStore
    TVar (Maybe User)
currentUser <- Maybe User -> IO (TVar (Maybe User))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe User
user
    NonEmpty PresetOperator
randomPresetServers <- PresetServers -> IO (NonEmpty PresetOperator)
chooseRandomServers PresetServers
presetServers'
    let rndSrvs :: [PresetOperator]
rndSrvs = NonEmpty PresetOperator -> [PresetOperator]
forall a. NonEmpty a -> [a]
L.toList NonEmpty PresetOperator
randomPresetServers
        operatorWithId :: (UserId, PresetOperator) -> Maybe (ServerOperator' 'DBStored)
operatorWithId (UserId
i, PresetOperator
op) = (\NewServerOperator
o -> NewServerOperator
o {operatorId = DBEntityId i}) (NewServerOperator -> ServerOperator' 'DBStored)
-> Maybe NewServerOperator -> Maybe (ServerOperator' 'DBStored)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PresetOperator -> Maybe NewServerOperator
pOperator PresetOperator
op
        opDomains :: [(Text, ServerOperator' 'DBStored)]
opDomains = [ServerOperator' 'DBStored] -> [(Text, ServerOperator' 'DBStored)]
forall (s :: DBStored).
[ServerOperator' s] -> [(Text, ServerOperator' s)]
operatorDomains ([ServerOperator' 'DBStored]
 -> [(Text, ServerOperator' 'DBStored)])
-> [ServerOperator' 'DBStored]
-> [(Text, ServerOperator' 'DBStored)]
forall a b. (a -> b) -> a -> b
$ ((UserId, PresetOperator) -> Maybe (ServerOperator' 'DBStored))
-> [(UserId, PresetOperator)] -> [ServerOperator' 'DBStored]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (UserId, PresetOperator) -> Maybe (ServerOperator' 'DBStored)
operatorWithId ([(UserId, PresetOperator)] -> [ServerOperator' 'DBStored])
-> [(UserId, PresetOperator)] -> [ServerOperator' 'DBStored]
forall a b. (a -> b) -> a -> b
$ [UserId] -> [PresetOperator] -> [(UserId, PresetOperator)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UserId
Item [UserId]
1 ..] [PresetOperator]
rndSrvs
    NonEmpty (ServerCfg 'PSMP)
agentSMP <- HostName
-> SProtocolType 'PSMP
-> [(Text, ServerOperator' 'DBStored)]
-> [PresetOperator]
-> IO (NonEmpty (ServerCfg 'PSMP))
forall (p :: ProtocolType).
UserProtocol p =>
HostName
-> SProtocolType p
-> [(Text, ServerOperator' 'DBStored)]
-> [PresetOperator]
-> IO (NonEmpty (ServerCfg p))
randomServerCfgs HostName
"agent SMP servers" SProtocolType 'PSMP
SPSMP [(Text, ServerOperator' 'DBStored)]
opDomains [PresetOperator]
rndSrvs
    NonEmpty (ServerCfg 'PXFTP)
agentXFTP <- HostName
-> SProtocolType 'PXFTP
-> [(Text, ServerOperator' 'DBStored)]
-> [PresetOperator]
-> IO (NonEmpty (ServerCfg 'PXFTP))
forall (p :: ProtocolType).
UserProtocol p =>
HostName
-> SProtocolType p
-> [(Text, ServerOperator' 'DBStored)]
-> [PresetOperator]
-> IO (NonEmpty (ServerCfg p))
randomServerCfgs HostName
"agent XFTP servers" SProtocolType 'PXFTP
SPXFTP [(Text, ServerOperator' 'DBStored)]
opDomains [PresetOperator]
rndSrvs
    let randomAgentServers :: RandomAgentServers
randomAgentServers = RandomAgentServers {smpServers :: NonEmpty (ServerCfg 'PSMP)
smpServers = NonEmpty (ServerCfg 'PSMP)
agentSMP, xftpServers :: NonEmpty (ServerCfg 'PXFTP)
xftpServers = NonEmpty (ServerCfg 'PXFTP)
agentXFTP}
    TVar (Maybe UserId)
currentRemoteHost <- Maybe UserId -> IO (TVar (Maybe UserId))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe UserId
forall a. Maybe a
Nothing
    InitialAgentServers
servers <- DBStore
-> (Connection -> IO InitialAgentServers) -> IO InitialAgentServers
forall a. DBStore -> (Connection -> IO a) -> IO a
withTransaction DBStore
chatStore ((Connection -> IO InitialAgentServers) -> IO InitialAgentServers)
-> (Connection -> IO InitialAgentServers) -> IO InitialAgentServers
forall a b. (a -> b) -> a -> b
$ \Connection
db -> Connection
-> ChatConfig
-> NonEmpty PresetOperator
-> RandomAgentServers
-> IO InitialAgentServers
agentServers Connection
db ChatConfig
config NonEmpty PresetOperator
randomPresetServers RandomAgentServers
randomAgentServers
    AgentClient
smpAgent <- AgentConfig
-> InitialAgentServers -> DBStore -> Bool -> IO AgentClient
getSMPAgentClient AgentConfig
aCfg {tbqSize} InitialAgentServers
servers DBStore
agentStore Bool
backgroundMode
    TVar (Maybe (Async (), Maybe (Async ())))
agentAsync <- Maybe (Async (), Maybe (Async ()))
-> IO (TVar (Maybe (Async (), Maybe (Async ()))))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe (Async (), Maybe (Async ()))
forall a. Maybe a
Nothing
    TVar ChaChaDRG
random <- IO (TVar ChaChaDRG) -> IO (TVar ChaChaDRG)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (TVar ChaChaDRG)
C.newRandom
    TVar Int
eventSeq <- Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0
    TBQueue HostName
inputQ <- Natural -> IO (TBQueue HostName)
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO Natural
tbqSize
    TBQueue (Maybe UserId, Either ChatError ChatEvent)
outputQ <- Natural -> IO (TBQueue (Maybe UserId, Either ChatError ChatEvent))
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO Natural
tbqSize
    TVar SubscriptionMode
subscriptionMode <- SubscriptionMode -> IO (TVar SubscriptionMode)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO SubscriptionMode
SMSubscribe
    TMVar Text
chatLock <- IO (TMVar Text)
forall (m :: * -> *) a. MonadIO m => m (TMVar a)
newEmptyTMVarIO
    TMap ChatLockEntity (TMVar Text)
entityLocks <- IO (TMap ChatLockEntity (TMVar Text))
forall k a. IO (TMap k a)
TM.emptyIO
    TVar (Map UserId Handle)
sndFiles <- Map UserId Handle -> IO (TVar (Map UserId Handle))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map UserId Handle
forall k a. Map k a
M.empty
    TVar (Map UserId Handle)
rcvFiles <- Map UserId Handle -> IO (TVar (Map UserId Handle))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map UserId Handle
forall k a. Map k a
M.empty
    TMap UserId Call
currentCalls <- IO (TMap UserId Call)
forall k a. IO (TMap k a)
TM.emptyIO
    TVar Text
localDeviceName <- Text -> IO (TVar Text)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Text -> IO (TVar Text)) -> Text -> IO (TVar Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
deviceNameForRemote Maybe Text
deviceName
    TMVar Int
multicastSubscribers <- Int -> IO (TMVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TMVar a)
newTMVarIO Int
0
    TVar Int
remoteSessionSeq <- Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0
    TMap RHKey (Int, RemoteHostSession)
remoteHostSessions <- IO (TMap RHKey (Int, RemoteHostSession))
forall k a. IO (TMap k a)
TM.emptyIO
    TVar (Maybe HostName)
remoteHostsFolder <- Maybe HostName -> IO (TVar (Maybe HostName))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe HostName
forall a. Maybe a
Nothing
    TVar (Maybe (Int, RemoteCtrlSession))
remoteCtrlSession <- Maybe (Int, RemoteCtrlSession)
-> IO (TVar (Maybe (Int, RemoteCtrlSession)))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe (Int, RemoteCtrlSession)
forall a. Maybe a
Nothing
    TVar (Maybe HostName)
filesFolder <- Maybe HostName -> IO (TVar (Maybe HostName))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe HostName
optFilesFolder
    TVar Bool
chatStoreChanged <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
    TMap DeliveryWorkerKey Worker
deliveryTaskWorkers <- IO (TMap DeliveryWorkerKey Worker)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap DeliveryWorkerKey Worker
deliveryJobWorkers <- IO (TMap DeliveryWorkerKey Worker)
forall k a. IO (TMap k a)
TM.emptyIO
    TMap UserId (Maybe (Async ()))
expireCIThreads <- IO (TMap UserId (Maybe (Async ())))
forall k a. IO (TMap k a)
TM.emptyIO
    TMap UserId Bool
expireCIFlags <- IO (TMap UserId Bool)
forall k a. IO (TMap k a)
TM.emptyIO
    TVar (Maybe (Async ()))
cleanupManagerAsync <- Maybe (Async ()) -> IO (TVar (Maybe (Async ())))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe (Async ())
forall a. Maybe a
Nothing
    TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
timedItemThreads <- IO (TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId))))
forall k a. IO (TMap k a)
TM.emptyIO
    TVar Bool
chatActivated <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
True
    TVar Bool
showLiveItems <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
    TVar Bool
encryptLocalFiles <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
False
    TVar (Maybe HostName)
tempDirectory <- Maybe HostName -> IO (TVar (Maybe HostName))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe HostName
optTempDirectory
    TVar (Maybe HostName)
assetsDirectory <- Maybe HostName -> IO (TVar (Maybe HostName))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe HostName
forall a. Maybe a
Nothing
    TVar Bool
contactMergeEnabled <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
True
    ChatController -> IO ChatController
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ChatController
        { Bool
firstTime :: Bool
firstTime :: Bool
firstTime,
          TVar (Maybe User)
currentUser :: TVar (Maybe User)
currentUser :: TVar (Maybe User)
currentUser,
          NonEmpty PresetOperator
randomPresetServers :: NonEmpty PresetOperator
randomPresetServers :: NonEmpty PresetOperator
randomPresetServers,
          RandomAgentServers
randomAgentServers :: RandomAgentServers
randomAgentServers :: RandomAgentServers
randomAgentServers,
          TVar (Maybe UserId)
currentRemoteHost :: TVar (Maybe UserId)
currentRemoteHost :: TVar (Maybe UserId)
currentRemoteHost,
          AgentClient
smpAgent :: AgentClient
smpAgent :: AgentClient
smpAgent,
          TVar (Maybe (Async (), Maybe (Async ())))
agentAsync :: TVar (Maybe (Async (), Maybe (Async ())))
agentAsync :: TVar (Maybe (Async (), Maybe (Async ())))
agentAsync,
          DBStore
chatStore :: DBStore
chatStore :: DBStore
chatStore,
          TVar Bool
chatStoreChanged :: TVar Bool
chatStoreChanged :: TVar Bool
chatStoreChanged,
          TVar ChaChaDRG
random :: TVar ChaChaDRG
random :: TVar ChaChaDRG
random,
          TVar Int
eventSeq :: TVar Int
eventSeq :: TVar Int
eventSeq,
          TBQueue HostName
inputQ :: TBQueue HostName
inputQ :: TBQueue HostName
inputQ,
          TBQueue (Maybe UserId, Either ChatError ChatEvent)
outputQ :: TBQueue (Maybe UserId, Either ChatError ChatEvent)
outputQ :: TBQueue (Maybe UserId, Either ChatError ChatEvent)
outputQ,
          TVar SubscriptionMode
subscriptionMode :: TVar SubscriptionMode
subscriptionMode :: TVar SubscriptionMode
subscriptionMode,
          TMVar Text
chatLock :: TMVar Text
chatLock :: TMVar Text
chatLock,
          TMap ChatLockEntity (TMVar Text)
entityLocks :: TMap ChatLockEntity (TMVar Text)
entityLocks :: TMap ChatLockEntity (TMVar Text)
entityLocks,
          TVar (Map UserId Handle)
sndFiles :: TVar (Map UserId Handle)
sndFiles :: TVar (Map UserId Handle)
sndFiles,
          TVar (Map UserId Handle)
rcvFiles :: TVar (Map UserId Handle)
rcvFiles :: TVar (Map UserId Handle)
rcvFiles,
          TMap UserId Call
currentCalls :: TMap UserId Call
currentCalls :: TMap UserId Call
currentCalls,
          TVar Text
localDeviceName :: TVar Text
localDeviceName :: TVar Text
localDeviceName,
          TMVar Int
multicastSubscribers :: TMVar Int
multicastSubscribers :: TMVar Int
multicastSubscribers,
          TVar Int
remoteSessionSeq :: TVar Int
remoteSessionSeq :: TVar Int
remoteSessionSeq,
          TMap RHKey (Int, RemoteHostSession)
remoteHostSessions :: TMap RHKey (Int, RemoteHostSession)
remoteHostSessions :: TMap RHKey (Int, RemoteHostSession)
remoteHostSessions,
          TVar (Maybe HostName)
remoteHostsFolder :: TVar (Maybe HostName)
remoteHostsFolder :: TVar (Maybe HostName)
remoteHostsFolder,
          TVar (Maybe (Int, RemoteCtrlSession))
remoteCtrlSession :: TVar (Maybe (Int, RemoteCtrlSession))
remoteCtrlSession :: TVar (Maybe (Int, RemoteCtrlSession))
remoteCtrlSession,
          ChatConfig
config :: ChatConfig
config :: ChatConfig
config,
          TVar (Maybe HostName)
filesFolder :: TVar (Maybe HostName)
filesFolder :: TVar (Maybe HostName)
filesFolder,
          TMap DeliveryWorkerKey Worker
deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker
deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker
deliveryTaskWorkers,
          TMap DeliveryWorkerKey Worker
deliveryJobWorkers :: TMap DeliveryWorkerKey Worker
deliveryJobWorkers :: TMap DeliveryWorkerKey Worker
deliveryJobWorkers,
          TMap UserId (Maybe (Async ()))
expireCIThreads :: TMap UserId (Maybe (Async ()))
expireCIThreads :: TMap UserId (Maybe (Async ()))
expireCIThreads,
          TMap UserId Bool
expireCIFlags :: TMap UserId Bool
expireCIFlags :: TMap UserId Bool
expireCIFlags,
          TVar (Maybe (Async ()))
cleanupManagerAsync :: TVar (Maybe (Async ()))
cleanupManagerAsync :: TVar (Maybe (Async ()))
cleanupManagerAsync,
          TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
timedItemThreads :: TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
timedItemThreads :: TMap (ChatRef, UserId) (TVar (Maybe (Weak ThreadId)))
timedItemThreads,
          TVar Bool
chatActivated :: TVar Bool
chatActivated :: TVar Bool
chatActivated,
          TVar Bool
showLiveItems :: TVar Bool
showLiveItems :: TVar Bool
showLiveItems,
          TVar Bool
encryptLocalFiles :: TVar Bool
encryptLocalFiles :: TVar Bool
encryptLocalFiles,
          TVar (Maybe HostName)
tempDirectory :: TVar (Maybe HostName)
tempDirectory :: TVar (Maybe HostName)
tempDirectory,
          TVar (Maybe HostName)
assetsDirectory :: TVar (Maybe HostName)
assetsDirectory :: TVar (Maybe HostName)
assetsDirectory,
          logFilePath :: Maybe HostName
logFilePath = Maybe HostName
logFile,
          TVar Bool
contactMergeEnabled :: TVar Bool
contactMergeEnabled :: TVar Bool
contactMergeEnabled
        }
    where
      presetServers' :: PresetServers
      presetServers' :: PresetServers
presetServers' = PresetServers
presetServers {operators = operators', netCfg = netCfg'}
        where
          PresetServers {NonEmpty PresetOperator
operators :: PresetServers -> NonEmpty PresetOperator
operators :: NonEmpty PresetOperator
operators, NetworkConfig
netCfg :: PresetServers -> NetworkConfig
netCfg :: NetworkConfig
netCfg} = PresetServers
presetServers
          netCfg' :: NetworkConfig
netCfg' = NetworkConfig -> SimpleNetCfg -> NetworkConfig
updateNetworkConfig NetworkConfig
netCfg SimpleNetCfg
simpleNetCfg
          operators' :: NonEmpty PresetOperator
operators' = case ([SMPServerWithAuth]
smpServers, [XFTPServerWithAuth]
xftpServers) of
            ([], []) -> NonEmpty PresetOperator
operators
            ([SMPServerWithAuth]
smpSrvs, []) -> (PresetOperator -> PresetOperator)
-> NonEmpty PresetOperator -> NonEmpty PresetOperator
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map PresetOperator -> PresetOperator
disableSMP NonEmpty PresetOperator
operators NonEmpty PresetOperator
-> NonEmpty PresetOperator -> NonEmpty PresetOperator
forall a. Semigroup a => a -> a -> a
<> [[SMPServerWithAuth] -> [XFTPServerWithAuth] -> PresetOperator
custom [SMPServerWithAuth]
smpSrvs []]
            ([], [XFTPServerWithAuth]
xftpSrvs) -> (PresetOperator -> PresetOperator)
-> NonEmpty PresetOperator -> NonEmpty PresetOperator
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map PresetOperator -> PresetOperator
disableXFTP NonEmpty PresetOperator
operators NonEmpty PresetOperator
-> NonEmpty PresetOperator -> NonEmpty PresetOperator
forall a. Semigroup a => a -> a -> a
<> [[SMPServerWithAuth] -> [XFTPServerWithAuth] -> PresetOperator
custom [] [XFTPServerWithAuth]
xftpSrvs]
            ([SMPServerWithAuth]
smpSrvs, [XFTPServerWithAuth]
xftpSrvs) -> [[SMPServerWithAuth] -> [XFTPServerWithAuth] -> PresetOperator
custom [SMPServerWithAuth]
smpSrvs [XFTPServerWithAuth]
xftpSrvs]
          disableSMP :: PresetOperator -> PresetOperator
disableSMP op :: PresetOperator
op@PresetOperator {[NewUserServer 'PSMP]
smp :: PresetOperator -> [NewUserServer 'PSMP]
smp :: [NewUserServer 'PSMP]
smp} = (PresetOperator
op :: PresetOperator) {smp = map disableSrv smp}
          disableXFTP :: PresetOperator -> PresetOperator
disableXFTP op :: PresetOperator
op@PresetOperator {[NewUserServer 'PXFTP]
xftp :: PresetOperator -> [NewUserServer 'PXFTP]
xftp :: [NewUserServer 'PXFTP]
xftp} = (PresetOperator
op :: PresetOperator) {xftp = map disableSrv xftp}
          disableSrv :: forall p. NewUserServer p -> NewUserServer p
          disableSrv :: forall (p :: ProtocolType). NewUserServer p -> NewUserServer p
disableSrv NewUserServer p
srv = (NewUserServer p
srv :: NewUserServer p) {enabled = False}
          custom :: [SMPServerWithAuth] -> [XFTPServerWithAuth] -> PresetOperator
custom [SMPServerWithAuth]
smpSrvs [XFTPServerWithAuth]
xftpSrvs =
            PresetOperator
              { operator :: Maybe NewServerOperator
operator = Maybe NewServerOperator
forall a. Maybe a
Nothing,
                smp :: [NewUserServer 'PSMP]
smp = (SMPServerWithAuth -> NewUserServer 'PSMP)
-> [SMPServerWithAuth] -> [NewUserServer 'PSMP]
forall a b. (a -> b) -> [a] -> [b]
map SMPServerWithAuth -> NewUserServer 'PSMP
forall (p :: ProtocolType).
ProtoServerWithAuth p -> NewUserServer p
newUserServer [SMPServerWithAuth]
smpSrvs,
                useSMP :: Int
useSMP = Int
0,
                xftp :: [NewUserServer 'PXFTP]
xftp = (XFTPServerWithAuth -> NewUserServer 'PXFTP)
-> [XFTPServerWithAuth] -> [NewUserServer 'PXFTP]
forall a b. (a -> b) -> [a] -> [b]
map XFTPServerWithAuth -> NewUserServer 'PXFTP
forall (p :: ProtocolType).
ProtoServerWithAuth p -> NewUserServer p
newUserServer [XFTPServerWithAuth]
xftpSrvs,
                useXFTP :: Int
useXFTP = Int
0
              }
      randomServerCfgs :: UserProtocol p => String -> SProtocolType p -> [(Text, ServerOperator)] -> [PresetOperator] -> IO (NonEmpty (ServerCfg p))
      randomServerCfgs :: forall (p :: ProtocolType).
UserProtocol p =>
HostName
-> SProtocolType p
-> [(Text, ServerOperator' 'DBStored)]
-> [PresetOperator]
-> IO (NonEmpty (ServerCfg p))
randomServerCfgs HostName
name SProtocolType p
p [(Text, ServerOperator' 'DBStored)]
opDomains [PresetOperator]
rndSrvs =
        HostName
-> Maybe (NonEmpty (ServerCfg p)) -> IO (NonEmpty (ServerCfg p))
forall a. HostName -> Maybe a -> IO a
toJustOrError HostName
name (Maybe (NonEmpty (ServerCfg p)) -> IO (NonEmpty (ServerCfg p)))
-> Maybe (NonEmpty (ServerCfg p)) -> IO (NonEmpty (ServerCfg p))
forall a b. (a -> b) -> a -> b
$ [ServerCfg p] -> Maybe (NonEmpty (ServerCfg p))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty ([ServerCfg p] -> Maybe (NonEmpty (ServerCfg p)))
-> [ServerCfg p] -> Maybe (NonEmpty (ServerCfg p))
forall a b. (a -> b) -> a -> b
$ SProtocolType p
-> [(Text, ServerOperator' 'DBStored)]
-> [UserServer' 'DBNew p]
-> [ServerCfg p]
forall (p :: ProtocolType) (s :: DBStored).
UserProtocol p =>
SProtocolType p
-> [(Text, ServerOperator' 'DBStored)]
-> [UserServer' s p]
-> [ServerCfg p]
agentServerCfgs SProtocolType p
p [(Text, ServerOperator' 'DBStored)]
opDomains ([UserServer' 'DBNew p] -> [ServerCfg p])
-> [UserServer' 'DBNew p] -> [ServerCfg p]
forall a b. (a -> b) -> a -> b
$ (PresetOperator -> [UserServer' 'DBNew p])
-> [PresetOperator] -> [UserServer' 'DBNew p]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SProtocolType p -> PresetOperator -> [UserServer' 'DBNew p]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> [NewUserServer p]
pServers SProtocolType p
p) [PresetOperator]
rndSrvs
      agentServers :: DB.Connection -> ChatConfig -> NonEmpty PresetOperator -> RandomAgentServers -> IO InitialAgentServers
      agentServers :: Connection
-> ChatConfig
-> NonEmpty PresetOperator
-> RandomAgentServers
-> IO InitialAgentServers
agentServers Connection
db ChatConfig {presetServers :: ChatConfig -> PresetServers
presetServers = PresetServers {[NtfServer]
ntf :: PresetServers -> [NtfServer]
ntf :: [NtfServer]
ntf, NetworkConfig
netCfg :: PresetServers -> NetworkConfig
netCfg :: NetworkConfig
netCfg}, [HostName]
presetDomains :: ChatConfig -> [HostName]
presetDomains :: [HostName]
presetDomains} NonEmpty PresetOperator
presetOps RandomAgentServers
as = do
        [User]
users <- Connection -> IO [User]
getUsers Connection
db
        [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
ops <- Connection
-> NonEmpty PresetOperator
-> Bool
-> IO [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
getUpdateServerOperators Connection
db NonEmpty PresetOperator
presetOps ([User] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [User]
users)
        let opDomains :: [(Text, ServerOperator' 'DBStored)]
opDomains = [ServerOperator' 'DBStored] -> [(Text, ServerOperator' 'DBStored)]
forall (s :: DBStored).
[ServerOperator' s] -> [(Text, ServerOperator' s)]
operatorDomains ([ServerOperator' 'DBStored]
 -> [(Text, ServerOperator' 'DBStored)])
-> [ServerOperator' 'DBStored]
-> [(Text, ServerOperator' 'DBStored)]
forall a b. (a -> b) -> a -> b
$ ((Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))
 -> Maybe (ServerOperator' 'DBStored))
-> [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
-> [ServerOperator' 'DBStored]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))
-> Maybe (ServerOperator' 'DBStored)
forall a b. (a, b) -> b
snd [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
ops
        ([(UserId, NonEmpty (ServerCfg 'PSMP))]
smp', [(UserId, NonEmpty (ServerCfg 'PXFTP))]
xftp') <- [((UserId, NonEmpty (ServerCfg 'PSMP)),
  (UserId, NonEmpty (ServerCfg 'PXFTP)))]
-> ([(UserId, NonEmpty (ServerCfg 'PSMP))],
    [(UserId, NonEmpty (ServerCfg 'PXFTP))])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((UserId, NonEmpty (ServerCfg 'PSMP)),
   (UserId, NonEmpty (ServerCfg 'PXFTP)))]
 -> ([(UserId, NonEmpty (ServerCfg 'PSMP))],
     [(UserId, NonEmpty (ServerCfg 'PXFTP))]))
-> IO
     [((UserId, NonEmpty (ServerCfg 'PSMP)),
       (UserId, NonEmpty (ServerCfg 'PXFTP)))]
-> IO
     ([(UserId, NonEmpty (ServerCfg 'PSMP))],
      [(UserId, NonEmpty (ServerCfg 'PXFTP))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (User
 -> IO
      ((UserId, NonEmpty (ServerCfg 'PSMP)),
       (UserId, NonEmpty (ServerCfg 'PXFTP))))
-> [User]
-> IO
     [((UserId, NonEmpty (ServerCfg 'PSMP)),
       (UserId, NonEmpty (ServerCfg 'PXFTP)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
-> [(Text, ServerOperator' 'DBStored)]
-> User
-> IO
     ((UserId, NonEmpty (ServerCfg 'PSMP)),
      (UserId, NonEmpty (ServerCfg 'PXFTP)))
getServers [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
ops [(Text, ServerOperator' 'DBStored)]
opDomains) [User]
users
        InitialAgentServers -> IO InitialAgentServers
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InitialAgentServers {smp :: Map UserId (NonEmpty (ServerCfg 'PSMP))
smp = [(UserId, NonEmpty (ServerCfg 'PSMP))]
-> Map UserId (NonEmpty (ServerCfg 'PSMP))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(UserId, NonEmpty (ServerCfg 'PSMP))]
-> [SMPServerWithAuth] -> [(UserId, NonEmpty (ServerCfg 'PSMP))]
forall (p :: ProtocolType).
[(UserId, NonEmpty (ServerCfg p))]
-> [ProtoServerWithAuth p] -> [(UserId, NonEmpty (ServerCfg p))]
optServers [(UserId, NonEmpty (ServerCfg 'PSMP))]
smp' [SMPServerWithAuth]
smpServers), xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP))
xftp = [(UserId, NonEmpty (ServerCfg 'PXFTP))]
-> Map UserId (NonEmpty (ServerCfg 'PXFTP))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(UserId, NonEmpty (ServerCfg 'PXFTP))]
-> [XFTPServerWithAuth] -> [(UserId, NonEmpty (ServerCfg 'PXFTP))]
forall (p :: ProtocolType).
[(UserId, NonEmpty (ServerCfg p))]
-> [ProtoServerWithAuth p] -> [(UserId, NonEmpty (ServerCfg p))]
optServers [(UserId, NonEmpty (ServerCfg 'PXFTP))]
xftp' [XFTPServerWithAuth]
xftpServers), [NtfServer]
ntf :: [NtfServer]
ntf :: [NtfServer]
ntf, NetworkConfig
netCfg :: NetworkConfig
netCfg :: NetworkConfig
netCfg, [HostName]
presetDomains :: [HostName]
presetDomains :: [HostName]
presetDomains, presetServers :: [SMPServer]
presetServers = NonEmpty SMPServer -> [SMPServer]
forall a. NonEmpty a -> [a]
L.toList NonEmpty SMPServer
allPresetServers}
        where
          optServers :: [(UserId, NonEmpty (ServerCfg p))] -> [ProtoServerWithAuth p] -> [(UserId, NonEmpty (ServerCfg p))]
          optServers :: forall (p :: ProtocolType).
[(UserId, NonEmpty (ServerCfg p))]
-> [ProtoServerWithAuth p] -> [(UserId, NonEmpty (ServerCfg p))]
optServers [(UserId, NonEmpty (ServerCfg p))]
srvs [ProtoServerWithAuth p]
overrides_ = case [ProtoServerWithAuth p] -> Maybe (NonEmpty (ProtoServerWithAuth p))
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [ProtoServerWithAuth p]
overrides_ of
            Just NonEmpty (ProtoServerWithAuth p)
overrides -> ((UserId, NonEmpty (ServerCfg p))
 -> (UserId, NonEmpty (ServerCfg p)))
-> [(UserId, NonEmpty (ServerCfg p))]
-> [(UserId, NonEmpty (ServerCfg p))]
forall a b. (a -> b) -> [a] -> [b]
map ((NonEmpty (ServerCfg p) -> NonEmpty (ServerCfg p))
-> (UserId, NonEmpty (ServerCfg p))
-> (UserId, NonEmpty (ServerCfg p))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((NonEmpty (ServerCfg p) -> NonEmpty (ServerCfg p))
 -> (UserId, NonEmpty (ServerCfg p))
 -> (UserId, NonEmpty (ServerCfg p)))
-> (NonEmpty (ServerCfg p) -> NonEmpty (ServerCfg p))
-> (UserId, NonEmpty (ServerCfg p))
-> (UserId, NonEmpty (ServerCfg p))
forall a b. (a -> b) -> a -> b
$ NonEmpty (ServerCfg p)
-> NonEmpty (ServerCfg p) -> NonEmpty (ServerCfg p)
forall a b. a -> b -> a
const (NonEmpty (ServerCfg p)
 -> NonEmpty (ServerCfg p) -> NonEmpty (ServerCfg p))
-> NonEmpty (ServerCfg p)
-> NonEmpty (ServerCfg p)
-> NonEmpty (ServerCfg p)
forall a b. (a -> b) -> a -> b
$ (ProtoServerWithAuth p -> ServerCfg p)
-> NonEmpty (ProtoServerWithAuth p) -> NonEmpty (ServerCfg p)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (Bool
-> ServerRoles
-> Maybe UserId
-> ProtoServerWithAuth p
-> ServerCfg p
forall (p :: ProtocolType).
Bool
-> ServerRoles
-> Maybe UserId
-> ProtoServerWithAuth p
-> ServerCfg p
presetServerCfg Bool
True ServerRoles
allRoles Maybe UserId
forall a. Maybe a
Nothing) NonEmpty (ProtoServerWithAuth p)
overrides) [(UserId, NonEmpty (ServerCfg p))]
srvs
            Maybe (NonEmpty (ProtoServerWithAuth p))
Nothing -> [(UserId, NonEmpty (ServerCfg p))]
srvs
          getServers :: [(Maybe PresetOperator, Maybe ServerOperator)] -> [(Text, ServerOperator)] -> User -> IO ((UserId, NonEmpty (ServerCfg 'PSMP)), (UserId, NonEmpty (ServerCfg 'PXFTP)))
          getServers :: [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
-> [(Text, ServerOperator' 'DBStored)]
-> User
-> IO
     ((UserId, NonEmpty (ServerCfg 'PSMP)),
      (UserId, NonEmpty (ServerCfg 'PXFTP)))
getServers [(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
ops [(Text, ServerOperator' 'DBStored)]
opDomains User
user' = do
            [UserServer 'PSMP]
smpSrvs <- Connection -> SProtocolType 'PSMP -> User -> IO [UserServer 'PSMP]
forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers Connection
db SProtocolType 'PSMP
SPSMP User
user'
            [UserServer 'PXFTP]
xftpSrvs <- Connection
-> SProtocolType 'PXFTP -> User -> IO [UserServer 'PXFTP]
forall (p :: ProtocolType).
ProtocolTypeI p =>
Connection -> SProtocolType p -> User -> IO [UserServer p]
getProtocolServers Connection
db SProtocolType 'PXFTP
SPXFTP User
user'
            [(Maybe PresetOperator, UserOperatorServers)]
uss <- ([(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))],
 [UserServer 'PSMP], [UserServer 'PXFTP])
-> IO [(Maybe PresetOperator, UserOperatorServers)]
groupByOperator' ([(Maybe PresetOperator, Maybe (ServerOperator' 'DBStored))]
ops, [UserServer 'PSMP]
smpSrvs, [UserServer 'PXFTP]
xftpSrvs)
            UTCTime
ts <- IO UTCTime
getCurrentTime
            [UserOperatorServers]
uss' <- ((Maybe PresetOperator, UserOperatorServers)
 -> IO UserOperatorServers)
-> [(Maybe PresetOperator, UserOperatorServers)]
-> IO [UserOperatorServers]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Connection
-> User
-> UTCTime
-> UpdatedUserOperatorServers
-> IO UserOperatorServers
setUserServers' Connection
db User
user' UTCTime
ts (UpdatedUserOperatorServers -> IO UserOperatorServers)
-> ((Maybe PresetOperator, UserOperatorServers)
    -> UpdatedUserOperatorServers)
-> (Maybe PresetOperator, UserOperatorServers)
-> IO UserOperatorServers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe PresetOperator, UserOperatorServers)
-> UpdatedUserOperatorServers
updatedUserServers) [(Maybe PresetOperator, UserOperatorServers)]
uss
            let auId :: UserId
auId = User -> UserId
aUserId User
user'
            ((UserId, NonEmpty (ServerCfg 'PSMP)),
 (UserId, NonEmpty (ServerCfg 'PXFTP)))
-> IO
     ((UserId, NonEmpty (ServerCfg 'PSMP)),
      (UserId, NonEmpty (ServerCfg 'PXFTP)))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((UserId, NonEmpty (ServerCfg 'PSMP)),
  (UserId, NonEmpty (ServerCfg 'PXFTP)))
 -> IO
      ((UserId, NonEmpty (ServerCfg 'PSMP)),
       (UserId, NonEmpty (ServerCfg 'PXFTP))))
-> ((UserId, NonEmpty (ServerCfg 'PSMP)),
    (UserId, NonEmpty (ServerCfg 'PXFTP)))
-> IO
     ((UserId, NonEmpty (ServerCfg 'PSMP)),
      (UserId, NonEmpty (ServerCfg 'PXFTP)))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (ServerCfg 'PSMP)
 -> (UserId, NonEmpty (ServerCfg 'PSMP)))
-> (NonEmpty (ServerCfg 'PXFTP)
    -> (UserId, NonEmpty (ServerCfg 'PXFTP)))
-> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))
-> ((UserId, NonEmpty (ServerCfg 'PSMP)),
    (UserId, NonEmpty (ServerCfg 'PXFTP)))
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (UserId
auId,) (UserId
auId,) ((NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))
 -> ((UserId, NonEmpty (ServerCfg 'PSMP)),
     (UserId, NonEmpty (ServerCfg 'PXFTP))))
-> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))
-> ((UserId, NonEmpty (ServerCfg 'PSMP)),
    (UserId, NonEmpty (ServerCfg 'PXFTP)))
forall a b. (a -> b) -> a -> b
$ RandomAgentServers
-> [(Text, ServerOperator' 'DBStored)]
-> [UserOperatorServers]
-> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))
forall (f :: * -> *).
Foldable f =>
RandomAgentServers
-> [(Text, ServerOperator' 'DBStored)]
-> f UserOperatorServers
-> (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))
useServers RandomAgentServers
as [(Text, ServerOperator' 'DBStored)]
opDomains [UserOperatorServers]
uss'

chooseRandomServers :: PresetServers -> IO (NonEmpty PresetOperator)
chooseRandomServers :: PresetServers -> IO (NonEmpty PresetOperator)
chooseRandomServers PresetServers {NonEmpty PresetOperator
operators :: PresetServers -> NonEmpty PresetOperator
operators :: NonEmpty PresetOperator
operators} =
  NonEmpty PresetOperator
-> (PresetOperator -> IO PresetOperator)
-> IO (NonEmpty PresetOperator)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM NonEmpty PresetOperator
operators ((PresetOperator -> IO PresetOperator)
 -> IO (NonEmpty PresetOperator))
-> (PresetOperator -> IO PresetOperator)
-> IO (NonEmpty PresetOperator)
forall a b. (a -> b) -> a -> b
$ \PresetOperator
op -> do
    [NewUserServer 'PSMP]
smp' <- SProtocolType 'PSMP -> PresetOperator -> IO [NewUserServer 'PSMP]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> IO [NewUserServer p]
opSrvs SProtocolType 'PSMP
SPSMP PresetOperator
op
    [NewUserServer 'PXFTP]
xftp' <- SProtocolType 'PXFTP -> PresetOperator -> IO [NewUserServer 'PXFTP]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> IO [NewUserServer p]
opSrvs SProtocolType 'PXFTP
SPXFTP PresetOperator
op
    PresetOperator -> IO PresetOperator
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PresetOperator
op :: PresetOperator) {smp = smp', xftp = xftp'}
  where
    opSrvs :: forall p. UserProtocol p => SProtocolType p -> PresetOperator -> IO [NewUserServer p]
    opSrvs :: forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> IO [NewUserServer p]
opSrvs SProtocolType p
p PresetOperator
op = do
      let srvs :: [NewUserServer p]
srvs = SProtocolType p -> PresetOperator -> [NewUserServer p]
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> [NewUserServer p]
pServers SProtocolType p
p PresetOperator
op
          toUse :: Int
toUse = SProtocolType p -> PresetOperator -> Int
forall (p :: ProtocolType).
UserProtocol p =>
SProtocolType p -> PresetOperator -> Int
operatorServersToUse SProtocolType p
p PresetOperator
op
          ([NewUserServer p]
enbldSrvs, [NewUserServer p]
dsbldSrvs) = (NewUserServer p -> Bool)
-> [NewUserServer p] -> ([NewUserServer p], [NewUserServer p])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\UserServer {Bool
enabled :: Bool
enabled :: forall (s :: DBStored) (p :: ProtocolType). UserServer' s p -> Bool
enabled} -> Bool
enabled) [NewUserServer p]
srvs
      if Int
toUse Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
toUse Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [NewUserServer p] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NewUserServer p]
enbldSrvs
        then [NewUserServer p] -> IO [NewUserServer p]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NewUserServer p]
srvs
        else do
          ([NewUserServer p]
enbldSrvs', [NewUserServer p]
srvsToDisable) <- Int -> [NewUserServer p] -> ([NewUserServer p], [NewUserServer p])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
toUse ([NewUserServer p] -> ([NewUserServer p], [NewUserServer p]))
-> IO [NewUserServer p]
-> IO ([NewUserServer p], [NewUserServer p])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NewUserServer p] -> IO [NewUserServer p]
forall a. [a] -> IO [a]
shuffle [NewUserServer p]
enbldSrvs
          let dsbldSrvs' :: [NewUserServer p]
dsbldSrvs' = (NewUserServer p -> NewUserServer p)
-> [NewUserServer p] -> [NewUserServer p]
forall a b. (a -> b) -> [a] -> [b]
map (\NewUserServer p
srv -> (NewUserServer p
srv :: NewUserServer p) {enabled = False}) [NewUserServer p]
srvsToDisable
          [NewUserServer p] -> IO [NewUserServer p]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([NewUserServer p] -> IO [NewUserServer p])
-> [NewUserServer p] -> IO [NewUserServer p]
forall a b. (a -> b) -> a -> b
$ (NewUserServer p -> ProtocolServer p)
-> [NewUserServer p] -> [NewUserServer p]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn NewUserServer p -> ProtocolServer p
forall {s :: DBStored} {p :: ProtocolType}.
UserServer' s p -> ProtocolServer p
server' ([NewUserServer p] -> [NewUserServer p])
-> [NewUserServer p] -> [NewUserServer p]
forall a b. (a -> b) -> a -> b
$ [NewUserServer p]
enbldSrvs' [NewUserServer p] -> [NewUserServer p] -> [NewUserServer p]
forall a. Semigroup a => a -> a -> a
<> [NewUserServer p]
dsbldSrvs' [NewUserServer p] -> [NewUserServer p] -> [NewUserServer p]
forall a. Semigroup a => a -> a -> a
<> [NewUserServer p]
dsbldSrvs
    server' :: UserServer' s p -> ProtocolServer p
server' UserServer {server :: forall (s :: DBStored) (p :: ProtocolType).
UserServer' s p -> ProtoServerWithAuth p
server = ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_} = ProtocolServer p
srv

toJustOrError :: String -> Maybe a -> IO a
toJustOrError :: forall a. HostName -> Maybe a -> IO a
toJustOrError HostName
name = \case
  Just a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Maybe a
Nothing -> do
    HostName -> IO ()
putStrLn (HostName -> IO ()) -> HostName -> IO ()
forall a b. (a -> b) -> a -> b
$ HostName
name HostName -> HostName -> HostName
forall a. Semigroup a => a -> a -> a
<> HostName
": expected Just, exiting"
    IOError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ HostName -> IOError
userError HostName
name