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

junction: locked logging

master
Denis Tereshkin 4 years ago
parent
9d016b0d44
commit
748c1ded89
2 changed files with 41 additions and 27 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. 1
      robocom-zero.cabal
  2. 67
      src/ATrade/Driver/Junction.hs

1
robocom-zero.cabal
Unescape View File

@ -73,6 +73,7 @@ library
, extra , extra
, co-log , co-log
, text-show , text-show
, unliftio
default-language: Haskell2010 default-language: Haskell2010
other-modules: ATrade.Exceptions other-modules: ATrade.Exceptions

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

@ -5,6 +5,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module ATrade.Driver.Junction module ATrade.Driver.Junction
( (
@ -52,18 +53,19 @@ import ATrade.RoboCom.ConfigStorage (ConfigStorage (loa
import ATrade.RoboCom.Monad (StrategyEnvironment (..)) import ATrade.RoboCom.Monad (StrategyEnvironment (..))
import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState))
import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId),
Bars, TickerInfoMap) Bars,
TickerInfoMap)
import ATrade.Types (ClientSecurityParams (ClientSecurityParams), import ATrade.Types (ClientSecurityParams (ClientSecurityParams),
OrderId, OrderId,
Trade (tradeOrderId)) Trade (tradeOrderId))
import Colog (HasLog (getLogAction, setLogAction), import Colog (HasLog (getLogAction, setLogAction),
LogAction, LogAction (LogAction),
hoistLogAction,
logTextStdout, logTextStdout,
(>$<)) (<&), (>$<))
import Colog.Actions (logTextHandle) import Colog.Actions (logTextHandle)
import Control.Concurrent (threadDelay, QSem, waitQSem, signalQSem) import Control.Concurrent.QSem (newQSem)
import Control.Exception.Safe (MonadThrow, import Control.Exception.Safe (MonadThrow)
bracket)
import Control.Monad (forM_, forever) import Control.Monad (forM_, forever)
import Control.Monad.Extra (whenM) import Control.Monad.Extra (whenM)
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
@ -113,6 +115,10 @@ import System.IO (BufferMode (LineBu
withFile) withFile)
import System.ZMQ4 (withContext) import System.ZMQ4 (withContext)
import System.ZMQ4.ZAP (loadCertificateFromFile) import System.ZMQ4.ZAP (loadCertificateFromFile)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (bracket)
import UnliftIO.QSem (QSem, withQSem)
data JunctionEnv = data JunctionEnv =
JunctionEnv JunctionEnv
@ -174,6 +180,9 @@ instance QuoteStream JunctionM where
return (SubscriptionId 0) -- TODO subscription Ids return (SubscriptionId 0) -- TODO subscription Ids
removeSubscription _ = undefined removeSubscription _ = undefined
locked :: (MonadIO m, MonadUnliftIO m) => QSem -> LogAction m a -> LogAction m a
locked sem action = LogAction (\m -> withQSem sem (action <& m))
logger :: (MonadIO m) => Handle -> LogAction m Message logger :: (MonadIO m) => Handle -> LogAction m Message
logger h = fmtMessage >$< (logTextStdout <> logTextHandle h) logger h = fmtMessage >$< (logTextStdout <> logTextHandle h)
@ -189,7 +198,11 @@ junctionMain descriptors = do
withFile (logBasePath cfg <> "/all.log") AppendMode $ \h -> do withFile (logBasePath cfg <> "/all.log") AppendMode $ \h -> do
let log = logWith (logger h) hSetBuffering h LineBuffering
locksem <- newQSem 1
let globalLogger = locked locksem (logger h)
let log = logWith globalLogger
barsMap <- newIORef M.empty barsMap <- newIORef M.empty
tickerInfoMap <- newIORef M.empty tickerInfoMap <- newIORef M.empty
@ -199,15 +212,14 @@ junctionMain descriptors = do
log Info "Junction" "redis: connected" log Info "Junction" "redis: connected"
withContext $ \ctx -> do withContext $ \ctx -> do
log Debug "Junction" "0mq context created" log Debug "Junction" "0mq context created"
let downloaderLogAction = logger h let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) (hoistLogAction liftIO globalLogger)
let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) downloaderLogAction
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 (logger h) $ \bro -> withBroker cfg ctx robotsMap ordersMap handledNotifications globalLogger $ \bro ->
withQThread downloaderEnv barsMap tickerInfoMap cfg ctx (logger h) $ \qt -> do withQThread downloaderEnv barsMap tickerInfoMap cfg ctx globalLogger $ \qt -> do
broService <- mkBrokerService bro ordersMap broService <- mkBrokerService bro ordersMap
let junctionLogAction = logger h let junctionLogAction = hoistLogAction liftIO globalLogger
let env = let env =
JunctionEnv JunctionEnv
{ {
@ -219,10 +231,10 @@ junctionMain descriptors = do
peLogAction = junctionLogAction peLogAction = junctionLogAction
} }
withJunction env $ do withJunction env $ do
startRobots h cfg barsMap tickerInfoMap broService startRobots (hoistLogAction liftIO globalLogger) cfg barsMap tickerInfoMap broService
forever $ do forever $ do
notifications <- liftIO $ getNotifications broService notifications <- liftIO $ getNotifications broService
forM_ notifications (liftIO . handleBrokerNotification robotsMap ordersMap handledNotifications (logger h)) forM_ notifications (liftIO . handleBrokerNotification robotsMap ordersMap handledNotifications globalLogger)
saveRobots saveRobots
liftIO $ threadDelay 1000000 liftIO $ threadDelay 1000000
where where
@ -238,10 +250,11 @@ junctionMain descriptors = do
currentTimers <- liftIO $ readIORef (strategyTimers inst) currentTimers <- liftIO $ readIORef (strategyTimers inst)
saveState currentTimers (strategyInstanceId inst <> ":timers") saveState currentTimers (strategyInstanceId inst <> ":timers")
startRobots :: Handle -> ProgramConfiguration -> IORef Bars -> IORef TickerInfoMap -> BrokerService -> JunctionM () startRobots :: LogAction IO Message -> ProgramConfiguration -> IORef Bars -> IORef TickerInfoMap -> BrokerService -> JunctionM ()
startRobots logHandle cfg barsMap tickerInfoMap broService = forM_ (instances cfg) $ \inst -> do startRobots gLogger cfg barsMap tickerInfoMap broService = forM_ (instances cfg) $ \inst -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
logWith (logger logHandle) Info "Junction" $ "Starting strategy: " <> (strategyBaseName inst) let lLogger = hoistLogAction liftIO gLogger
logWith lLogger Info "Junction" $ "Starting strategy: " <> (strategyBaseName inst)
case M.lookup (strategyBaseName inst) descriptors of case M.lookup (strategyBaseName inst) descriptors of
Just (StrategyDescriptorE desc) -> do Just (StrategyDescriptorE desc) -> do
bigConf <- loadConfig (configKey inst) bigConf <- loadConfig (configKey inst)
@ -252,7 +265,7 @@ junctionMain descriptors = do
rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef
localH <- liftIO $ openFile (logBasePath cfg <> "/" <> T.unpack (strategyId inst) <> ".log") AppendMode localH <- liftIO $ openFile (logBasePath cfg <> "/" <> T.unpack (strategyId inst) <> ".log") AppendMode
liftIO $ hSetBuffering localH LineBuffering liftIO $ hSetBuffering localH LineBuffering
let robotLogAction = logger logHandle <> (fmtMessage >$< logTextHandle localH) let robotLogAction = (hoistLogAction liftIO gLogger) <> (fmtMessage >$< logTextHandle localH)
stratEnv <- liftIO $ newIORef StrategyEnvironment stratEnv <- liftIO $ newIORef StrategyEnvironment
{ {
_seInstanceId = strategyId inst, _seInstanceId = strategyId inst,
@ -265,8 +278,8 @@ junctionMain descriptors = do
robot <- createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState rTimers robot <- createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState rTimers
robotsMap' <- asks peRobots robotsMap' <- asks peRobots
liftIO $ atomicModifyIORef' robotsMap' (\s -> (M.insert (strategyId inst) robot s, ())) liftIO $ atomicModifyIORef' robotsMap' (\s -> (M.insert (strategyId inst) robot s, ()))
_ -> logWith (logger logHandle) Error (strategyId inst) $ "No tickers configured !!!" _ -> logWith lLogger Error (strategyId inst) $ "No tickers configured !!!"
Nothing -> logWith (logger logHandle) Error "Junction" $ "Unknown strategy: " <> (strategyBaseName inst) Nothing -> logWith lLogger Error "Junction" $ "Unknown strategy: " <> strategyBaseName inst
toBarSeriesId t = BarSeriesId (tickerId t) (timeframe t) toBarSeriesId t = BarSeriesId (tickerId t) (timeframe t)
@ -279,8 +292,8 @@ junctionMain descriptors = do
LogAction IO Message -> LogAction IO Message ->
Notification -> Notification ->
IO () IO ()
handleBrokerNotification robotsRef ordersMapRef handled logger notification= do handleBrokerNotification robotsRef ordersMapRef handled logger' notification= do
logWith logger Trace "Junction" $ "Incoming notification: " <> (T.pack . show . unNotificationSqnum . getNotificationSqnum) notification logWith logger' Trace "Junction" $ "Incoming notification: " <> (T.pack . show . unNotificationSqnum . getNotificationSqnum) notification
whenM (notMember (getNotificationSqnum notification) <$> readIORef handled) $ do whenM (notMember (getNotificationSqnum notification) <$> readIORef handled) $ do
robotsMap <- readIORef robotsRef robotsMap <- readIORef robotsRef
ordersMap <- readIORef ordersMapRef ordersMap <- readIORef ordersMapRef
@ -288,8 +301,8 @@ junctionMain descriptors = do
case getNotificationTarget robotsMap ordersMap notification of case getNotificationTarget robotsMap ordersMap notification of
Just robot -> postNotificationEvent robot notification Just robot -> postNotificationEvent robot notification
Nothing -> do Nothing -> do
logWith logger Warning "Junction" $ "Unknown order: " <> (T.pack . show) (notificationOrderId notification) logWith logger' Warning "Junction" $ "Unknown order: " <> (T.pack . show) (notificationOrderId notification)
logWith logger Debug "Junction" $ "Ordermap: " <> (T.pack . show) (M.toList ordersMap) logWith logger' Debug "Junction" $ "Ordermap: " <> (T.pack . show) (M.toList ordersMap)
atomicModifyIORef' handled (\s -> (S.insert (getNotificationSqnum notification) s, ())) atomicModifyIORef' handled (\s -> (S.insert (getNotificationSqnum notification) s, ()))
@ -301,7 +314,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 ctx robotsMap ordersMap handled logger' f = do
securityParameters <- loadBrokerSecurityParameters cfg securityParameters <- loadBrokerSecurityParameters cfg
bracket bracket
(startBrokerClient (startBrokerClient
@ -309,9 +322,9 @@ junctionMain descriptors = do
ctx ctx
(brokerEndpoint cfg) (brokerEndpoint cfg)
(brokerNotificationEndpoint cfg) (brokerNotificationEndpoint cfg)
[handleBrokerNotification robotsMap ordersMap handled logger] [handleBrokerNotification robotsMap ordersMap handled logger']
securityParameters securityParameters
logger) logger')
stopBrokerClient f stopBrokerClient f
loadBrokerSecurityParameters cfg = loadBrokerSecurityParameters cfg =

Write Preview
Loading…
Cancel
Save