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

Logging: use co-log && logging facilities from libatrade-0.11

junction
Denis Tereshkin 4 years ago
parent
bf7df5e98c
commit
632ca49d15
8 changed files with 94 additions and 41 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 5
      robocom-zero.cabal
  2. 45
      src/ATrade/Driver/Junction.hs
  3. 22
      src/ATrade/Driver/Junction/QuoteThread.hs
  4. 15
      src/ATrade/Driver/Junction/RobotDriverThread.hs
  5. 5
      src/ATrade/Quotes/Finam.hs
  6. 26
      src/ATrade/Quotes/QHP.hs
  7. 15
      src/ATrade/Quotes/QTIS.hs
  8. 2
      stack.yaml

5
robocom-zero.cabal
Unescape View File

@ -24,7 +24,6 @@ library @@ -24,7 +24,6 @@ library
, ATrade.RoboCom.Types
, ATrade.RoboCom.Utils
, ATrade.Quotes
, ATrade.Quotes.Finam
, ATrade.Quotes.QHP
, ATrade.Quotes.QTIS
-- , ATrade.Driver.Real
@ -41,7 +40,7 @@ library @@ -41,7 +40,7 @@ library
, ATrade.Quotes.TickerInfoProvider
other-modules: Paths_robocom_zero
build-depends: base >= 4.7 && < 5
, libatrade >= 0.10.0.0 && < 0.11.0.0
, libatrade >= 0.11.0.0 && < 0.12.0.0
, text
, text-icu
, errors
@ -53,7 +52,6 @@ library @@ -53,7 +52,6 @@ library
, vector
, wreq
, safe
, hslogger
, parsec
, parsec-numbers
, aeson
@ -86,6 +84,7 @@ library @@ -86,6 +84,7 @@ library
, async
, dhall
, extra
, co-log
default-language: Haskell2010
other-modules: ATrade.Exceptions

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

@ -38,12 +38,21 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor @@ -38,12 +38,21 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor
confStrategy,
strategyState,
strategyTimers)
import ATrade.Logging (Message,
Severity (Info),
fmtMessage,
logWarning,
logWith)
import ATrade.Quotes.QHP (mkQHPHandle)
import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig))
import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState))
import ATrade.Types (ClientSecurityParams (ClientSecurityParams),
OrderId,
Trade (tradeOrderId))
import Colog (HasLog (getLogAction, setLogAction),
LogAction,
logTextStdout,
(>$<))
import Control.Concurrent (threadDelay)
import Control.Exception.Safe (MonadThrow,
bracket)
@ -84,8 +93,8 @@ import Options.Applicative (Parser, @@ -84,8 +93,8 @@ import Options.Applicative (Parser,
metavar, progDesc,
short, strOption,
(<**>))
import Prelude hiding (readFile)
import System.Log.Logger (warningM)
import Prelude hiding (log,
readFile)
import System.ZMQ4 (withContext)
import System.ZMQ4.ZAP (loadCertificateFromFile)
@ -96,12 +105,17 @@ data JunctionEnv = @@ -96,12 +105,17 @@ data JunctionEnv =
peConfigPath :: FilePath,
peQuoteThread :: QuoteThreadHandle,
peBroker :: BrokerClientHandle,
peRobots :: IORef (M.Map T.Text RobotDriverHandle)
peRobots :: IORef (M.Map T.Text RobotDriverHandle),
peLogAction :: LogAction JunctionM Message
}
newtype JunctionM a = JunctionM { unJunctionM :: ReaderT JunctionEnv IO a }
deriving (Functor, Applicative, Monad, MonadReader JunctionEnv, MonadIO, MonadThrow)
instance HasLog JunctionEnv Message JunctionM where
getLogAction = peLogAction
setLogAction a e = e { peLogAction = a }
instance ConfigStorage JunctionM where
loadConfig key = do
basePath <- asks peConfigPath
@ -115,7 +129,7 @@ instance MonadPersistence JunctionM where @@ -115,7 +129,7 @@ instance MonadPersistence JunctionM where
res <- liftIO $ runRedis conn $ mset [(encodeUtf8 key, BL.toStrict $ encode newState),
(encodeUtf8 (key <> ":last_store") , encodeUtf8 . T.pack . show $ now)]
case res of
Left _ -> liftIO $ warningM "main" "Unable to save state"
Left _ -> logWarning "Junction " "Unable to save state"
Right _ -> return ()
loadState key = do
@ -124,17 +138,17 @@ instance MonadPersistence JunctionM where @@ -124,17 +138,17 @@ instance MonadPersistence JunctionM where
-- TODO: just chain eithers
case res of
Left _ -> do
liftIO $ warningM "main" "Unable to load state"
logWarning "Junction" "Unable to load state"
return def
Right maybeRawState ->
case maybeRawState of
Just rawState -> case eitherDecode $ BL.fromStrict rawState of
Left _ -> do
liftIO $ warningM "main" "Unable to decode state"
logWarning "Junction" "Unable to decode state"
return def
Right decodedState -> return decodedState
Nothing -> do
liftIO $ warningM "main" "Unable to decode state"
logWarning "Junction" "Unable to decode state"
return def
instance QuoteStream JunctionM where
@ -148,18 +162,25 @@ junctionMain :: M.Map T.Text StrategyDescriptorE -> IO () @@ -148,18 +162,25 @@ junctionMain :: M.Map T.Text StrategyDescriptorE -> IO ()
junctionMain descriptors = do
opts <- parseOptions
let bootstrapLogAction = fmtMessage >$< logTextStdout
let log = logWith bootstrapLogAction
log Info "Junction" $ "Reading config from: " <> (T.pack . show) (configPath opts)
cfg <- readFile (configPath opts) >>= input auto
barsMap <- newIORef M.empty
redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) })
withContext $ \ctx -> do
let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg)
let downloaderLogAction = fmtMessage >$< logTextStdout
let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) downloaderLogAction
robotsMap <- newIORef M.empty
ordersMap <- newIORef M.empty
handledNotifications <- newIORef S.empty
withBroker cfg ctx robotsMap ordersMap handledNotifications $ \bro ->
withQThread downloaderEnv barsMap cfg ctx $ \qt -> do
let junctionLogAction = fmtMessage >$< logTextStdout
let env =
JunctionEnv
{
@ -167,7 +188,8 @@ junctionMain descriptors = do @@ -167,7 +188,8 @@ junctionMain descriptors = do
peConfigPath = robotsConfigsPath cfg,
peQuoteThread = qt,
peBroker = bro,
peRobots = robotsMap
peRobots = robotsMap,
peLogAction = junctionLogAction
}
withJunction env $ do
startRobots cfg bro barsMap
@ -194,7 +216,8 @@ junctionMain descriptors = do @@ -194,7 +216,8 @@ junctionMain descriptors = do
rConf <- liftIO $ newIORef (confStrategy bigConf)
rState <- loadState (stateKey inst) >>= liftIO . newIORef
rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef
let robotEnv = RobotEnv rState rConf rTimers bro barsMap
let robotLogAction = fmtMessage >$< logTextStdout
let robotEnv = RobotEnv rState rConf rTimers bro barsMap robotLogAction
robot <- createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState rTimers
robotsMap' <- asks peRobots
liftIO $ atomicModifyIORef' robotsMap' (\s -> (M.insert (strategyId inst) robot s, ()))
@ -215,7 +238,7 @@ junctionMain descriptors = do @@ -215,7 +238,7 @@ junctionMain descriptors = do
case getNotificationTarget robotsMap ordersMap notification of
Just robot -> postNotificationEvent robot notification
Nothing -> warningM "Junction" "Unknown order"
Nothing -> return () --logWarning "Junction" "Unknown order" -- TODO log
atomicModifyIORef' handled (\s -> (S.insert (getNotificationSqnum notification) s, ()))

22
src/ATrade/Driver/Junction/QuoteThread.hs
Unescape View File

@ -1,7 +1,11 @@ @@ -1,7 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module ATrade.Driver.Junction.QuoteThread
(
@ -17,6 +21,7 @@ module ATrade.Driver.Junction.QuoteThread @@ -17,6 +21,7 @@ module ATrade.Driver.Junction.QuoteThread
import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (..))
import ATrade.Driver.Junction.QuoteStream (QuoteSubscription (..))
import ATrade.Logging (Message)
import ATrade.Quotes.HistoryProvider (HistoryProvider (..))
import ATrade.Quotes.QHP (QHPHandle, requestHistoryFromQHP)
import ATrade.Quotes.QTIS (TickerInfo (tiLotSize, tiTickSize, tiTicker),
@ -36,13 +41,17 @@ import ATrade.Types (BarTimeframe (BarT @@ -36,13 +41,17 @@ import ATrade.Types (BarTimeframe (BarT
ClientSecurityParams (ClientSecurityParams),
Tick (security),
TickerId)
import Colog (HasLog (getLogAction, setLogAction),
LogAction,
WithLog)
import Control.Concurrent (ThreadId, forkIO,
killThread)
import Control.Concurrent.BoundedChan (BoundedChan,
newBoundedChan,
readChan,
writeChan)
import Control.Exception.Safe (MonadThrow,
import Control.Exception.Safe (MonadMask,
MonadThrow,
bracket)
import Control.Monad (forM, forever)
import Control.Monad.Reader (MonadIO (liftIO), ReaderT (runReaderT),
@ -75,6 +84,7 @@ data QuoteThreadEnv = @@ -75,6 +84,7 @@ data QuoteThreadEnv =
startQuoteThread :: (MonadIO m,
MonadIO m1,
WithLog DownloaderEnv Message m1,
HistoryProvider m1,
TickerInfoProvider m1) =>
IORef Bars ->
@ -161,12 +171,17 @@ data DownloaderEnv = @@ -161,12 +171,17 @@ data DownloaderEnv =
{
qhp :: QHPHandle,
downloaderContext :: Context,
downloaderQtisEndpoint :: T.Text
downloaderQtisEndpoint :: T.Text,
logAction :: LogAction DownloaderM Message
}
newtype DownloaderM a = DownloaderM { unDownloaderM :: ReaderT DownloaderEnv IO a }
deriving (Functor, Applicative, Monad, MonadReader DownloaderEnv, MonadIO, MonadThrow)
instance HasLog DownloaderEnv Message DownloaderM where
getLogAction = logAction
setLogAction a e = e { logAction = a }
instance HistoryProvider DownloaderM where
getHistory tid tf from to = do
q <- asks qhp
@ -176,7 +191,7 @@ instance TickerInfoProvider DownloaderM where @@ -176,7 +191,7 @@ instance TickerInfoProvider DownloaderM where
getInstrumentParameters tickers = do
ctx <- asks downloaderContext
ep <- asks downloaderQtisEndpoint
tis <- liftIO $ forM tickers (qtisGetTickersInfo ctx ep)
tis <- forM tickers (qtisGetTickersInfo ctx ep)
pure $ convert `fmap` tis
where
convert ti = InstrumentParameters
@ -196,7 +211,6 @@ withQThread env barsMap cfg ctx f = do @@ -196,7 +211,6 @@ withQThread env barsMap cfg ctx f = do
(runDownloaderM env))
stopQuoteThread f
where
loadSecurityParameters :: IO ClientSecurityParams
loadSecurityParameters =
case (quotesourceClientCert cfg, quotesourceServerCert cfg) of
(Just clientCertPath, Just serverCertPath) -> do

15
src/ATrade/Driver/Junction/RobotDriverThread.hs
Unescape View File

@ -1,7 +1,9 @@ @@ -1,7 +1,9 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module ATrade.Driver.Junction.RobotDriverThread
@ -26,6 +28,7 @@ import ATrade.Driver.Junction.Types (BigConfig, @@ -26,6 +28,7 @@ import ATrade.Driver.Junction.Types (BigConfig,
eventCallback, stateKey,
strategyId, tickerId,
timeframe)
import ATrade.Logging (Message, logInfo)
import ATrade.QuoteSource.Client (QuoteData (..))
import ATrade.RoboCom.ConfigStorage (ConfigStorage)
import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderUpdate),
@ -34,6 +37,8 @@ import ATrade.RoboCom.Persistence (MonadPersistence) @@ -34,6 +37,8 @@ import ATrade.RoboCom.Persistence (MonadPersistence)
import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId),
Bars)
import ATrade.Types (OrderId, OrderState, Trade)
import Colog (HasLog (getLogAction, setLogAction),
LogAction)
import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.BoundedChan (BoundedChan,
newBoundedChan, readChan,
@ -50,7 +55,6 @@ import qualified Data.Map.Strict as M @@ -50,7 +55,6 @@ import qualified Data.Map.Strict as M
import qualified Data.Text.Lazy as TL
import Data.Time (UTCTime)
import Dhall (FromDhall)
import System.Log.Logger (infoM)
data RobotDriverHandle = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) =>
RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent)
@ -127,12 +131,17 @@ data RobotEnv c s = @@ -127,12 +131,17 @@ data RobotEnv c s =
configRef :: IORef c,
timersRef :: IORef [UTCTime],
broker :: BrokerClientHandle,
bars :: IORef Bars
bars :: IORef Bars,
logAction :: LogAction (RobotM c s) Message
}
newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a }
deriving (Functor, Applicative, Monad, MonadReader (RobotEnv c s), MonadIO, MonadThrow)
instance HasLog (RobotEnv c s) Message (RobotM c s) where
getLogAction = logAction
setLogAction a e = e { logAction = a }
instance MonadRobot (RobotM c s) c s where
submitOrder order = do
bro <- asks broker
@ -142,7 +151,7 @@ instance MonadRobot (RobotM c s) c s where @@ -142,7 +151,7 @@ instance MonadRobot (RobotM c s) c s where
bro <- asks broker
liftIO $ void $ Bro.cancelOrder bro oid
appendToLog = liftIO . infoM "Robot" . TL.unpack
appendToLog = logInfo "RobotM" . TL.toStrict -- TODO get instance id from environment and better use it instead of generic 'RobotM'
setupTimer t = do
ref <- asks timersRef

5
src/ATrade/Quotes/Finam.hs
Unescape View File

@ -18,10 +18,12 @@ module ATrade.Quotes.Finam ( @@ -18,10 +18,12 @@ module ATrade.Quotes.Finam (
) where
import ATrade.Types
import Colog (HasLog, Msg)
import Control.Error.Util
import Control.Exception
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class (MonadIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
@ -37,7 +39,6 @@ import Data.Time.Format @@ -37,7 +39,6 @@ import Data.Time.Format
import qualified Data.Vector as V
import Network.Wreq
import Safe
import System.Log.Logger
import Text.Parsec
import Text.ParserCombinators.Parsec.Number
@ -209,7 +210,7 @@ instance FromRecord Row where @@ -209,7 +210,7 @@ instance FromRecord Row where
Just dt -> return dt
Nothing -> fail "Unable to parse date/time"
downloadAndParseQuotes :: RequestParams -> IO (Maybe [Row])
downloadAndParseQuotes :: (MonadIO m, HasLog env Msg m)RequestParams -> IO (Maybe [Row])
downloadAndParseQuotes requestParams = downloadAndParseQuotes' 3
where
downloadAndParseQuotes' iter = do

26
src/ATrade/Quotes/QHP.hs
Unescape View File

@ -1,4 +1,6 @@ @@ -1,4 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module ATrade.Quotes.QHP (
Period(..),
@ -9,18 +11,20 @@ module ATrade.Quotes.QHP ( @@ -9,18 +11,20 @@ module ATrade.Quotes.QHP (
) where
import ATrade.Exceptions
import ATrade.Logging (Message, logInfo)
import ATrade.Types
import Control.Exception.Safe (MonadThrow, throw)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Colog (WithLog)
import Control.Exception.Safe (MonadThrow, throw)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson
import Data.Binary.Get
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Format
import System.Log.Logger
import Language.Haskell.Printf (t)
import System.ZMQ4
data Period =
@ -53,10 +57,10 @@ data QHPHandle = QHPHandle @@ -53,10 +57,10 @@ data QHPHandle = QHPHandle
mkQHPHandle :: Context -> T.Text -> QHPHandle
mkQHPHandle = QHPHandle
requestHistoryFromQHP :: (MonadThrow m, MonadIO m) => QHPHandle -> TickerId -> BarTimeframe -> UTCTime -> UTCTime -> m [Bar]
requestHistoryFromQHP :: (WithLog env Message m, MonadThrow m, MonadIO m) => QHPHandle -> TickerId -> BarTimeframe -> UTCTime -> UTCTime -> m [Bar]
requestHistoryFromQHP qhp tickerId timeframe fromTime toTime =
case parseQHPPeriod (unBarTimeframe timeframe) of
Just tf -> liftIO $ getQuotes (qhpContext qhp) (params tf)
Just tf -> getQuotes (qhpContext qhp) (params tf)
_ -> throw $ BadParams "QHP: Unable to parse timeframe"
where
params tf = RequestParams
@ -96,10 +100,10 @@ instance ToJSON RequestParams where @@ -96,10 +100,10 @@ instance ToJSON RequestParams where
"to" .= printDatetime (UTCTime (endDate p) 0),
"timeframe" .= show (period p) ]
getQuotes :: Context -> RequestParams -> IO [Bar]
getQuotes ctx params =
withSocket ctx Req $ \sock -> do
debugM "QHP" $ "Connecting to ep: " ++ show (endpoint params)
getQuotes :: (WithLog env Message m, MonadIO m) => Context -> RequestParams -> m [Bar]
getQuotes ctx params = do
logInfo "QHP" $ "Connecting to ep: " <> endpoint params
liftIO $ withSocket ctx Req $ \sock -> do
connect sock $ (T.unpack . endpoint) params
send sock [] (BL.toStrict $ encode params)
response <- receiveMulti sock

15
src/ATrade/Quotes/QTIS.hs
Unescape View File

@ -1,3 +1,4 @@ @@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module ATrade.Quotes.QTIS
@ -7,13 +8,15 @@ module ATrade.Quotes.QTIS @@ -7,13 +8,15 @@ module ATrade.Quotes.QTIS
) where
import ATrade.Exceptions
import ATrade.Logging (Message, logInfo)
import ATrade.Types
import Colog (WithLog)
import Control.Exception.Safe
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import System.Log.Logger
import System.ZMQ4
data TickerInfo = TickerInfo {
@ -34,16 +37,14 @@ instance ToJSON TickerInfo where @@ -34,16 +37,14 @@ instance ToJSON TickerInfo where
"lot_size" .= tiLotSize ti,
"tick_size" .= tiTickSize ti ]
qtisGetTickersInfo :: Context -> T.Text -> TickerId -> IO TickerInfo
qtisGetTickersInfo ctx endpoint tickerId =
withSocket ctx Req $ \sock -> do
debugM "QTIS" $ "Connecting to: " ++ T.unpack endpoint
qtisGetTickersInfo :: (WithLog env Message m, MonadIO m) => Context -> T.Text -> TickerId -> m TickerInfo
qtisGetTickersInfo ctx endpoint tickerId = do
logInfo "QTIS" $ "Requesting ticker: " <> tickerId <> " from " <> endpoint
liftIO $ withSocket ctx Req $ \sock -> do
connect sock $ T.unpack endpoint
debugM "QTIS" $ "Requesting: " ++ T.unpack tickerId
send sock [] $ BL.toStrict tickerRequest
response <- receiveMulti sock
let r = parseResponse response
debugM "QTIS" $ "Got response: " ++ show r
case r of
Just resp -> return resp
Nothing -> throw $ QTISFailure "Can't parse response"

2
stack.yaml
Unescape View File

@ -48,6 +48,8 @@ extra-deps: @@ -48,6 +48,8 @@ extra-deps:
- binary-ieee754-0.1.0.0
- th-printf-0.7
- normaldistribution-1.1.0.3
- co-log-0.4.0.1@sha256:3d4c17f37693c80d1aa2c41669bc3438fac3e89dc5f479e57d79bc3ddc4dfcc5,5087
- ansi-terminal-0.10.3@sha256:e2fbcef5f980dc234c7ad8e2fa433b0e8109132c9e643bc40ea5608cd5697797,3226
# Override default flag values for local packages and extra-deps
# flags: {}

Write Preview
Loading…
Cancel
Save