asakul
/
robocom-zero
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Junction: per-component configurable log levels

master
Denis Tereshkin 11 months ago
parent
4d6cc07ee3
commit
5d7434c631
2 changed files with 56 additions and 44 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 51
      src/ATrade/Driver/Junction.hs
  2. 35
      src/ATrade/Driver/Junction/ProgramConfiguration.hs

51
src/ATrade/Driver/Junction.hs
Unescape View File

@ -1,8 +1,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
@ -17,8 +15,7 @@ import ATrade.Broker.Client (startBrokerClient,
import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification), import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification),
NotificationSqnum (unNotificationSqnum), NotificationSqnum (unNotificationSqnum),
getNotificationSqnum) getNotificationSqnum)
import ATrade.Driver.Junction.BrokerService (BrokerService, import ATrade.Driver.Junction.BrokerService (getNotifications,
getNotifications,
mkBrokerService) mkBrokerService)
import ATrade.Driver.Junction.JunctionMonad (JunctionEnv (..), import ATrade.Driver.Junction.JunctionMonad (JunctionEnv (..),
JunctionM (..), JunctionM (..),
@ -30,23 +27,14 @@ import ATrade.Driver.Junction.QuoteThread (DownloaderEnv (Dow
withQThread) withQThread)
import ATrade.Driver.Junction.RemoteControl (handleRemoteControl) import ATrade.Driver.Junction.RemoteControl (handleRemoteControl)
import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, postNotificationEvent) import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, postNotificationEvent)
import ATrade.Driver.Junction.Types (StrategyDescriptorE, import ATrade.Driver.Junction.Types (StrategyDescriptorE)
confStrategy, import ATrade.Logging (Message (..), Severity (Debug, Info, Trace, Warning),
confTickers,
strategyState,
strategyTimers,
tickerId,
timeframe)
import ATrade.Logging (Message, Severity (Debug, Info, Trace, Warning),
fmtMessage, fmtMessage,
logWith) logWith)
import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.Quotes.QHP (mkQHPHandle)
import ATrade.RoboCom.Types (Bars, import ATrade.Types (OrderId, Trade (tradeOrderId))
TickerInfoMap)
import ATrade.Types (ClientSecurityParams (ClientSecurityParams),
OrderId,
Trade (tradeOrderId))
import Colog (LogAction (LogAction), import Colog (LogAction (LogAction),
cfilter,
hoistLogAction, hoistLogAction,
logTextStdout, logTextStdout,
(<&), (>$<)) (<&), (>$<))
@ -64,7 +52,6 @@ import qualified Data.Map.Strict as M
import Data.Set (notMember) import Data.Set (notMember)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Text.IO (readFile) import Data.Text.IO (readFile)
import Database.Redis (ConnectInfo (..), PortID (UnixSocket), import Database.Redis (ConnectInfo (..), PortID (UnixSocket),
checkedConnect, checkedConnect,
@ -88,7 +75,6 @@ import System.IO (BufferMode (LineBu
import System.ZMQ4 (Router (Router), import System.ZMQ4 (Router (Router),
bind, withContext, bind, withContext,
withSocket) withSocket)
import System.ZMQ4.ZAP (loadCertificateFromFile)
import UnliftIO (MonadUnliftIO) import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (bracket) import UnliftIO.Exception (bracket)
import UnliftIO.QSem (QSem, withQSem) import UnliftIO.QSem (QSem, withQSem)
@ -97,8 +83,13 @@ import UnliftIO.QSem (QSem, withQSem)
locked :: (MonadIO m, MonadUnliftIO m) => QSem -> LogAction m a -> LogAction m a locked :: (MonadIO m, MonadUnliftIO m) => QSem -> LogAction m a -> LogAction m a
locked sem action = LogAction (\m -> withQSem sem (action <& m)) locked sem action = LogAction (\m -> withQSem sem (action <& m))
logger :: (MonadIO m) => Handle -> LogAction m Message logger :: (MonadIO m) => M.Map T.Text Severity -> Handle -> LogAction m Message
logger h = fmtMessage >$< (logTextStdout <> logTextHandle h) logger loglevels h = cfilter checkLoglevel (fmtMessage >$< (logTextStdout <> logTextHandle h))
where
checkLoglevel msg =
case M.lookup (msgComponent msg) loglevels of
Just level -> msgSeverity msg >= level
Nothing -> True
junctionMain :: M.Map T.Text StrategyDescriptorE -> IO () junctionMain :: M.Map T.Text StrategyDescriptorE -> IO ()
junctionMain descriptors = do junctionMain descriptors = do
@ -115,7 +106,7 @@ junctionMain descriptors = do
hSetBuffering h LineBuffering hSetBuffering h LineBuffering
locksem <- newQSem 1 locksem <- newQSem 1
let globalLogger = locked locksem (logger h) let globalLogger = locked locksem (logger (M.fromList $ logLevels cfg) h)
let log = logWith globalLogger let log = logWith globalLogger
barsMap <- newIORef M.empty barsMap <- newIORef M.empty
@ -130,7 +121,7 @@ junctionMain descriptors = do
robotsMap <- newIORef M.empty robotsMap <- newIORef M.empty
ordersMap <- newIORef M.empty ordersMap <- newIORef M.empty
handledNotifications <- newIORef S.empty handledNotifications <- newIORef S.empty
withBroker cfg ctx robotsMap ordersMap handledNotifications globalLogger $ \bro -> withBroker cfg robotsMap ordersMap handledNotifications globalLogger $ \bro ->
withQThread downloaderEnv barsMap tickerInfoMap cfg ctx globalLogger $ \qt -> withQThread downloaderEnv barsMap tickerInfoMap cfg ctx globalLogger $ \qt ->
withSocket ctx Router $ \rcSocket -> do withSocket ctx Router $ \rcSocket -> do
liftIO $ bind rcSocket (T.unpack . remoteControlEndpoint $ cfg) liftIO $ bind rcSocket (T.unpack . remoteControlEndpoint $ cfg)
@ -195,8 +186,7 @@ junctionMain descriptors = do
notificationOrderId (OrderNotification _ oid _) = oid notificationOrderId (OrderNotification _ oid _) = oid
notificationOrderId (TradeNotification _ trade) = tradeOrderId trade notificationOrderId (TradeNotification _ trade) = tradeOrderId trade
withBroker cfg ctx robotsMap ordersMap handled logger' f = do withBroker cfg robotsMap ordersMap handled logger' f = do
securityParameters <- loadBrokerSecurityParameters cfg
bracket bracket
(startBrokerClient (startBrokerClient
(brokerIdentity cfg) (brokerIdentity cfg)
@ -205,17 +195,6 @@ junctionMain descriptors = do
logger') logger')
stopBrokerClient f stopBrokerClient f
loadBrokerSecurityParameters cfg =
case (brokerClientCert cfg, brokerServerCert cfg) of
(Just clientCertPath, Just serverCertPath) -> do
eClientCert <- loadCertificateFromFile clientCertPath
eServerCert <- loadCertificateFromFile serverCertPath
case (eClientCert, eServerCert) of
(Right clientCert, Right serverCert) -> return $ ClientSecurityParams (Just clientCert) (Just serverCert)
(_, _) -> return $ ClientSecurityParams Nothing Nothing
_ -> return $ ClientSecurityParams Nothing Nothing
parseOptions = execParser options parseOptions = execParser options
options = info (optionsParser <**> helper) options = info (optionsParser <**> helper)
(fullDesc <> (fullDesc <>

35
src/ATrade/Driver/Junction/ProgramConfiguration.hs
Unescape View File

@ -1,4 +1,7 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module ATrade.Driver.Junction.ProgramConfiguration module ATrade.Driver.Junction.ProgramConfiguration
( (
@ -6,8 +9,12 @@ module ATrade.Driver.Junction.ProgramConfiguration
ProgramConfiguration(..) ProgramConfiguration(..)
) where ) where
import ATrade.Driver.Junction.Types (StrategyInstanceDescriptor) import ATrade.Driver.Junction.Types (StrategyInstanceDescriptor)
import ATrade.Logging (Severity (..))
import qualified Data.Text as T import qualified Data.Text as T
import Dhall (FromDhall) import Dhall (FromDhall, autoWith)
import Dhall.Core (Expr (..), FieldSelection (..))
import qualified Dhall.Map
import Dhall.Marshal.Decode (Decoder (..), typeError)
import GHC.Generics (Generic) import GHC.Generics (Generic)
newtype ProgramOptions = newtype ProgramOptions =
@ -33,7 +40,33 @@ data ProgramConfiguration =
redisSocket :: T.Text, redisSocket :: T.Text,
robotsConfigsPath :: FilePath, robotsConfigsPath :: FilePath,
logBasePath :: FilePath, logBasePath :: FilePath,
logLevels :: [(T.Text, Severity)],
instances :: [StrategyInstanceDescriptor] instances :: [StrategyInstanceDescriptor]
} deriving (Generic, Show) } deriving (Generic, Show)
instance FromDhall Severity where
autoWith _ = Decoder {..}
where
extract expr@(Field _ FieldSelection{ fieldSelectionLabel }) =
case fieldSelectionLabel of
"Trace" -> pure Trace
"Debug" -> pure Debug
"Info" -> pure Info
"Warning" -> pure Warning
"Error" -> pure Error
_ -> typeError expected expr
extract expr = typeError expected expr
expected = pure
(Union
(Dhall.Map.fromList
[ ("Trace", Nothing)
, ("Debug", Nothing)
, ("Info", Nothing)
, ("Warning", Nothing)
, ("Error", Nothing)
]
)
)
instance FromDhall ProgramConfiguration instance FromDhall ProgramConfiguration

Write Preview
Loading…
Cancel
Save