{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

module Simplex.Messaging.Agent.Env.SQLite
  ( AM',
    AM,
    AgentConfig (..),
    InitialAgentServers (..),
    ServerCfg (..),
    ServerRoles (..),
    OperatorId,
    UserServers (..),
    NetworkConfig (..),
    presetServerCfg,
    allRoles,
    mkUserServers,
    serverHosts,
    defaultAgentConfig,
    defaultReconnectInterval,
    Env (..),
    newSMPAgentEnv,
    createAgentStore,
    NtfSupervisor (..),
    NtfSupervisorCommand (..),
    XFTPAgent (..),
    Worker (..),
    RestartCount (..),
    updateRestartCount,
  )
where

import Control.Concurrent (ThreadId)
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Crypto.Random
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson.TH as JQ
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Time.Clock (NominalDiffTime, nominalDay)
import Data.Time.Clock.System (SystemTime (..))
import Data.Word (Word16)
import Network.Socket
import Numeric.Natural
import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig)
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store (createStore)
import Simplex.Messaging.Agent.Store.Common (DBStore)
import Simplex.Messaging.Agent.Store.Interface (DBOpts)
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Notifications.Transport (NTFVersion)
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Parsers (defaultJSON)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI, VersionRangeSMPC, XFTPServer, supportedSMPClientVRange)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SMPVersion)
import Simplex.Messaging.Transport.Client (TransportHost)
import System.Mem.Weak (Weak)
import System.Random (StdGen, newStdGen)
import UnliftIO.STM

type AM' a = ReaderT Env IO a

type AM a = ExceptT AgentErrorType (ReaderT Env IO) a

data InitialAgentServers = InitialAgentServers
  { InitialAgentServers -> Map Int64 (NonEmpty (ServerCfg 'PSMP))
smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)),
    InitialAgentServers -> [NtfServer]
ntf :: [NtfServer],
    InitialAgentServers -> Map Int64 (NonEmpty (ServerCfg 'PXFTP))
xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
    InitialAgentServers -> NetworkConfig
netCfg :: NetworkConfig,
    InitialAgentServers -> [HostName]
presetDomains :: [HostName],
    InitialAgentServers -> [SMPServer]
presetServers :: [SMPServer]
  }

data ServerCfg p = ServerCfg
  { forall (p :: ProtocolType). ServerCfg p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p,
    forall (p :: ProtocolType). ServerCfg p -> Maybe Int64
operator :: Maybe OperatorId,
    forall (p :: ProtocolType). ServerCfg p -> Bool
enabled :: Bool,
    forall (p :: ProtocolType). ServerCfg p -> ServerRoles
roles :: ServerRoles
  }
  deriving (Int -> ServerCfg p -> ShowS
[ServerCfg p] -> ShowS
ServerCfg p -> HostName
(Int -> ServerCfg p -> ShowS)
-> (ServerCfg p -> HostName)
-> ([ServerCfg p] -> ShowS)
-> Show (ServerCfg p)
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
forall (p :: ProtocolType). Int -> ServerCfg p -> ShowS
forall (p :: ProtocolType). [ServerCfg p] -> ShowS
forall (p :: ProtocolType). ServerCfg p -> HostName
$cshowsPrec :: forall (p :: ProtocolType). Int -> ServerCfg p -> ShowS
showsPrec :: Int -> ServerCfg p -> ShowS
$cshow :: forall (p :: ProtocolType). ServerCfg p -> HostName
show :: ServerCfg p -> HostName
$cshowList :: forall (p :: ProtocolType). [ServerCfg p] -> ShowS
showList :: [ServerCfg p] -> ShowS
Show)

data ServerRoles = ServerRoles
  { ServerRoles -> Bool
storage :: Bool,
    ServerRoles -> Bool
proxy :: Bool
  }
  deriving (Int -> ServerRoles -> ShowS
[ServerRoles] -> ShowS
ServerRoles -> HostName
(Int -> ServerRoles -> ShowS)
-> (ServerRoles -> HostName)
-> ([ServerRoles] -> ShowS)
-> Show ServerRoles
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerRoles -> ShowS
showsPrec :: Int -> ServerRoles -> ShowS
$cshow :: ServerRoles -> HostName
show :: ServerRoles -> HostName
$cshowList :: [ServerRoles] -> ShowS
showList :: [ServerRoles] -> ShowS
Show)

allRoles :: ServerRoles
allRoles :: ServerRoles
allRoles = Bool -> Bool -> ServerRoles
ServerRoles Bool
True Bool
True

presetServerCfg :: Bool -> ServerRoles -> Maybe OperatorId -> ProtoServerWithAuth p -> ServerCfg p
presetServerCfg :: forall (p :: ProtocolType).
Bool
-> ServerRoles
-> Maybe Int64
-> ProtoServerWithAuth p
-> ServerCfg p
presetServerCfg Bool
enabled ServerRoles
roles Maybe Int64
operator ProtoServerWithAuth p
server =
  ServerCfg {ProtoServerWithAuth p
$sel:server:ServerCfg :: ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server, Maybe Int64
$sel:operator:ServerCfg :: Maybe Int64
operator :: Maybe Int64
operator, Bool
$sel:enabled:ServerCfg :: Bool
enabled :: Bool
enabled, ServerRoles
$sel:roles:ServerCfg :: ServerRoles
roles :: ServerRoles
roles}

data UserServers p = UserServers
  { forall (p :: ProtocolType).
UserServers p -> NonEmpty (Maybe Int64, ProtoServerWithAuth p)
storageSrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
    forall (p :: ProtocolType).
UserServers p -> NonEmpty (Maybe Int64, ProtoServerWithAuth p)
proxySrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
    forall (p :: ProtocolType). UserServers p -> Set TransportHost
knownHosts :: Set TransportHost
  }

type OperatorId = Int64

-- This function sets all servers as enabled in case all passed servers are disabled.
mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p
mkUserServers :: forall (p :: ProtocolType). NonEmpty (ServerCfg p) -> UserServers p
mkUserServers NonEmpty (ServerCfg p)
srvs = UserServers {$sel:storageSrvs:UserServers :: NonEmpty (Maybe Int64, ProtoServerWithAuth p)
storageSrvs = (ServerRoles -> Bool)
-> NonEmpty (Maybe Int64, ProtoServerWithAuth p)
filterSrvs ServerRoles -> Bool
storage, $sel:proxySrvs:UserServers :: NonEmpty (Maybe Int64, ProtoServerWithAuth p)
proxySrvs = (ServerRoles -> Bool)
-> NonEmpty (Maybe Int64, ProtoServerWithAuth p)
filterSrvs ServerRoles -> Bool
proxy, Set TransportHost
$sel:knownHosts:UserServers :: Set TransportHost
knownHosts :: Set TransportHost
knownHosts}
  where
    filterSrvs :: (ServerRoles -> Bool)
-> NonEmpty (Maybe Int64, ProtoServerWithAuth p)
filterSrvs ServerRoles -> Bool
role = (ServerCfg p -> (Maybe Int64, ProtoServerWithAuth p))
-> NonEmpty (ServerCfg p)
-> NonEmpty (Maybe Int64, ProtoServerWithAuth p)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\ServerCfg {Maybe Int64
$sel:operator:ServerCfg :: forall (p :: ProtocolType). ServerCfg p -> Maybe Int64
operator :: Maybe Int64
operator, ProtoServerWithAuth p
$sel:server:ServerCfg :: forall (p :: ProtocolType). ServerCfg p -> ProtoServerWithAuth p
server :: ProtoServerWithAuth p
server} -> (Maybe Int64
operator, ProtoServerWithAuth p
server)) (NonEmpty (ServerCfg p)
 -> NonEmpty (Maybe Int64, ProtoServerWithAuth p))
-> NonEmpty (ServerCfg p)
-> NonEmpty (Maybe Int64, ProtoServerWithAuth p)
forall a b. (a -> b) -> a -> b
$ NonEmpty (ServerCfg p)
-> Maybe (NonEmpty (ServerCfg p)) -> NonEmpty (ServerCfg p)
forall a. a -> Maybe a -> a
fromMaybe NonEmpty (ServerCfg p)
srvs (Maybe (NonEmpty (ServerCfg p)) -> NonEmpty (ServerCfg p))
-> Maybe (NonEmpty (ServerCfg p)) -> 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
$ (ServerCfg p -> Bool) -> NonEmpty (ServerCfg p) -> [ServerCfg p]
forall a. (a -> Bool) -> NonEmpty a -> [a]
L.filter (\ServerCfg {Bool
$sel:enabled:ServerCfg :: forall (p :: ProtocolType). ServerCfg p -> Bool
enabled :: Bool
enabled, ServerRoles
$sel:roles:ServerCfg :: forall (p :: ProtocolType). ServerCfg p -> ServerRoles
roles :: ServerRoles
roles} -> Bool
enabled Bool -> Bool -> Bool
&& ServerRoles -> Bool
role ServerRoles
roles) NonEmpty (ServerCfg p)
srvs
    knownHosts :: Set TransportHost
knownHosts = NonEmpty (Set TransportHost) -> Set TransportHost
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (NonEmpty (Set TransportHost) -> Set TransportHost)
-> NonEmpty (Set TransportHost) -> Set TransportHost
forall a b. (a -> b) -> a -> b
$ (ServerCfg p -> Set TransportHost)
-> NonEmpty (ServerCfg p) -> NonEmpty (Set TransportHost)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\ServerCfg {$sel:server:ServerCfg :: forall (p :: ProtocolType). ServerCfg p -> ProtoServerWithAuth p
server = ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_} -> ProtocolServer p -> Set TransportHost
forall (p :: ProtocolType). ProtocolServer p -> Set TransportHost
serverHosts ProtocolServer p
srv) NonEmpty (ServerCfg p)
srvs

serverHosts :: ProtocolServer p -> Set TransportHost
serverHosts :: forall (p :: ProtocolType). ProtocolServer p -> Set TransportHost
serverHosts ProtocolServer {NonEmpty TransportHost
host :: NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host} = [TransportHost] -> Set TransportHost
forall a. Ord a => [a] -> Set a
S.fromList ([TransportHost] -> Set TransportHost)
-> [TransportHost] -> Set TransportHost
forall a b. (a -> b) -> a -> b
$ NonEmpty TransportHost -> [TransportHost]
forall a. NonEmpty a -> [a]
L.toList NonEmpty TransportHost
host

data AgentConfig = AgentConfig
  { AgentConfig -> Maybe HostName
tcpPort :: Maybe ServiceName,
    AgentConfig -> AuthAlg
rcvAuthAlg :: C.AuthAlg,
    AgentConfig -> AuthAlg
sndAuthAlg :: C.AuthAlg,
    AgentConfig -> Int
connIdBytes :: Int,
    AgentConfig -> Natural
tbqSize :: Natural,
    AgentConfig -> ProtocolClientConfig SMPVersion
smpCfg :: ProtocolClientConfig SMPVersion,
    AgentConfig -> ProtocolClientConfig NTFVersion
ntfCfg :: ProtocolClientConfig NTFVersion,
    AgentConfig -> XFTPClientConfig
xftpCfg :: XFTPClientConfig,
    AgentConfig -> RetryInterval
reconnectInterval :: RetryInterval,
    AgentConfig -> RetryInterval2
messageRetryInterval :: RetryInterval2,
    AgentConfig -> Int
userNetworkInterval :: Int,
    AgentConfig -> NominalDiffTime
userOfflineDelay :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
messageTimeout :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
connDeleteDeliveryTimeout :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
helloTimeout :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
quotaExceededTimeout :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
persistErrorInterval :: NominalDiffTime,
    AgentConfig -> Int64
initialCleanupDelay :: Int64,
    AgentConfig -> Int64
cleanupInterval :: Int64,
    AgentConfig -> Int
cleanupBatchSize :: Int,
    AgentConfig -> Int64
initialLogStatsDelay :: Int64,
    AgentConfig -> Int64
logStatsInterval :: Int64,
    AgentConfig -> Int
cleanupStepInterval :: Int,
    AgentConfig -> Int
maxWorkerRestartsPerMin :: Int,
    AgentConfig -> NominalDiffTime
storedMsgDataTTL :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
rcvFilesTTL :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
sndFilesTTL :: NominalDiffTime,
    AgentConfig -> Int
xftpConsecutiveRetries :: Int,
    AgentConfig -> Int
xftpMaxRecipientsPerRequest :: Int,
    AgentConfig -> Int
deleteErrorCount :: Int,
    AgentConfig -> Word16
ntfCron :: Word16,
    AgentConfig -> Int
ntfBatchSize :: Int,
    AgentConfig -> NominalDiffTime
ntfSubFirstCheckInterval :: NominalDiffTime,
    AgentConfig -> NominalDiffTime
ntfSubCheckInterval :: NominalDiffTime,
    AgentConfig -> Int
subsBatchSize :: Int,
    AgentConfig -> HostName
caCertificateFile :: FilePath,
    AgentConfig -> HostName
privateKeyFile :: FilePath,
    AgentConfig -> HostName
certificateFile :: FilePath,
    AgentConfig -> Int
rcvExpireCount :: Int,
    AgentConfig -> NominalDiffTime
rcvExpireInterval :: NominalDiffTime,
    AgentConfig -> VersionRangeE2E
e2eEncryptVRange :: VersionRangeE2E,
    AgentConfig -> VersionRangeSMPA
smpAgentVRange :: VersionRangeSMPA,
    AgentConfig -> VersionRangeSMPC
smpClientVRange :: VersionRangeSMPC
  }

defaultReconnectInterval :: RetryInterval
defaultReconnectInterval :: RetryInterval
defaultReconnectInterval =
  RetryInterval
    { initialInterval :: Int64
initialInterval = Int64
2_000000,
      increaseAfter :: Int64
increaseAfter = Int64
10_000000,
      maxInterval :: Int64
maxInterval = Int64
180_000000
    }

defaultMessageRetryInterval :: RetryInterval2
defaultMessageRetryInterval :: RetryInterval2
defaultMessageRetryInterval =
  RetryInterval2
    { riFast :: RetryInterval
riFast =
        RetryInterval
          { initialInterval :: Int64
initialInterval = Int64
2_000000,
            increaseAfter :: Int64
increaseAfter = Int64
10_000000,
            maxInterval :: Int64
maxInterval = Int64
120_000000
          },
      riSlow :: RetryInterval
riSlow =
        RetryInterval
          { initialInterval :: Int64
initialInterval = Int64
300_000000, -- 5 minutes
            increaseAfter :: Int64
increaseAfter = Int64
60_000000,
            maxInterval :: Int64
maxInterval = Int64
6 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
3600_000000 -- 6 hours
          }
    }

defaultAgentConfig :: AgentConfig
defaultAgentConfig :: AgentConfig
defaultAgentConfig =
  AgentConfig
    { $sel:tcpPort:AgentConfig :: Maybe HostName
tcpPort = HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
"5224",
      -- while the current client version supports X25519, it can only be enabled once support for SMP v6 is dropped,
      -- and all servers are required to support v7 to be compatible.
      $sel:rcvAuthAlg:AgentConfig :: AuthAlg
rcvAuthAlg = SAlgorithm 'Ed25519 -> AuthAlg
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> AuthAlg
C.AuthAlg SAlgorithm 'Ed25519
C.SEd25519, -- this will stay as Ed25519
      $sel:sndAuthAlg:AgentConfig :: AuthAlg
sndAuthAlg = SAlgorithm 'Ed25519 -> AuthAlg
forall (a :: Algorithm).
(AlgorithmI a, AuthAlgorithm a) =>
SAlgorithm a -> AuthAlg
C.AuthAlg SAlgorithm 'Ed25519
C.SEd25519, -- TODO replace with X25519 when switching to v7
      $sel:connIdBytes:AgentConfig :: Int
connIdBytes = Int
12,
      $sel:tbqSize:AgentConfig :: Natural
tbqSize = Natural
128,
      $sel:smpCfg:AgentConfig :: ProtocolClientConfig SMPVersion
smpCfg = ProtocolClientConfig SMPVersion
defaultSMPClientConfig,
      $sel:ntfCfg:AgentConfig :: ProtocolClientConfig NTFVersion
ntfCfg = ProtocolClientConfig NTFVersion
defaultNTFClientConfig,
      $sel:xftpCfg:AgentConfig :: XFTPClientConfig
xftpCfg = XFTPClientConfig
defaultXFTPClientConfig,
      $sel:reconnectInterval:AgentConfig :: RetryInterval
reconnectInterval = RetryInterval
defaultReconnectInterval,
      $sel:messageRetryInterval:AgentConfig :: RetryInterval2
messageRetryInterval = RetryInterval2
defaultMessageRetryInterval,
      $sel:userNetworkInterval:AgentConfig :: Int
userNetworkInterval = Int
1800_000000, -- 30 minutes, should be less than Int32 max value
      $sel:userOfflineDelay:AgentConfig :: NominalDiffTime
userOfflineDelay = NominalDiffTime
2, -- if network offline event happens in less than 2 seconds after it was set online, it is ignored
      $sel:messageTimeout:AgentConfig :: NominalDiffTime
messageTimeout = NominalDiffTime
2 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay,
      $sel:connDeleteDeliveryTimeout:AgentConfig :: NominalDiffTime
connDeleteDeliveryTimeout = NominalDiffTime
2 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay,
      $sel:helloTimeout:AgentConfig :: NominalDiffTime
helloTimeout = NominalDiffTime
2 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay,
      $sel:quotaExceededTimeout:AgentConfig :: NominalDiffTime
quotaExceededTimeout = NominalDiffTime
7 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay,
      $sel:persistErrorInterval:AgentConfig :: NominalDiffTime
persistErrorInterval = NominalDiffTime
3, -- seconds
      $sel:initialCleanupDelay:AgentConfig :: Int64
initialCleanupDelay = Int64
30 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000, -- 30 seconds
      $sel:cleanupInterval:AgentConfig :: Int64
cleanupInterval = Int64
5 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
60 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000, -- 5 minutes
      $sel:cleanupBatchSize:AgentConfig :: Int
cleanupBatchSize = Int
10000,
      $sel:initialLogStatsDelay:AgentConfig :: Int64
initialLogStatsDelay = Int64
10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000, -- 10 seconds
      $sel:logStatsInterval:AgentConfig :: Int64
logStatsInterval = Int64
10 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1000000, -- 10 seconds
      $sel:cleanupStepInterval:AgentConfig :: Int
cleanupStepInterval = Int
200000, -- 200ms
      $sel:maxWorkerRestartsPerMin:AgentConfig :: Int
maxWorkerRestartsPerMin = Int
5,
      $sel:storedMsgDataTTL:AgentConfig :: NominalDiffTime
storedMsgDataTTL = NominalDiffTime
21 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay,
      $sel:rcvFilesTTL:AgentConfig :: NominalDiffTime
rcvFilesTTL = NominalDiffTime
2 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay,
      $sel:sndFilesTTL:AgentConfig :: NominalDiffTime
sndFilesTTL = NominalDiffTime
nominalDay,
      $sel:xftpConsecutiveRetries:AgentConfig :: Int
xftpConsecutiveRetries = Int
3,
      $sel:xftpMaxRecipientsPerRequest:AgentConfig :: Int
xftpMaxRecipientsPerRequest = Int
200,
      $sel:deleteErrorCount:AgentConfig :: Int
deleteErrorCount = Int
10,
      $sel:ntfCron:AgentConfig :: Word16
ntfCron = Word16
20, -- minutes
      $sel:ntfBatchSize:AgentConfig :: Int
ntfBatchSize = Int
150,
      $sel:ntfSubFirstCheckInterval:AgentConfig :: NominalDiffTime
ntfSubFirstCheckInterval = NominalDiffTime
nominalDay,
      $sel:ntfSubCheckInterval:AgentConfig :: NominalDiffTime
ntfSubCheckInterval = NominalDiffTime
3 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
nominalDay,
      $sel:subsBatchSize:AgentConfig :: Int
subsBatchSize = Int
1350,
      -- CA certificate private key is not needed for initialization
      -- ! we do not generate these
      $sel:caCertificateFile:AgentConfig :: HostName
caCertificateFile = HostName
"/etc/simplex-agent/ca.crt",
      $sel:privateKeyFile:AgentConfig :: HostName
privateKeyFile = HostName
"/etc/simplex-agent/agent.key",
      $sel:certificateFile:AgentConfig :: HostName
certificateFile = HostName
"/etc/simplex-agent/agent.crt",
      $sel:rcvExpireCount:AgentConfig :: Int
rcvExpireCount = Int
8,
      $sel:rcvExpireInterval:AgentConfig :: NominalDiffTime
rcvExpireInterval = NominalDiffTime
nominalDay,
      $sel:e2eEncryptVRange:AgentConfig :: VersionRangeE2E
e2eEncryptVRange = VersionRangeE2E
supportedE2EEncryptVRange,
      $sel:smpAgentVRange:AgentConfig :: VersionRangeSMPA
smpAgentVRange = VersionRangeSMPA
supportedSMPAgentVRange,
      $sel:smpClientVRange:AgentConfig :: VersionRangeSMPC
smpClientVRange = VersionRangeSMPC
supportedSMPClientVRange
    }

data Env = Env
  { Env -> AgentConfig
config :: AgentConfig,
    Env -> DBStore
store :: DBStore,
    Env -> TVar ChaChaDRG
random :: TVar ChaChaDRG,
    Env -> TVar StdGen
randomServer :: TVar StdGen,
    Env -> NtfSupervisor
ntfSupervisor :: NtfSupervisor,
    Env -> XFTPAgent
xftpAgent :: XFTPAgent,
    Env -> TMVar Int
multicastSubscribers :: TMVar Int
  }

newSMPAgentEnv :: AgentConfig -> DBStore -> IO Env
newSMPAgentEnv :: AgentConfig -> DBStore -> IO Env
newSMPAgentEnv AgentConfig
config DBStore
store = do
  TVar ChaChaDRG
random <- IO (TVar ChaChaDRG)
C.newRandom
  TVar StdGen
randomServer <- StdGen -> IO (TVar StdGen)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (StdGen -> IO (TVar StdGen)) -> IO StdGen -> IO (TVar StdGen)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO StdGen -> IO StdGen
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
  NtfSupervisor
ntfSupervisor <- Natural -> IO NtfSupervisor
newNtfSubSupervisor (Natural -> IO NtfSupervisor) -> Natural -> IO NtfSupervisor
forall a b. (a -> b) -> a -> b
$ AgentConfig -> Natural
tbqSize AgentConfig
config
  XFTPAgent
xftpAgent <- IO XFTPAgent
newXFTPAgent
  TMVar Int
multicastSubscribers <- Int -> IO (TMVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TMVar a)
newTMVarIO Int
0
  Env -> IO Env
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env {AgentConfig
$sel:config:Env :: AgentConfig
config :: AgentConfig
config, DBStore
$sel:store:Env :: DBStore
store :: DBStore
store, TVar ChaChaDRG
$sel:random:Env :: TVar ChaChaDRG
random :: TVar ChaChaDRG
random, TVar StdGen
$sel:randomServer:Env :: TVar StdGen
randomServer :: TVar StdGen
randomServer, NtfSupervisor
$sel:ntfSupervisor:Env :: NtfSupervisor
ntfSupervisor :: NtfSupervisor
ntfSupervisor, XFTPAgent
$sel:xftpAgent:Env :: XFTPAgent
xftpAgent :: XFTPAgent
xftpAgent, TMVar Int
$sel:multicastSubscribers:Env :: TMVar Int
multicastSubscribers :: TMVar Int
multicastSubscribers}

createAgentStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
createAgentStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
createAgentStore = DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore)
createStore

data NtfSupervisor = NtfSupervisor
  { NtfSupervisor -> TVar (Maybe NtfToken)
ntfTkn :: TVar (Maybe NtfToken),
    NtfSupervisor -> TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId),
    NtfSupervisor -> TMap NtfServer Worker
ntfWorkers :: TMap NtfServer Worker,
    NtfSupervisor -> TMap SMPServer Worker
ntfSMPWorkers :: TMap SMPServer Worker,
    NtfSupervisor -> TMap NtfServer Worker
ntfTknDelWorkers :: TMap NtfServer Worker
  }

data NtfSupervisorCommand = NSCCreate | NSCSmpDelete | NSCDeleteSub
  deriving (Int -> NtfSupervisorCommand -> ShowS
[NtfSupervisorCommand] -> ShowS
NtfSupervisorCommand -> HostName
(Int -> NtfSupervisorCommand -> ShowS)
-> (NtfSupervisorCommand -> HostName)
-> ([NtfSupervisorCommand] -> ShowS)
-> Show NtfSupervisorCommand
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfSupervisorCommand -> ShowS
showsPrec :: Int -> NtfSupervisorCommand -> ShowS
$cshow :: NtfSupervisorCommand -> HostName
show :: NtfSupervisorCommand -> HostName
$cshowList :: [NtfSupervisorCommand] -> ShowS
showList :: [NtfSupervisorCommand] -> ShowS
Show)

newNtfSubSupervisor :: Natural -> IO NtfSupervisor
newNtfSubSupervisor :: Natural -> IO NtfSupervisor
newNtfSubSupervisor Natural
qSize = do
  TVar (Maybe NtfToken)
ntfTkn <- Maybe NtfToken -> IO (TVar (Maybe NtfToken))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe NtfToken
forall a. Maybe a
Nothing
  TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ <- Natural -> IO (TBQueue (NtfSupervisorCommand, NonEmpty ConnId))
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO Natural
qSize
  TMap NtfServer Worker
ntfWorkers <- IO (TMap NtfServer Worker)
forall k a. IO (TMap k a)
TM.emptyIO
  TMap SMPServer Worker
ntfSMPWorkers <- IO (TMap SMPServer Worker)
forall k a. IO (TMap k a)
TM.emptyIO
  TMap NtfServer Worker
ntfTknDelWorkers <- IO (TMap NtfServer Worker)
forall k a. IO (TMap k a)
TM.emptyIO
  NtfSupervisor -> IO NtfSupervisor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSupervisor {TVar (Maybe NtfToken)
$sel:ntfTkn:NtfSupervisor :: TVar (Maybe NtfToken)
ntfTkn :: TVar (Maybe NtfToken)
ntfTkn, TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
$sel:ntfSubQ:NtfSupervisor :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ :: TBQueue (NtfSupervisorCommand, NonEmpty ConnId)
ntfSubQ, TMap NtfServer Worker
$sel:ntfWorkers:NtfSupervisor :: TMap NtfServer Worker
ntfWorkers :: TMap NtfServer Worker
ntfWorkers, TMap SMPServer Worker
$sel:ntfSMPWorkers:NtfSupervisor :: TMap SMPServer Worker
ntfSMPWorkers :: TMap SMPServer Worker
ntfSMPWorkers, TMap NtfServer Worker
$sel:ntfTknDelWorkers:NtfSupervisor :: TMap NtfServer Worker
ntfTknDelWorkers :: TMap NtfServer Worker
ntfTknDelWorkers}

data XFTPAgent = XFTPAgent
  { -- if set, XFTP file paths will be considered as relative to this directory
    XFTPAgent -> TVar (Maybe HostName)
xftpWorkDir :: TVar (Maybe FilePath),
    XFTPAgent -> TMap (Maybe XFTPServer) Worker
xftpRcvWorkers :: TMap (Maybe XFTPServer) Worker,
    XFTPAgent -> TMap (Maybe XFTPServer) Worker
xftpSndWorkers :: TMap (Maybe XFTPServer) Worker,
    XFTPAgent -> TMap XFTPServer Worker
xftpDelWorkers :: TMap XFTPServer Worker
  }

newXFTPAgent :: IO XFTPAgent
newXFTPAgent :: IO XFTPAgent
newXFTPAgent = do
  TVar (Maybe HostName)
xftpWorkDir <- Maybe HostName -> IO (TVar (Maybe HostName))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe HostName
forall a. Maybe a
Nothing
  TMap (Maybe XFTPServer) Worker
xftpRcvWorkers <- IO (TMap (Maybe XFTPServer) Worker)
forall k a. IO (TMap k a)
TM.emptyIO
  TMap (Maybe XFTPServer) Worker
xftpSndWorkers <- IO (TMap (Maybe XFTPServer) Worker)
forall k a. IO (TMap k a)
TM.emptyIO
  TMap XFTPServer Worker
xftpDelWorkers <- IO (TMap XFTPServer Worker)
forall k a. IO (TMap k a)
TM.emptyIO
  XFTPAgent -> IO XFTPAgent
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPAgent {TVar (Maybe HostName)
$sel:xftpWorkDir:XFTPAgent :: TVar (Maybe HostName)
xftpWorkDir :: TVar (Maybe HostName)
xftpWorkDir, TMap (Maybe XFTPServer) Worker
$sel:xftpRcvWorkers:XFTPAgent :: TMap (Maybe XFTPServer) Worker
xftpRcvWorkers :: TMap (Maybe XFTPServer) Worker
xftpRcvWorkers, TMap (Maybe XFTPServer) Worker
$sel:xftpSndWorkers:XFTPAgent :: TMap (Maybe XFTPServer) Worker
xftpSndWorkers :: TMap (Maybe XFTPServer) Worker
xftpSndWorkers, TMap XFTPServer Worker
$sel:xftpDelWorkers:XFTPAgent :: TMap XFTPServer Worker
xftpDelWorkers :: TMap XFTPServer Worker
xftpDelWorkers}

data Worker = Worker
  { Worker -> Int
workerId :: Int,
    Worker -> TMVar ()
doWork :: TMVar (),
    Worker -> TMVar (Maybe (Weak ThreadId))
action :: TMVar (Maybe (Weak ThreadId)),
    Worker -> TVar RestartCount
restarts :: TVar RestartCount
  }

data RestartCount = RestartCount
  { RestartCount -> Int64
restartMinute :: Int64,
    RestartCount -> Int
restartCount :: Int
  }

updateRestartCount :: SystemTime -> RestartCount -> RestartCount
updateRestartCount :: SystemTime -> RestartCount -> RestartCount
updateRestartCount SystemTime
t (RestartCount Int64
minute Int
count) = do
  let min' :: Int64
min' = SystemTime -> Int64
systemSeconds SystemTime
t Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
60
   in Int64 -> Int -> RestartCount
RestartCount Int64
min' (Int -> RestartCount) -> Int -> RestartCount
forall a b. (a -> b) -> a -> b
$ if Int64
minute Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
min' then Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 else Int
1

$(pure [])

$(JQ.deriveJSON defaultJSON ''ServerRoles)

instance ProtocolTypeI p => ToJSON (ServerCfg p) where
  toEncoding :: ServerCfg p -> Encoding
toEncoding = $(JQ.mkToEncoding defaultJSON ''ServerCfg)
  toJSON :: ServerCfg p -> Value
toJSON = $(JQ.mkToJSON defaultJSON ''ServerCfg)

instance ProtocolTypeI p => FromJSON (ServerCfg p) where
  parseJSON :: Value -> Parser (ServerCfg p)
parseJSON = $(JQ.mkParseJSON defaultJSON ''ServerCfg)