158 lines
5.1 KiB
Haskell
158 lines
5.1 KiB
Haskell
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE NumericUnderscores #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
|
|
|
|
module Simplex.Messaging.Agent.Env.SQLite
|
|
( AgentMonad,
|
|
AgentConfig (..),
|
|
InitialAgentServers (..),
|
|
defaultAgentConfig,
|
|
defaultReconnectInterval,
|
|
Env (..),
|
|
newSMPAgentEnv,
|
|
NtfSupervisor (..),
|
|
NtfSupervisorCommand (..),
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Unlift
|
|
import Control.Monad.Reader
|
|
import Crypto.Random
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import Data.Time.Clock (NominalDiffTime, nominalDay)
|
|
import Data.Word (Word16)
|
|
import Network.Socket
|
|
import Network.Socks5 (SocksConf)
|
|
import Numeric.Natural
|
|
import Simplex.Messaging.Agent.Protocol
|
|
import Simplex.Messaging.Agent.RetryInterval
|
|
import Simplex.Messaging.Agent.Store.SQLite
|
|
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
|
|
import Simplex.Messaging.Client
|
|
import Simplex.Messaging.Client.Agent ()
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Notifications.Types
|
|
import Simplex.Messaging.Protocol (NtfServer)
|
|
import Simplex.Messaging.TMap (TMap)
|
|
import qualified Simplex.Messaging.TMap as TM
|
|
import Simplex.Messaging.Transport (TLS, Transport (..))
|
|
import Simplex.Messaging.Transport.Client (defaultSMPPort)
|
|
import Simplex.Messaging.Version
|
|
import System.Random (StdGen, newStdGen)
|
|
import UnliftIO (Async)
|
|
import UnliftIO.STM
|
|
|
|
-- | Agent monad with MonadReader Env and MonadError AgentErrorType
|
|
type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
|
|
|
|
data InitialAgentServers = InitialAgentServers
|
|
{ smp :: NonEmpty SMPServer,
|
|
ntf :: [NtfServer],
|
|
socksProxy :: Maybe SocksConf,
|
|
tcpTimeout :: Int
|
|
}
|
|
|
|
data AgentConfig = AgentConfig
|
|
{ tcpPort :: ServiceName,
|
|
cmdSignAlg :: C.SignAlg,
|
|
connIdBytes :: Int,
|
|
tbqSize :: Natural,
|
|
dbFile :: FilePath,
|
|
yesToMigrations :: Bool,
|
|
smpCfg :: ProtocolClientConfig,
|
|
ntfCfg :: ProtocolClientConfig,
|
|
reconnectInterval :: RetryInterval,
|
|
helloTimeout :: NominalDiffTime,
|
|
ntfCron :: Word16,
|
|
ntfWorkerDelay :: Int,
|
|
ntfSMPWorkerDelay :: Int,
|
|
ntfSubCheckInterval :: NominalDiffTime,
|
|
ntfMaxMessages :: Int,
|
|
caCertificateFile :: FilePath,
|
|
privateKeyFile :: FilePath,
|
|
certificateFile :: FilePath,
|
|
smpAgentVersion :: Version,
|
|
smpAgentVRange :: VersionRange
|
|
}
|
|
|
|
defaultReconnectInterval :: RetryInterval
|
|
defaultReconnectInterval =
|
|
RetryInterval
|
|
{ initialInterval = second,
|
|
increaseAfter = 10 * second,
|
|
maxInterval = 10 * second
|
|
}
|
|
where
|
|
second = 1_000_000
|
|
|
|
defaultAgentConfig :: AgentConfig
|
|
defaultAgentConfig =
|
|
AgentConfig
|
|
{ tcpPort = "5224",
|
|
cmdSignAlg = C.SignAlg C.SEd448,
|
|
connIdBytes = 12,
|
|
tbqSize = 64,
|
|
dbFile = "smp-agent.db",
|
|
yesToMigrations = False,
|
|
smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)},
|
|
ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)},
|
|
reconnectInterval = defaultReconnectInterval,
|
|
helloTimeout = 2 * nominalDay,
|
|
ntfCron = 20, -- minutes
|
|
ntfWorkerDelay = 100000, -- microseconds
|
|
ntfSMPWorkerDelay = 500000, -- microseconds
|
|
ntfSubCheckInterval = nominalDay,
|
|
ntfMaxMessages = 4,
|
|
-- CA certificate private key is not needed for initialization
|
|
-- ! we do not generate these
|
|
caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
|
|
privateKeyFile = "/etc/opt/simplex-agent/agent.key",
|
|
certificateFile = "/etc/opt/simplex-agent/agent.crt",
|
|
smpAgentVersion = currentSMPAgentVersion,
|
|
smpAgentVRange = supportedSMPAgentVRange
|
|
}
|
|
|
|
data Env = Env
|
|
{ config :: AgentConfig,
|
|
store :: SQLiteStore,
|
|
idsDrg :: TVar ChaChaDRG,
|
|
clientCounter :: TVar Int,
|
|
randomServer :: TVar StdGen,
|
|
ntfSupervisor :: NtfSupervisor
|
|
}
|
|
|
|
newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
|
|
newSMPAgentEnv config@AgentConfig {dbFile, yesToMigrations} = do
|
|
idsDrg <- newTVarIO =<< drgNew
|
|
store <- liftIO $ createSQLiteStore dbFile Migrations.app yesToMigrations
|
|
clientCounter <- newTVarIO 0
|
|
randomServer <- newTVarIO =<< liftIO newStdGen
|
|
ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config
|
|
return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor}
|
|
|
|
data NtfSupervisor = NtfSupervisor
|
|
{ ntfTkn :: TVar (Maybe NtfToken),
|
|
ntfSubQ :: TBQueue (ConnId, NtfSupervisorCommand),
|
|
ntfWorkers :: TMap NtfServer (TMVar (), Async ()),
|
|
ntfSMPWorkers :: TMap SMPServer (TMVar (), Async ())
|
|
}
|
|
|
|
data NtfSupervisorCommand = NSCCreate | NSCDelete | NSCSmpDelete | NSCNtfWorker NtfServer | NSCNtfSMPWorker SMPServer
|
|
deriving (Show)
|
|
|
|
newNtfSubSupervisor :: Natural -> STM NtfSupervisor
|
|
newNtfSubSupervisor qSize = do
|
|
ntfTkn <- newTVar Nothing
|
|
ntfSubQ <- newTBQueue qSize
|
|
ntfWorkers <- TM.empty
|
|
ntfSMPWorkers <- TM.empty
|
|
pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers}
|