From 632ca49d15e0d04a832e32460ba1b952b8643fcd Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Mon, 29 Nov 2021 21:06:12 +0700 Subject: [PATCH] Logging: use co-log && logging facilities from libatrade-0.11 --- robocom-zero.cabal | 5 +-- src/ATrade/Driver/Junction.hs | 45 ++++++++++++++----- src/ATrade/Driver/Junction/QuoteThread.hs | 22 +++++++-- .../Driver/Junction/RobotDriverThread.hs | 15 +++++-- src/ATrade/Quotes/Finam.hs | 5 ++- src/ATrade/Quotes/QHP.hs | 26 ++++++----- src/ATrade/Quotes/QTIS.hs | 15 ++++--- stack.yaml | 2 + 8 files changed, 94 insertions(+), 41 deletions(-) diff --git a/robocom-zero.cabal b/robocom-zero.cabal index 921f893..37cf0b1 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -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 , 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 , vector , wreq , safe - , hslogger , parsec , parsec-numbers , aeson @@ -86,6 +84,7 @@ library , async , dhall , extra + , co-log default-language: Haskell2010 other-modules: ATrade.Exceptions diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index b6963e0..ac72ded 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -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, 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 = 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 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 -- 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 () 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 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 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 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, ())) diff --git a/src/ATrade/Driver/Junction/QuoteThread.hs b/src/ATrade/Driver/Junction/QuoteThread.hs index c78f8c7..bd3090f 100644 --- a/src/ATrade/Driver/Junction/QuoteThread.hs +++ b/src/ATrade/Driver/Junction/QuoteThread.hs @@ -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 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 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 = startQuoteThread :: (MonadIO m, MonadIO m1, + WithLog DownloaderEnv Message m1, HistoryProvider m1, TickerInfoProvider m1) => IORef Bars -> @@ -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 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 (runDownloaderM env)) stopQuoteThread f where - loadSecurityParameters :: IO ClientSecurityParams loadSecurityParameters = case (quotesourceClientCert cfg, quotesourceServerCert cfg) of (Just clientCertPath, Just serverCertPath) -> do diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index ae7e235..8c726bc 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -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, 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) 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 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 = 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 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 diff --git a/src/ATrade/Quotes/Finam.hs b/src/ATrade/Quotes/Finam.hs index 005409d..c7b26dc 100644 --- a/src/ATrade/Quotes/Finam.hs +++ b/src/ATrade/Quotes/Finam.hs @@ -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 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 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 diff --git a/src/ATrade/Quotes/QHP.hs b/src/ATrade/Quotes/QHP.hs index 28ed63d..1ff7f19 100644 --- a/src/ATrade/Quotes/QHP.hs +++ b/src/ATrade/Quotes/QHP.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module ATrade.Quotes.QHP ( Period(..), @@ -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 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 "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 diff --git a/src/ATrade/Quotes/QTIS.hs b/src/ATrade/Quotes/QTIS.hs index b4d2163..83e95ff 100644 --- a/src/ATrade/Quotes/QTIS.hs +++ b/src/ATrade/Quotes/QTIS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} 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 "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" diff --git a/stack.yaml b/stack.yaml index 2011e3d..1f6d9a3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: {}