From 20fd1f25e3c958effe757a53b36c77b06069a611 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 7 Nov 2021 21:23:01 +0700 Subject: [PATCH 01/25] Junction branch --- robocom-zero.cabal | 4 + src/ATrade/Driver/Junction.hs | 38 +++-- src/ATrade/Driver/Junction/OrderRouter.hs | 178 ++++++++++++++++++++++ 3 files changed, 211 insertions(+), 9 deletions(-) create mode 100644 src/ATrade/Driver/Junction/OrderRouter.hs diff --git a/robocom-zero.cabal b/robocom-zero.cabal index 87828c2..a9da65b 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -29,6 +29,7 @@ library , ATrade.Driver.Backtest , ATrade.Driver.Junction , ATrade.Driver.Junction.Types + , ATrade.Driver.Junction.OrderRouter , ATrade.BarAggregator , ATrade.RoboCom other-modules: Paths_robocom_zero @@ -69,6 +70,9 @@ library , gitrev , data-default , template-haskell + , unliftio + , monad-logger + , bimap default-language: Haskell2010 other-modules: ATrade.Exceptions diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index e89de78..116767a 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module ATrade.Driver.Junction ( @@ -7,14 +8,33 @@ module ATrade.Driver.Junction import ATrade.Driver.Junction.Types (StrategyDescriptor (..), StrategyInstance (..), StrategyInstanceDescriptor (..)) -import Data.Aeson (decode) +import ATrade.RoboCom.Types (Ticker (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), + decode, object, withObject, (.:), + (.=)) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) import qualified Data.Text as T -load :: T.Text -> IO B.ByteString +data BigConfig c = BigConfig { + confTickers :: [Ticker], + confStrategy :: c +} + +instance (FromJSON c) => FromJSON (BigConfig c) where + parseJSON = withObject "object" (\obj -> BigConfig <$> + obj .: "tickers" <*> + obj .: "params") + +instance (ToJSON c) => ToJSON (BigConfig c) where + toJSON conf = object ["tickers" .= confTickers conf, + "params" .= confStrategy conf ] + + +load :: T.Text -> IO (Maybe B.ByteString) load = undefined junctionMain :: M.Map T.Text StrategyDescriptor -> IO () @@ -36,10 +56,10 @@ junctionMain descriptors = do sState <- load (stateKey desc) sCfg <- load (configKey desc) case M.lookup (strategyId desc) descriptors of - Just (StrategyDescriptor _sName sCallback _sDefState) -> - case (decode $ BL.fromStrict sCfg, decode $ BL.fromStrict sState) of - (Just pCfg, Just pState) -> do - cfgRef <- newIORef pCfg + Just (StrategyDescriptor _sName sCallback sDefState) -> + case (sCfg >>= decode . BL.fromStrict, fromMaybe sDefState (sState >>= decode . BL.fromStrict)) of + (Just bigConfig, pState) -> do + cfgRef <- newIORef (confStrategy bigConfig) stateRef <- newIORef pState return $ StrategyInstance { @@ -48,10 +68,10 @@ junctionMain descriptors = do strategyState = stateRef, strategyConfig = cfgRef } - _ -> undefined - _ -> undefined + _ -> error "Can't read state and config" + _ -> error $ "Can't find strategy: " ++ T.unpack (strategyId desc) - start = undefined + start strategy = undefined diff --git a/src/ATrade/Driver/Junction/OrderRouter.hs b/src/ATrade/Driver/Junction/OrderRouter.hs new file mode 100644 index 0000000..9fe5825 --- /dev/null +++ b/src/ATrade/Driver/Junction/OrderRouter.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module ATrade.Driver.Junction.OrderRouter + ( + mkOrderRouter, + AccountsList + ) where + +import ATrade.Broker.Client (BrokerClientHandle (cancelOrder, getNotifications, submitOrder), + startBrokerClient, + stopBrokerClient) +import ATrade.Broker.Protocol (Notification (..)) +import ATrade.RoboCom.Monad (Event (..)) +import ATrade.Types (ClientSecurityParams, + Order (..), OrderId) +import Control.Concurrent.BoundedChan (BoundedChan, newBoundedChan, + readChan, tryReadChan, + writeChan, writeList2Chan) +import Control.Monad (forM_, forever) +import Control.Monad.Logger (MonadLogger, logDebugS, + logInfoS, logWarnS) +import qualified Data.Bimap as BM +import qualified Data.ByteString.Char8 as B8 +import Data.List (find) +import qualified Data.Text as T +import GHC.OverloadedLabels (IsLabel (..)) +import System.ZMQ4 (Context) +import UnliftIO (MonadUnliftIO, liftIO) +import UnliftIO.Concurrent (ThreadId, forkIO) +import UnliftIO.IORef (IORef, atomicModifyIORef', + newIORef, readIORef) + +data OrderRouterEvent = + SubmitOrder Order | + CancelOrder OrderId | + BrokerNotification Notification + +data OrderRouter = + OrderRouter + { + requestChan :: BoundedChan OrderRouterEvent, + eventChan :: BoundedChan Event, + routerThread :: ThreadId, + brokers :: [([T.Text], BrokerClientHandle)] + } + +instance IsLabel "requestChan" (OrderRouter -> BoundedChan OrderRouterEvent) where + fromLabel = requestChan + +instance IsLabel "eventChan" (OrderRouter -> BoundedChan Event) where + fromLabel = eventChan + +instance IsLabel "brokers" (OrderRouter -> [([T.Text], BrokerClientHandle)]) where + fromLabel = brokers + +data OrderRouterEnv = + OrderRouterEnv + { + requestChan :: BoundedChan OrderRouterEvent, + eventChan :: BoundedChan Event, + brokers :: [([T.Text], BrokerClientHandle)], + notificationRequestThread :: ThreadId, + orderIdMap :: IORef (BM.Bimap OrderId (OrderId, T.Text)), + currentOrderId :: IORef OrderId + } + +instance IsLabel "requestChan" (OrderRouterEnv -> BoundedChan OrderRouterEvent) where + fromLabel = requestChan + +instance IsLabel "eventChan" (OrderRouterEnv -> BoundedChan Event) where + fromLabel = eventChan + +instance IsLabel "brokers" (OrderRouterEnv -> [([T.Text], BrokerClientHandle)]) where + fromLabel = brokers + +-- | List of pairs: ([accounts], broker-endpoint, security-params) +type AccountsList = [([T.Text], T.Text, ClientSecurityParams)] + + +mkOrderRouter :: (MonadUnliftIO m, MonadLogger m) => Context -> AccountsList -> BoundedChan Event -> m OrderRouter +mkOrderRouter ctx accounts evtChan = do + $(logInfoS) "OrderRouter" "Order Router started" + rqChan <- liftIO $ newBoundedChan 1000 + bros <- makeBrokers accounts + idmap <- newIORef BM.empty + rqThread <- forkIO $ requestNotifications bros rqChan + idcnt <- newIORef 1 + let env = OrderRouterEnv { + requestChan = rqChan, + eventChan = evtChan, + brokers = bros, + notificationRequestThread = rqThread, + orderIdMap = idmap, + currentOrderId = idcnt + } + tId <- forkIO (react env) + return $ OrderRouter rqChan evtChan tId bros + where + makeBrokers = mapM (\(accs, ep, secParams) -> do + bro <- liftIO $ startBrokerClient (B8.pack "foo") ctx ep secParams + return (accs, bro)) + + react env = do + $(logDebugS) "OrderRouter" "Order Router react" + let rqChan = #requestChan env + evts <- liftIO $ readChanMax 20 rqChan + forM_ evts (handleEvent env) + + handleEvent env evt = do + case evt of + (SubmitOrder order) -> doSubmitOrder env order + (CancelOrder oid) -> doCancelOrder env oid + (BrokerNotification notification) -> handleBrokerNotification env notification + + readChanMax n chan = do + first <- readChan chan + rest <- readChanN (n - 1) chan + return $ first : rest + + readChanN n chan + | n <= 0 = return [] + | otherwise = do + x <- tryReadChan chan + case x of + Nothing -> return [] + Just v -> do + rest <- readChanN (n - 1) chan + return $ v : rest + + doSubmitOrder env order = do + let bros = #brokers env + case findBrokerForAccount (orderAccountId order) bros of + Just bro -> do + result <- liftIO $ submitOrder bro order + case result of + Left errmsg -> $(logWarnS) "OrderRouter" $ "Unable to submit order: " <> errmsg + Right oid -> do + newOrderId <- atomicModifyIORef' (currentOrderId env) (\s -> (s + 1, s)) + atomicModifyIORef' (orderIdMap env) (\s -> (BM.insert newOrderId (oid, orderAccountId order) s, ())) + pushEvent (OrderSubmitted order { orderId = newOrderId }) + + Nothing -> $(logWarnS) "OrderRouter" $ "No broker found for account: " <> orderAccountId order + + doCancelOrder env oid = do + let bros = #brokers env + idpair <- BM.lookup oid <$> readIORef (orderIdMap env) + case idpair of + Just (brokerOrderId, account) -> + case findBrokerForAccount account bros of + Just bro -> do + result <- liftIO $ cancelOrder bro brokerOrderId + case result of + Left errmsg -> $(logWarnS) "OrderRouter" $ "Unable to cancel order: " <> (T.pack . show) brokerOrderId <> ", account: " <> account <> ", " <> errmsg + Right _ -> return () + Nothing -> $(logWarnS) "OrderRouter" $ "Can't find broker for order: " <> (T.pack . show) brokerOrderId <> ", account: " <> account + Nothing -> $(logWarnS) "OrderRouter" $ "Can't find order id map: " <> (T.pack . show) oid + + handleBrokerNotification env notification = undefined + pushEvent event = liftIO $ writeChan evtChan event + + findBrokerForAccount :: T.Text -> [([T.Text], BrokerClientHandle)] -> Maybe BrokerClientHandle + findBrokerForAccount accId bros = snd <$> find (\x -> accId `elem` fst x) bros + + requestNotifications bros rqChan = forever $ do + forM_ bros $ \(_, handle) -> do + result <- liftIO $ getNotifications handle + case result of + Left errmsg -> $(logWarnS) "OrderRouter" $ "Can't request notifications: " <> errmsg + Right nots -> liftIO $ writeList2Chan rqChan (BrokerNotification <$> nots) + + From c424dc217a0da2af6e87bb1f336e4ee81dd0e3c6 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 20 Nov 2021 19:33:03 +0700 Subject: [PATCH 02/25] WIP: QuoteThread mostly works --- robocom-zero.cabal | 29 ++-- src/ATrade/BarAggregator.hs | 10 +- src/ATrade/Driver/Junction.hs | 94 +++++++++--- src/ATrade/Driver/Junction/QuoteThread.hs | 147 +++++++++++++++++++ src/ATrade/Driver/Junction/Types.hs | 12 +- src/ATrade/Quotes/HistoryProvider.hs | 14 ++ src/ATrade/Quotes/TickerInfoProvider.hs | 13 ++ src/ATrade/Quotes/Types.hs | 0 src/ATrade/RoboCom/Positions.hs | 6 +- src/ATrade/RoboCom/Types.hs | 23 +-- src/ATrade/RoboCom/Utils.hs | 7 +- test/ArbitraryInstances.hs | 2 +- test/Spec.hs | 6 +- test/Test/BarAggregator.hs | 133 ++--------------- test/Test/Driver/Junction/QuoteThread.hs | 82 +++++++++++ test/Test/Mock/HistoryProvider.hs | 25 ++++ test/Test/Mock/TickerInfoProvider.hs | 17 +++ test/Test/RoboCom/Positions.hs | 167 ---------------------- 18 files changed, 437 insertions(+), 350 deletions(-) create mode 100644 src/ATrade/Driver/Junction/QuoteThread.hs create mode 100644 src/ATrade/Quotes/HistoryProvider.hs create mode 100644 src/ATrade/Quotes/TickerInfoProvider.hs create mode 100644 src/ATrade/Quotes/Types.hs create mode 100644 test/Test/Driver/Junction/QuoteThread.hs create mode 100644 test/Test/Mock/HistoryProvider.hs create mode 100644 test/Test/Mock/TickerInfoProvider.hs delete mode 100644 test/Test/RoboCom/Positions.hs diff --git a/robocom-zero.cabal b/robocom-zero.cabal index a9da65b..da3c561 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -25,16 +25,18 @@ library , ATrade.Quotes.Finam , ATrade.Quotes.QHP , ATrade.Quotes.QTIS - , ATrade.Driver.Real - , ATrade.Driver.Backtest +-- , ATrade.Driver.Real +-- , ATrade.Driver.Backtest , ATrade.Driver.Junction , ATrade.Driver.Junction.Types - , ATrade.Driver.Junction.OrderRouter , ATrade.BarAggregator , ATrade.RoboCom + , ATrade.Driver.Junction.QuoteThread + , ATrade.Quotes.HistoryProvider + , ATrade.Quotes.TickerInfoProvider other-modules: Paths_robocom_zero build-depends: base >= 4.7 && < 5 - , libatrade >= 0.9.0.0 && < 0.10.0.0 + , libatrade >= 0.10.0.0 && < 0.11.0.0 , text , text-icu , errors @@ -53,7 +55,9 @@ library , binary , binary-ieee754 , zeromq4-haskell + , zeromq4-haskell-zap , unordered-containers + , hashable , th-printf , BoundedChan , monad-loops @@ -73,11 +77,14 @@ library , unliftio , monad-logger , bimap - + , stm + , async + , dhall + default-language: Haskell2010 other-modules: ATrade.Exceptions - , ATrade.Driver.Real.BrokerClientThread - , ATrade.Driver.Real.QuoteSourceThread +-- , ATrade.Driver.Real.BrokerClientThread +-- , ATrade.Driver.Real.QuoteSourceThread , ATrade.Driver.Types test-suite robots-test @@ -99,13 +106,19 @@ test-suite robots-test , quickcheck-instances , containers , safe + , zeromq4-haskell + , zeromq4-haskell-zap + , BoundedChan + , hslogger ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 other-modules: Test.RoboCom.Indicators - , Test.RoboCom.Positions , Test.RoboCom.Utils + , Test.Driver.Junction.QuoteThread , Test.BarAggregator , ArbitraryInstances + , Test.Mock.HistoryProvider + , Test.Mock.TickerInfoProvider source-repository head type: git diff --git a/src/ATrade/BarAggregator.hs b/src/ATrade/BarAggregator.hs index 904ec74..f385e52 100644 --- a/src/ATrade/BarAggregator.hs +++ b/src/ATrade/BarAggregator.hs @@ -79,12 +79,12 @@ handleTick tick = runState $ do case M.lookup (security tick) mybars of Just series -> case bsBars series of (b:bs) -> do - let currentBn = barNumber (barTimestamp b) (tfSeconds $ bsTimeframe series) + let currentBn = barNumber (barTimestamp b) (fromIntegral . unBarTimeframe $ bsTimeframe series) case datatype tick of LastTradePrice -> if volume tick > 0 then - if currentBn == barNumber (timestamp tick) (tfSeconds $ bsTimeframe series) + if currentBn == barNumber (timestamp tick) (fromIntegral . unBarTimeframe $ bsTimeframe series) then do lBars %= M.insert (security tick) series { bsBars = updateBar b tick : bs } return Nothing @@ -94,7 +94,7 @@ handleTick tick = runState $ do else return Nothing _ -> - if currentBn == barNumber (timestamp tick) (tfSeconds $ bsTimeframe series) + if currentBn == barNumber (timestamp tick) (fromIntegral . unBarTimeframe $ bsTimeframe series) then do lBars %= M.insert (security tick) series { bsBars = updateBarTimestamp b tick : bs } return Nothing @@ -147,8 +147,8 @@ updateTime tick = runState $ do case M.lookup (security tick) mybars of Just series -> case bsBars series of (b:bs) -> do - let currentBn = barNumber (barTimestamp b) (tfSeconds $ bsTimeframe series) - let thisBn = barNumber (timestamp tick) (tfSeconds $ bsTimeframe series) + let currentBn = barNumber (barTimestamp b) (fromIntegral . unBarTimeframe $ bsTimeframe series) + let thisBn = barNumber (timestamp tick) (fromIntegral . unBarTimeframe $ bsTimeframe series) if | currentBn == thisBn -> do lBars %= M.insert (security tick) series { bsBars = updateBarTimestamp b tick : bs } diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index 116767a..d9758da 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -1,23 +1,39 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} module ATrade.Driver.Junction ( junctionMain ) where -import ATrade.Driver.Junction.Types (StrategyDescriptor (..), - StrategyInstance (..), - StrategyInstanceDescriptor (..)) -import ATrade.RoboCom.Types (Ticker (..)) -import Data.Aeson (FromJSON (..), ToJSON (..), - decode, object, withObject, (.:), - (.=)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL +import ATrade.Driver.Junction.Types (StrategyDescriptor (..), + StrategyInstance (..), + StrategyInstanceDescriptor (..)) +import ATrade.RoboCom.Types (Ticker (..)) +import Control.Concurrent (forkIO) +import Control.Concurrent.Async (forConcurrently_) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue (newTQueueIO) +import Control.Concurrent.STM.TVar (newTVarIO) +import Data.Aeson (FromJSON (..), ToJSON (..), + decode, object, withObject, + (.:), (.=)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import Data.IORef -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import qualified Data.Text as T +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Semigroup ((<>)) +import qualified Data.Text as T +import Data.Text.IO (readFile) +import Dhall (FromDhall, auto, input) +import GHC.Generics (Generic) +import Options.Applicative (Parser, execParser, fullDesc, + header, help, helper, info, + long, metavar, progDesc, short, + strOption, (<**>)) +import Prelude hiding (readFile) data BigConfig c = BigConfig { confTickers :: [Ticker], @@ -33,20 +49,51 @@ instance (ToJSON c) => ToJSON (BigConfig c) where toJSON conf = object ["tickers" .= confTickers conf, "params" .= confStrategy conf ] +data ProgramOptions = + ProgramOptions + { + configPath :: FilePath + } + +data ProgramConfiguration = + ProgramConfiguration + { + brokerEndpoint :: T.Text, + brokerServerCert :: Maybe FilePath, + brokerClientCert :: Maybe FilePath, + quotesourceEndpoint :: T.Text, + quotesourceServerCert :: Maybe FilePath, + quotesourceClientCert :: Maybe FilePath, + qhpEndpoint :: T.Text, + qtisEndpoint :: T.Text, + redisSocket :: T.Text, + globalLog :: FilePath, + instances :: [StrategyInstanceDescriptor] + } deriving (Generic, Show) + +instance FromDhall ProgramConfiguration load :: T.Text -> IO (Maybe B.ByteString) load = undefined junctionMain :: M.Map T.Text StrategyDescriptor -> IO () junctionMain descriptors = do - parseOptions - instanceDescriptors <- undefined - strategies <- mkStrategies instanceDescriptors + opts <- parseOptions - start strategies + cfg <- readFile (configPath opts) >>= input auto + + bars <- newTVarIO M.empty + + strategies <- mkStrategies (instances cfg) + + start strategies bars where - parseOptions = undefined + parseOptions = execParser options + options = info (optionsParser <**> helper) + (fullDesc <> + progDesc "Robocom-zero junction mode driver" <> + header "robocom-zero-junction") mkStrategies :: [StrategyInstanceDescriptor] -> IO [StrategyInstance] mkStrategies = mapM mkStrategy @@ -71,8 +118,13 @@ junctionMain descriptors = do _ -> error "Can't read state and config" _ -> error $ "Can't find strategy: " ++ T.unpack (strategyId desc) - start strategy = undefined - - + start strategies bars = undefined + optionsParser :: Parser ProgramOptions + optionsParser = ProgramOptions + <$> strOption + (long "config" <> + short 'c' <> + metavar "FILENAME" <> + help "Configuration file path") diff --git a/src/ATrade/Driver/Junction/QuoteThread.hs b/src/ATrade/Driver/Junction/QuoteThread.hs new file mode 100644 index 0000000..4753f8e --- /dev/null +++ b/src/ATrade/Driver/Junction/QuoteThread.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +module ATrade.Driver.Junction.QuoteThread + ( + QuoteThreadHandle, + startQuoteThread, + stopQuoteThread, + addSubscription + ) where + +import ATrade.Quotes.HistoryProvider (HistoryProvider (..)) +import ATrade.Quotes.TickerInfoProvider (TickerInfoProvider (..)) +import ATrade.QuoteSource.Client (QuoteData (QDBar, QDTick), + QuoteSourceClientHandle, + quoteSourceClientSubscribe, + startQuoteSourceClient, + stopQuoteSourceClient) +import ATrade.RoboCom.Types (Bar (barSecurity), + BarSeries (..), + BarSeriesId (BarSeriesId), + Bars, InstrumentParameters) +import ATrade.Types (BarTimeframe (BarTimeframe), ClientSecurityParams (ClientSecurityParams), + Tick (security), TickerId) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Concurrent.BoundedChan (BoundedChan, newBoundedChan, + readChan, writeChan) +import Control.Monad (forever) +import Control.Monad.Reader (MonadIO (liftIO), + ReaderT (runReaderT), lift) +import Control.Monad.Reader.Class (asks) +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.IORef (IORef, atomicModifyIORef', + newIORef, readIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Time (addUTCTime, getCurrentTime) +import GHC.Generics (Generic) +import System.ZMQ4 (Context) +import System.ZMQ4.ZAP (CurveCertificate) + +data QuoteSubscription = + QuoteSubscription TickerId BarTimeframe + deriving (Generic, Eq) + +instance Hashable BarTimeframe +instance Hashable QuoteSubscription + +data QuoteThreadHandle = QuoteThreadHandle ThreadId ThreadId QuoteThreadEnv + +data QuoteThreadEnv = + QuoteThreadEnv + { + bars :: IORef Bars, + endpoints :: IORef (HM.HashMap QuoteSubscription [BoundedChan QuoteData]), + qsclient :: QuoteSourceClientHandle, + paramsCache :: IORef (M.Map TickerId InstrumentParameters), + historyProvider :: HistoryProvider, + tickerInfoProvider :: TickerInfoProvider, + downloaderChan :: BoundedChan QuoteSubscription + } + +startQuoteThread :: (MonadIO m) => + IORef Bars -> + Context -> + T.Text -> + Maybe CurveCertificate -> + Maybe CurveCertificate -> + HistoryProvider -> + TickerInfoProvider -> + m QuoteThreadHandle +startQuoteThread barsRef ctx ep clientCert serverCert hp tip = do + chan <- liftIO $ newBoundedChan 2000 + dChan <- liftIO $ newBoundedChan 2000 + qsc <- liftIO $ startQuoteSourceClient chan [] ctx ep (ClientSecurityParams clientCert serverCert) + env <- liftIO $ QuoteThreadEnv barsRef <$> newIORef HM.empty <*> pure qsc <*> newIORef M.empty <*> pure hp <*> pure tip <*> pure dChan + tid <- liftIO . forkIO $ quoteThread env chan + downloaderTid <- liftIO . forkIO $ downloaderThread env dChan + return $ QuoteThreadHandle tid downloaderTid env + where + downloaderThread env chan = forever $ do + QuoteSubscription tickerid tf <- readChan chan + paramsMap <- liftIO $ readIORef $ paramsCache env + mbParams <- case M.lookup tickerid paramsMap of + Nothing -> do + paramsList <- liftIO $ getInstrumentParameters (tickerInfoProvider env) [tickerid] + case paramsList of + (params:_) -> liftIO $ atomicModifyIORef' (paramsCache env) (\m -> (M.insert tickerid params m, Just params)) + _ -> return Nothing + Just params -> return $ Just params + barsMap <- readIORef (bars env) + case M.lookup (BarSeriesId tickerid tf) barsMap of + Just _ -> return () -- already downloaded + Nothing -> case mbParams of + Just params -> do + now <- liftIO getCurrentTime + barsData <- liftIO $ getHistory (historyProvider env) tickerid tf ((-86400 * 60) `addUTCTime` now) now + let barSeries = BarSeries tickerid tf barsData params + atomicModifyIORef' (bars env) (\m -> (M.insert (BarSeriesId tickerid tf) barSeries m, ())) + _ -> return () -- TODO log + + + quoteThread env chan = flip runReaderT env $ forever $ do + qssData <- lift $ readChan chan + case qssData of + QDBar (tf, bar) -> do + barsRef' <- asks bars + lift $ atomicModifyIORef' barsRef' (\x -> (updateBarsMap x bar tf, ())) + _ -> return () -- TODO pass to bar aggregator + let key = case qssData of + QDTick tick -> QuoteSubscription (security tick) (BarTimeframe 0) + QDBar (tf, bar) -> QuoteSubscription (barSecurity bar) tf + subs <- asks endpoints >>= (lift . readIORef) + case HM.lookup key subs of + Just clientChannels -> do + lift $ mapM_ (`writeChan` qssData) clientChannels + Nothing -> return () + +stopQuoteThread :: (MonadIO m) => QuoteThreadHandle -> m () +stopQuoteThread (QuoteThreadHandle tid dtid env) = liftIO $ do + killThread tid + killThread dtid + stopQuoteSourceClient (qsclient env) + +addSubscription :: (MonadIO m) => QuoteThreadHandle -> TickerId -> BarTimeframe -> BoundedChan QuoteData -> m () +addSubscription (QuoteThreadHandle _ _ env) tid tf chan = liftIO $ do + writeChan (downloaderChan env) (QuoteSubscription tid tf) + atomicModifyIORef' (endpoints env) (\m -> (doAddSubscription m tid, ())) + quoteSourceClientSubscribe (qsclient env) [(tid, BarTimeframe 0)] + where + doAddSubscription m tickerid = + let m1 = HM.alter (\case + Just chans -> Just (chan : chans) + _ -> Just [chan]) (QuoteSubscription tickerid tf) m in + HM.alter (\case + Just chans -> Just (chan : chans) + _ -> Just [chan]) (QuoteSubscription tickerid (BarTimeframe 0)) m1 + +updateBarsMap :: Bars -> Bar -> BarTimeframe -> Bars +updateBarsMap barsMap bar tf = M.adjust (addToSeries bar) (BarSeriesId (barSecurity bar) tf) barsMap + +addToSeries :: Bar -> BarSeries -> BarSeries +addToSeries bar series = series { bsBars = bar : bsBars series } + + + diff --git a/src/ATrade/Driver/Junction/Types.hs b/src/ATrade/Driver/Junction/Types.hs index d0cdd3c..bc23b80 100644 --- a/src/ATrade/Driver/Junction/Types.hs +++ b/src/ATrade/Driver/Junction/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} @@ -12,9 +14,10 @@ module ATrade.Driver.Junction.Types import ATrade.RoboCom.Monad (EventCallback) import ATrade.Types (BarTimeframe, TickerId) import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.ByteString as B import Data.IORef import qualified Data.Text as T +import Dhall (FromDhall) +import GHC.Generics (Generic) data StrategyDescriptor = forall c s. (FromJSON s, ToJSON s, FromJSON c) => @@ -39,9 +42,10 @@ data StrategyInstanceDescriptor = strategyName :: T.Text, configKey :: T.Text, stateKey :: T.Text, - logPath :: T.Text, - tickers :: [TickerConfig] - } + logPath :: T.Text + } deriving (Generic, Show) + +instance FromDhall StrategyInstanceDescriptor data StrategyInstance = forall c s. (FromJSON s, ToJSON s, FromJSON c) => diff --git a/src/ATrade/Quotes/HistoryProvider.hs b/src/ATrade/Quotes/HistoryProvider.hs new file mode 100644 index 0000000..ad7a9a4 --- /dev/null +++ b/src/ATrade/Quotes/HistoryProvider.hs @@ -0,0 +1,14 @@ + +module ATrade.Quotes.HistoryProvider + ( + HistoryProvider(..) + ) where + +import ATrade.RoboCom.Types (Bar) +import ATrade.Types (BarTimeframe, TickerId) +import Data.Time (UTCTime) +newtype HistoryProvider = + HistoryProvider + { + getHistory :: TickerId -> BarTimeframe -> UTCTime -> UTCTime -> IO [Bar] + } diff --git a/src/ATrade/Quotes/TickerInfoProvider.hs b/src/ATrade/Quotes/TickerInfoProvider.hs new file mode 100644 index 0000000..f66efae --- /dev/null +++ b/src/ATrade/Quotes/TickerInfoProvider.hs @@ -0,0 +1,13 @@ + +module ATrade.Quotes.TickerInfoProvider + ( + TickerInfoProvider(..) + ) where + +import ATrade.RoboCom.Types (InstrumentParameters) +import ATrade.Types (TickerId) +newtype TickerInfoProvider = + TickerInfoProvider + { + getInstrumentParameters :: [TickerId] -> IO [InstrumentParameters] + } diff --git a/src/ATrade/Quotes/Types.hs b/src/ATrade/Quotes/Types.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index 7ddb711..d4e74d6 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -145,7 +145,7 @@ modifyPositions f = do modifyState (\s -> setPositions s (f pos)) class ParamsHasMainTicker a where - mainTicker :: a -> TickerId + mainTicker :: a -> BarSeriesId -- | Helper function. Finds first element in list which satisfies predicate 'p' and if found, applies 'm' to it, leaving other elements intact. findAndModify :: (a -> Bool) -> (a -> a) -> [a] -> [a] @@ -464,7 +464,7 @@ enterAtMarket operationSignalName operation = do enterAtMarketWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position enterAtMarketWithParams account quantity signalId operation = do - tickerId <- mainTicker <$> getConfig + tickerId <- bsidTickerId . mainTicker <$> getConfig submitOrder $ order tickerId newPosition (order tickerId) account tickerId operation quantity 20 where @@ -490,7 +490,7 @@ enterAtLimitWithVolume timeToCancel operationSignalName price vol operation = do enterAtLimitWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position enterAtLimitWithParams timeToCancel account quantity signalId price operation = do - tickerId <- mainTicker <$> getConfig + tickerId <- bsidTickerId . mainTicker <$> getConfig enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation enterAtLimitForTickerWithVolume :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position diff --git a/src/ATrade/RoboCom/Types.hs b/src/ATrade/RoboCom/Types.hs index 935e798..e5b8878 100644 --- a/src/ATrade/RoboCom/Types.hs +++ b/src/ATrade/RoboCom/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,12 +7,12 @@ module ATrade.RoboCom.Types ( Bar(..), + BarSeriesId(..), BarSeries(..), - Timeframe(..), - tfSeconds, Ticker(..), Bars, - InstrumentParameters(..) + InstrumentParameters(..), + bsidTickerId ) where import ATrade.Types @@ -20,12 +21,8 @@ import Data.Aeson.Types import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as M import qualified Data.Text as T +import GHC.Generics (Generic) -newtype Timeframe = - Timeframe Integer deriving (Show, Eq) - -tfSeconds :: (Num a) => Timeframe -> a -tfSeconds (Timeframe s) = fromInteger s data InstrumentParameters = InstrumentParameters { @@ -36,7 +33,7 @@ data InstrumentParameters = data BarSeries = BarSeries { bsTickerId :: TickerId, - bsTimeframe :: Timeframe, + bsTimeframe :: BarTimeframe, bsBars :: [Bar], bsParams :: InstrumentParameters } deriving (Show, Eq) @@ -68,5 +65,11 @@ instance ToJSON Ticker where "timeframe" .= timeframeSeconds t, "aliases" .= Object (HM.fromList $ fmap (\(x, y) -> (T.pack x, String $ T.pack y)) $ aliases t) ] -type Bars = M.Map TickerId BarSeries +data BarSeriesId = BarSeriesId TickerId BarTimeframe + deriving (Show, Eq, Generic, Ord) + +bsidTickerId :: BarSeriesId -> TickerId +bsidTickerId (BarSeriesId tid _) = tid + +type Bars = M.Map BarSeriesId BarSeries diff --git a/src/ATrade/RoboCom/Utils.hs b/src/ATrade/RoboCom/Utils.hs index ff3df31..f9f5f54 100644 --- a/src/ATrade/RoboCom/Utils.hs +++ b/src/ATrade/RoboCom/Utils.hs @@ -20,6 +20,7 @@ import qualified Data.Text as T import Data.Time.Calendar import Data.Time.Clock +import Data.Int (Int64) import Text.Read hiding (String) rescaleToDaily :: [Bar] -> [Bar] @@ -36,13 +37,13 @@ rescaleToDaily (firstBar:restBars) = rescaleToDaily' restBars firstBar rescaleToDaily [] = [] -barEndTime :: Bar -> Integer -> UTCTime +barEndTime :: Bar -> Int64 -> UTCTime barEndTime bar tframe = addUTCTime (fromIntegral $ (1 + barNumber (barTimestamp bar) tframe) * tframe) epoch -barStartTime :: Bar -> Integer -> UTCTime +barStartTime :: Bar -> Int64 -> UTCTime barStartTime bar tframe = addUTCTime (fromIntegral $ barNumber (barTimestamp bar) tframe * tframe) epoch -barNumber :: UTCTime -> Integer -> Integer +barNumber :: UTCTime -> Int64 -> Int64 barNumber ts barlen = floor (diffUTCTime ts epoch) `div` barlen epoch :: UTCTime diff --git a/test/ArbitraryInstances.hs b/test/ArbitraryInstances.hs index e732f7d..e857cb4 100644 --- a/test/ArbitraryInstances.hs +++ b/test/ArbitraryInstances.hs @@ -52,7 +52,7 @@ instance Arbitrary OrderPrice where | v == 2 -> Limit <$> arbitrary `suchThat` notTooBig | v == 3 -> Stop <$> arbitrary `suchThat` notTooBig <*> arbitrary `suchThat` notTooBig | v == 4 -> StopMarket <$> arbitrary `suchThat` notTooBig - | otherwise -> fail "Invalid case" + | otherwise -> error "invalid case" instance Arbitrary Operation where arbitrary = elements [Buy, Sell] diff --git a/test/Spec.hs b/test/Spec.hs index 364f9e6..efdc2c4 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,6 @@ import qualified Test.BarAggregator +import qualified Test.Driver.Junction.QuoteThread import qualified Test.RoboCom.Indicators -import qualified Test.RoboCom.Positions import qualified Test.RoboCom.Utils import Test.Tasty @@ -11,9 +11,9 @@ main = defaultMain $ testGroup "Tests" [unitTests, properties] unitTests :: TestTree unitTests = testGroup "Unit Tests" [Test.RoboCom.Indicators.unitTests, - Test.RoboCom.Positions.unitTests, Test.RoboCom.Utils.unitTests, - Test.BarAggregator.unitTests ] + Test.BarAggregator.unitTests, + Test.Driver.Junction.QuoteThread.unitTests] properties :: TestTree properties = testGroup "Properties" diff --git a/test/Test/BarAggregator.hs b/test/Test/BarAggregator.hs index a9263b5..2f9d88f 100644 --- a/test/Test/BarAggregator.hs +++ b/test/Test/BarAggregator.hs @@ -29,17 +29,14 @@ unitTests = testGroup "BarAggregator" [ , testOneTick , testTwoTicksInSameBar , testTwoTicksInDifferentBars - , testOneBar - , testTwoBarsInSameBar - , testTwoBarsInSameBarLastBar - , testNextBarAfterBarClose - , testUpdateTime ] properties = testGroup "BarAggregator" [ prop_allTicksInOneBar ] +secParams = InstrumentParameters 1 0.01 + testUnknownBarSeries :: TestTree testUnknownBarSeries = testCase "Tick with unknown ticker id" $ do let agg = BarAggregator M.empty M.empty [(0, 86400)] @@ -57,7 +54,7 @@ testUnknownBarSeries = testCase "Tick with unknown ticker id" $ do testOneTick :: TestTree testOneTick = testCase "One tick" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 60) [] + let series = BarSeries "TEST_TICKER" (BarTimeframe 60) [] secParams let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] let (mbar, newagg) = handleTick tick agg mbar @?= Nothing @@ -73,7 +70,7 @@ testOneTick = testCase "One tick" $ do testTwoTicksInSameBar :: TestTree testTwoTicksInSameBar = testCase "Two ticks - same bar" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 60) [] + let series = BarSeries "TEST_TICKER" (BarTimeframe 60) [] secParams let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] let (mbar, newagg) = handleTick (tick testTimestamp1 12.00) agg mbar @?= Nothing @@ -92,7 +89,7 @@ testTwoTicksInSameBar = testCase "Two ticks - same bar" $ do testTwoTicksInDifferentBars :: TestTree testTwoTicksInDifferentBars = testCase "Two ticks - different bar" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 60) [] + let series = BarSeries "TEST_TICKER" (BarTimeframe 60) [] secParams let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] let (mbar, newagg) = handleTick (tick testTimestamp1 12.00) agg mbar @?= Nothing @@ -109,120 +106,6 @@ testTwoTicksInDifferentBars = testCase "Two ticks - different bar" $ do value = fromDouble val, volume = 1 } -testOneBar :: TestTree -testOneBar = testCase "One bar" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 3600) [] - let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] - let (mbar, newagg) = handleBar bar agg - mbar @?= Nothing - (bsBars <$> (M.lookup "TEST_TICKER" $ bars newagg)) @?= Just [Bar "TEST_TICKER" testTimestamp 12.00 18.00 10.00 12.00 68] - where - testTimestamp = (UTCTime (fromGregorian 1970 1 1) 60) - bar = Bar { - barSecurity = "TEST_TICKER", - barTimestamp = testTimestamp, - barOpen = fromDouble 12.00, - barHigh = fromDouble 18.00, - barLow = fromDouble 10.00, - barClose = fromDouble 12.00, - barVolume = 68 } - - -testTwoBarsInSameBar :: TestTree -testTwoBarsInSameBar = testCase "Two bars (smaller timeframe) - same bar" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 600) [] - let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] - let (mbar, newagg) = handleBar (bar testTimestamp1 12.00 13.00 10.00 11.00 1) agg - mbar @?= Nothing - let (mbar', newagg') = handleBar (bar testTimestamp2 12.00 15.00 11.00 12.00 2) newagg - mbar' @?= Nothing - (bsBars <$> (M.lookup "TEST_TICKER" $ bars newagg')) @?= Just [Bar "TEST_TICKER" testTimestamp2 12.00 15.00 10.00 12.00 3] - where - testTimestamp1 = (UTCTime (fromGregorian 1970 1 1) 60) - testTimestamp2 = (UTCTime (fromGregorian 1970 1 1) 120) - bar ts o h l c v = Bar { - barSecurity = "TEST_TICKER", - barTimestamp = ts, - barOpen = fromDouble o, - barHigh = fromDouble h, - barLow = fromDouble l, - barClose = fromDouble c, - barVolume = v } - -testTwoBarsInSameBarLastBar :: TestTree -testTwoBarsInSameBarLastBar = testCase "Two bars (smaller timeframe) - same bar: last bar is exactly at the end of the bigger tf bar" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 600) [] - let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] - let (mbar, newagg) = handleBar (bar testTimestamp1 12.00 13.00 10.00 11.00 1) agg - mbar @?= Nothing - let (mbar', newagg') = handleBar (bar testTimestamp2 12.00 15.00 11.00 12.00 2) newagg - let expectedBar = Bar "TEST_TICKER" testTimestamp2 12.00 15.00 10.00 12.00 3 - mbar' @?= Just expectedBar - (head . tail <$> bsBars <$> (M.lookup "TEST_TICKER" $ bars newagg')) @?= Just expectedBar - where - testTimestamp1 = (UTCTime (fromGregorian 1970 1 1) 560) - testTimestamp2 = (UTCTime (fromGregorian 1970 1 1) 600) - bar ts o h l c v = Bar { - barSecurity = "TEST_TICKER", - barTimestamp = ts, - barOpen = fromDouble o, - barHigh = fromDouble h, - barLow = fromDouble l, - barClose = fromDouble c, - barVolume = v } - -testNextBarAfterBarClose :: TestTree -testNextBarAfterBarClose = testCase "Three bars (smaller timeframe) - next bar after bigger tf bar close" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 600) [] - let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] - let (_, newagg) = handleBar (bar testTimestamp1 12.00 13.00 10.00 11.00 1) agg - let (_, newagg') = handleBar (bar testTimestamp2 12.00 15.00 11.00 12.00 2) newagg - let (_, newagg'') = handleBar (bar testTimestamp3 12.00 15.00 11.00 12.00 12) newagg' - let expectedBar = Bar "TEST_TICKER" testTimestamp3 12.00 15.00 11.00 12.00 12 - (head <$> bsBars <$> (M.lookup "TEST_TICKER" $ bars newagg'')) @?= Just expectedBar - where - testTimestamp1 = (UTCTime (fromGregorian 1970 1 1) 560) - testTimestamp2 = (UTCTime (fromGregorian 1970 1 1) 600) - testTimestamp3 = (UTCTime (fromGregorian 1970 1 1) 660) - bar ts o h l c v = Bar { - barSecurity = "TEST_TICKER", - barTimestamp = ts, - barOpen = fromDouble o, - barHigh = fromDouble h, - barLow = fromDouble l, - barClose = fromDouble c, - barVolume = v } - -testUpdateTime :: TestTree -testUpdateTime = testCase "updateTime - next bar - creates new bar with zero volume" $ do - let series = BarSeries "TEST_TICKER" (Timeframe 3600) [] - let agg = mkAggregatorFromBars (M.fromList [("TEST_TICKER", series)]) [(0, 86400)] - let (_, newagg) = handleBar (bar testTimestamp1 12.00 13.00 10.00 11.00 1) agg - let (_, newagg') = handleBar (bar testTimestamp2 12.00 15.00 11.00 12.00 2) newagg - let (newBar, newagg'') = updateTime (tick testTimestamp4 13.00 100) newagg' - let expectedNewBar = Bar "TEST_TICKER" testTimestamp2 12.00 15.00 10.00 12.00 3 - let expectedBar = Bar "TEST_TICKER" testTimestamp4 13.00 13.00 13.00 13.00 0 - (head <$> bsBars <$> (M.lookup "TEST_TICKER" $ bars newagg'')) @?= Just expectedBar - newBar @?= Just expectedNewBar - where - testTimestamp1 = (UTCTime (fromGregorian 1970 1 1) 560) - testTimestamp2 = (UTCTime (fromGregorian 1970 1 1) 600) - testTimestamp3 = (UTCTime (fromGregorian 1970 1 1) 3600) - testTimestamp4 = (UTCTime (fromGregorian 1970 1 1) 3660) - tick ts v vol = Tick { - security = "TEST_TICKER" - , datatype = LastTradePrice - , timestamp = ts - , value = v - , volume = vol } - bar ts o h l c v = Bar { - barSecurity = "TEST_TICKER", - barTimestamp = ts, - barOpen = fromDouble o, - barHigh = fromDouble h, - barLow = fromDouble l, - barClose = fromDouble c, - barVolume = v } prop_allTicksInOneBar :: TestTree prop_allTicksInOneBar = QC.testProperty "All ticks in one bar" $ QC.forAll (QC.choose (1, 86400)) $ \timeframe -> @@ -236,13 +119,13 @@ prop_allTicksInOneBar = QC.testProperty "All ticks in one bar" $ QC.forAll (QC.c ((barClose <$> currentBar "TEST_TICKER" agg) == (value <$> lastMay ticks')) && ((barVolume <$> currentBar "TEST_TICKER" agg) == Just (sum $ volume <$> ticks)) where - genTick :: T.Text -> UTCTime -> Integer -> Gen Tick + genTick :: T.Text -> UTCTime -> Int -> Gen Tick genTick tickerId base tf = do - difftime <- fromRational . toRational . picosecondsToDiffTime <$> choose (0, truncate 1e12 * tf) + difftime <- fromRational . toRational . picosecondsToDiffTime <$> choose (0, truncate 1e12 * fromIntegral tf) val <- arbitrary vol <- arbitrary `suchThat` (> 0) return $ Tick tickerId LastTradePrice (difftime `addUTCTime` baseTime) val vol - mkAggregator tickerId tf = mkAggregatorFromBars (M.singleton tickerId (BarSeries tickerId (Timeframe tf) [])) [(0, 86400)] + mkAggregator tickerId tf = mkAggregatorFromBars (M.singleton tickerId (BarSeries tickerId (BarTimeframe tf) [] secParams)) [(0, 86400)] currentBar tickerId agg = headMay =<< (bsBars <$> M.lookup tickerId (bars agg)) baseTime = UTCTime (fromGregorian 1970 1 1) 0 diff --git a/test/Test/Driver/Junction/QuoteThread.hs b/test/Test/Driver/Junction/QuoteThread.hs new file mode 100644 index 0000000..4413764 --- /dev/null +++ b/test/Test/Driver/Junction/QuoteThread.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Driver.Junction.QuoteThread +( + unitTests +) where + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC +import Test.Tasty.SmallCheck as SC + +import ATrade.Driver.Junction.QuoteThread (addSubscription, + startQuoteThread, + stopQuoteThread) +import ATrade.QuoteSource.Client (QuoteData (QDBar)) +import ATrade.QuoteSource.Server (QuoteSourceServerData (..), + startQuoteSourceServer, + stopQuoteSourceServer) +import ATrade.RoboCom.Types (BarSeries (bsBars), + BarSeriesId (BarSeriesId), + InstrumentParameters (InstrumentParameters)) +import ATrade.Types +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.BoundedChan (newBoundedChan, readChan, + writeChan) +import Control.Exception (bracket) +import Control.Monad (forever) +import Data.IORef (newIORef, readIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Time (UTCTime (UTCTime), + fromGregorian) +import System.IO (BufferMode (LineBuffering), + hSetBuffering, stderr) +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple +import System.Log.Logger +import System.ZMQ4 (withContext) +import Test.Mock.HistoryProvider (mkMockHistoryProvider) +import Test.Mock.TickerInfoProvider (mkMockTickerInfoProvider) + +qsEndpoint = "inproc://qs" + +mockHistoryProvider = mkMockHistoryProvider $ M.fromList [(BarSeriesId "FOO" (BarTimeframe 3600), bars)] + where + bars = [] + +mockTickerInfoProvider = mkMockTickerInfoProvider $ M.fromList [("FOO", InstrumentParameters 10 0.1)] + +unitTests = testGroup "Driver.Junction.QuoteThread" [ + testSubscription + ] + +testSubscription :: TestTree +testSubscription = testCase "Subscription" $ withContext $ \ctx -> do + barsRef <- newIORef M.empty + serverChan <- newBoundedChan 2000 + bracket + (startQuoteSourceServer serverChan ctx qsEndpoint defaultServerSecurityParams) + stopQuoteSourceServer $ \_ -> + bracket + (startQuoteThread barsRef ctx qsEndpoint Nothing Nothing mockHistoryProvider mockTickerInfoProvider) + stopQuoteThread $ \qt -> do + chan <- newBoundedChan 2000 + addSubscription qt "FOO" (BarTimeframe 3600) chan + + forkIO $ forever $ threadDelay 50000 >> writeChan serverChan (QSSBar (BarTimeframe 3600, bar)) + + clientData <- readChan chan + assertEqual "Invalid client data" clientData (QDBar (BarTimeframe 3600, bar)) + + bars <- readIORef barsRef + case M.lookup (BarSeriesId "FOO" (BarTimeframe 3600)) bars of + Just series -> assertBool "Length should be >= 1" $ (not . null . bsBars) series + Nothing -> assertFailure "Bar Series should be present" + where + bar = + Bar { + barSecurity="FOO", barTimestamp=UTCTime (fromGregorian 2021 11 20) 7200, barOpen=10, barHigh=12, barLow=9, barClose=11, barVolume=100 + } diff --git a/test/Test/Mock/HistoryProvider.hs b/test/Test/Mock/HistoryProvider.hs new file mode 100644 index 0000000..0630e9f --- /dev/null +++ b/test/Test/Mock/HistoryProvider.hs @@ -0,0 +1,25 @@ + +module Test.Mock.HistoryProvider +( + mkMockHistoryProvider +) where + +import ATrade.Quotes.HistoryProvider +import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), Bars) +import ATrade.Types (Bar (Bar, barTimestamp), + BarTimeframe (BarTimeframe), + TickerId) +import qualified Data.Map.Strict as M +import Data.Time (UTCTime) + +mkMockHistoryProvider :: M.Map BarSeriesId [Bar] -> HistoryProvider +mkMockHistoryProvider bars = HistoryProvider $ mockGetHistory bars + +mockGetHistory :: M.Map BarSeriesId [Bar] -> TickerId -> BarTimeframe -> UTCTime -> UTCTime -> IO [Bar] +mockGetHistory bars tid tf from to = + case M.lookup (BarSeriesId tid tf) bars of + Just series -> return $ filter (\bar -> (barTimestamp bar >= from) && (barTimestamp bar <= to)) series + Nothing -> return [] + + + diff --git a/test/Test/Mock/TickerInfoProvider.hs b/test/Test/Mock/TickerInfoProvider.hs new file mode 100644 index 0000000..18d79c7 --- /dev/null +++ b/test/Test/Mock/TickerInfoProvider.hs @@ -0,0 +1,17 @@ + +module Test.Mock.TickerInfoProvider +( + mkMockTickerInfoProvider +) where + +import ATrade.Quotes.TickerInfoProvider +import ATrade.RoboCom.Types (InstrumentParameters) +import ATrade.Types (TickerId) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, mapMaybe) + +mkMockTickerInfoProvider :: M.Map TickerId InstrumentParameters -> TickerInfoProvider +mkMockTickerInfoProvider params = TickerInfoProvider $ mockGetInstrumentParameters params + +mockGetInstrumentParameters :: M.Map TickerId InstrumentParameters -> [TickerId] -> IO [InstrumentParameters] +mockGetInstrumentParameters params = return . mapMaybe (`M.lookup` params) diff --git a/test/Test/RoboCom/Positions.hs b/test/Test/RoboCom/Positions.hs deleted file mode 100644 index afd4b3e..0000000 --- a/test/Test/RoboCom/Positions.hs +++ /dev/null @@ -1,167 +0,0 @@ - -{-# LANGUAGE OverloadedStrings #-} - -module Test.RoboCom.Positions -( - unitTests -) where - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC -import Test.Tasty.SmallCheck as SC - -import ATrade.Types -import qualified Data.Text as T -import qualified Data.Map.Strict as M -import Data.Time.Calendar -import Data.Time.Clock -import qualified Data.List as L - -import ATrade.RoboCom.Monad -import ATrade.RoboCom.Positions -import ATrade.RoboCom.Types - -data TestState = TestState - { - positions :: [Position], - testInt :: Int - } - -defaultState = TestState { - positions = [], - testInt = 0 - } - -data TestConfig = TestConfig - -instance ParamsHasMainTicker TestConfig where - mainTicker _ = "TEST_TICKER" - -instance StateHasPositions TestState where - getPositions = positions - setPositions a p = a { positions = p } - -defaultStrategyEnvironment = StrategyEnvironment - { - seInstanceId = "test_instance", - seAccount = "test_account", - seVolume = 1, - seBars = M.empty, - seLastTimestamp = (UTCTime (fromGregorian 1970 1 1) 0) - } - -unitTests = testGroup "RoboCom.Positions" [ - testEnterAtMarket, - testEnterAtMarketSendsAction, - testDefaultHandlerSubmissionDeadline, - testDefaultHandlerAfterSubmissionPositionIsWaitingOpen, - testDefaultHandlerPositionWaitingOpenOrderOpenExecuted1 - ] - -testEnterAtMarket = testCase "enterAtMarket creates position in PositionWaitingOpenSubmission state" $ do - let (newState, actions, _) = runStrategyElement TestConfig defaultState defaultStrategyEnvironment element - assertBool "Should be exactly 1 position" ((length . positions) newState == 1) - let pos = head . positions $ newState - assertBool "Should be in PositionWaitingOpenSubmission" (isPositionWaitingOpenSubmission . posState $ pos) - let (PositionWaitingOpenSubmission order) = posState pos - assertBool "Account should be 'test_account'" (orderAccountId order == "test_account") - assertBool "Security should be 'TEST_TICKER'" (orderSecurity order == "TEST_TICKER") - assertBool "Order price should be Market" (orderPrice order == Market) - assertBool "Order quantity should be 1" (orderQuantity order == 1) - assertBool "Executed order quantity should be 0" (orderExecutedQuantity order == 0) - assertBool "Order operation should be Buy" (orderOperation order == Buy) - assertBool "Order signal id should be correct" (orderSignalId order == (SignalId "test_instance" "long" "")) - where - element = enterAtMarket "long" Buy - - isPositionWaitingOpenSubmission (PositionWaitingOpenSubmission _) = True - isPositionWaitingOpenSubmission _ = False - -testEnterAtMarketSendsAction = testCase "enterAtMarket sends ActionSubmitOrder" $ do - let (newState, actions, _) = runStrategyElement TestConfig defaultState defaultStrategyEnvironment element - case (L.find isActionOrder actions) of - Just (ActionOrder order) -> do - assertBool "Account should be 'test_account'" (orderAccountId order == "test_account") - assertBool "Security should be 'TEST_TICKER'" (orderSecurity order == "TEST_TICKER") - assertBool "Order price should be Market" (orderPrice order == Market) - assertBool "Order quantity should be 1" (orderQuantity order == 1) - assertBool "Executed order quantity should be 0" (orderExecutedQuantity order == 0) - assertBool "Order operation should be Buy" (orderOperation order == Buy) - assertBool "Order signal id should be correct" (orderSignalId order == (SignalId "test_instance" "long" "")) - Nothing -> assertFailure "Should be exactly 1 ActionOrder" - where - element = enterAtMarket "long" Buy - - isActionOrder (ActionOrder _) = True - isActionOrder _ = False - -testDefaultHandlerSubmissionDeadline = testCase "defaultHandler after submission deadline marks position as cancelled" $ do - let (newState, actions, _) = runStrategyElement TestConfig defaultState defaultStrategyEnvironment element - let (newState', actions', _) = runStrategyElement TestConfig newState defaultStrategyEnvironment { seLastTimestamp = afterDeadline } $ defaultHandler (NewTick tick) - let pos = head . positions $ newState' - assertBool "Cancelled position" (posState pos == PositionCancelled) - where - element = enterAtMarket "long" Buy - afterDeadline = (UTCTime (fromGregorian 1970 1 1) 100) - tick = Tick { - security = "TEST_TICKER", - datatype = LastTradePrice, - timestamp = afterDeadline, - value = fromDouble 12.00, - volume = 1 } - -testDefaultHandlerAfterSubmissionPositionIsWaitingOpen = testCase "defaultHandler after successful submission sets position state as PositionWaitingOpen" $ do - let (newState, actions, _) = runStrategyElement TestConfig defaultState defaultStrategyEnvironment element - let pos = head . positions $ newState - let (PositionWaitingOpenSubmission order) = posState pos - let (newState', actions', _) = runStrategyElement TestConfig newState defaultStrategyEnvironment { seLastTimestamp = beforeDeadline } $ defaultHandler (OrderSubmitted order {orderId = 1 }) - let pos' = head . positions $ newState' - assertEqual "New position state should be PositionWaitingOpen" (posState pos') PositionWaitingOpen - where - element = enterAtMarket "long" Buy - beforeDeadline = (UTCTime (fromGregorian 1970 1 1) 1) - -testDefaultHandlerPositionWaitingOpenOrderCancelledExecuted0 = testCase "defaultHandler in PositionWaitingOpen, if order is cancelled and nothing is executed, marks position as cancelled" $ do - let (newState, actions, _) = runStrategyElement TestConfig defaultState defaultStrategyEnvironment element - let pos = head . positions $ newState - let (PositionWaitingOpenSubmission order) = posState pos - let (newState', actions', _) = runStrategyElement TestConfig newState defaultStrategyEnvironment { seLastTimestamp = ts1 } $ defaultHandler (OrderSubmitted order {orderId = 1 }) - let (newState'', actions'', _) = runStrategyElement TestConfig newState defaultStrategyEnvironment { seLastTimestamp = ts2 } $ defaultHandler (OrderUpdate 1 Cancelled) - let pos = head . positions $ newState'' - assertEqual "New position state should be PositionCancelled" (posState pos) PositionCancelled - where - element = enterAtMarket "long" Buy - ts1 = (UTCTime (fromGregorian 1970 1 1) 1) - ts2 = (UTCTime (fromGregorian 1970 1 1) 2) - -testDefaultHandlerPositionWaitingOpenOrderOpenExecuted1 = testCase "defaultHandler in PositionWaitingOpen, if order is cancelled and something is executed, marks position as open" $ do - let (newState, actions, _) = runStrategyElement TestConfig defaultState defaultStrategyEnvironment element - let pos = head . positions $ newState - let (PositionWaitingOpenSubmission order) = posState pos - let (newState', actions', _) = runStrategyElement TestConfig newState defaultStrategyEnvironment { seLastTimestamp = ts1, seVolume = 2 } $ defaultHandler (OrderSubmitted order {orderId = 1 }) - let (newState'', actions'', _) = runStrategyElement TestConfig newState' defaultStrategyEnvironment { seLastTimestamp = ts2 } $ defaultHandler (NewTrade trade) - let (newState''', actions''', _) = runStrategyElement TestConfig newState'' defaultStrategyEnvironment { seLastTimestamp = ts3 } $ defaultHandler (OrderUpdate 1 Cancelled) - let pos = head . positions $ newState''' - assertEqual "New position state should be PositionOpen" (posState pos) PositionOpen - where - element = enterAtMarket "long" Buy - ts1 = (UTCTime (fromGregorian 1970 1 1) 1) - ts2 = (UTCTime (fromGregorian 1970 1 1) 2) - ts3 = (UTCTime (fromGregorian 1970 1 1) 3) - trade = Trade - { - tradeOrderId = 1, - tradePrice = fromDouble 10, - tradeQuantity = 1, - tradeVolume = fromDouble 10, - tradeVolumeCurrency = "FOO", - tradeOperation = Buy, - tradeAccount = "test_account", - tradeSecurity = "TEST_TICKER", - tradeTimestamp = ts3, - tradeCommission = fromDouble 0, - tradeSignalId = SignalId "test_instance" "long" "" - } - - From 72c421c64f80bfbbcff97e7a989e4e74925f57a5 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 21 Nov 2021 13:44:21 +0700 Subject: [PATCH 03/25] Make HistoryProvider and TickerInfoProvider monad typeclasses --- robocom-zero.cabal | 8 +- src/ATrade/Driver/Junction/QuoteThread.hs | 99 +++++++++++------------ src/ATrade/Quotes/HistoryProvider.hs | 8 +- src/ATrade/Quotes/TickerInfoProvider.hs | 9 +-- test/Test/Driver/Junction/QuoteThread.hs | 38 ++++++++- test/Test/Mock/HistoryProvider.hs | 18 +++-- test/Test/Mock/TickerInfoProvider.hs | 15 ++-- 7 files changed, 115 insertions(+), 80 deletions(-) diff --git a/robocom-zero.cabal b/robocom-zero.cabal index da3c561..ce6842f 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -17,8 +17,10 @@ library hs-source-dirs: src ghc-options: -Wall -fno-warn-orphans -Wno-type-defaults exposed-modules: ATrade.RoboCom.Indicators + , ATrade.RoboCom.ConfigStorage , ATrade.RoboCom.Monad , ATrade.RoboCom.Positions + , ATrade.RoboCom.Persistence , ATrade.RoboCom.Types , ATrade.RoboCom.Utils , ATrade.Quotes @@ -29,9 +31,11 @@ library -- , ATrade.Driver.Backtest , ATrade.Driver.Junction , ATrade.Driver.Junction.Types + , ATrade.Driver.Junction.QuoteThread + , ATrade.Driver.Junction.QuoteStream + , ATrade.Driver.Junction.RobotDriverThread , ATrade.BarAggregator , ATrade.RoboCom - , ATrade.Driver.Junction.QuoteThread , ATrade.Quotes.HistoryProvider , ATrade.Quotes.TickerInfoProvider other-modules: Paths_robocom_zero @@ -109,7 +113,7 @@ test-suite robots-test , zeromq4-haskell , zeromq4-haskell-zap , BoundedChan - , hslogger + , mtl ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 other-modules: Test.RoboCom.Indicators diff --git a/src/ATrade/Driver/Junction/QuoteThread.hs b/src/ATrade/Driver/Junction/QuoteThread.hs index 4753f8e..9c8bac4 100644 --- a/src/ATrade/Driver/Junction/QuoteThread.hs +++ b/src/ATrade/Driver/Junction/QuoteThread.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module ATrade.Driver.Junction.QuoteThread ( @@ -9,43 +10,39 @@ module ATrade.Driver.Junction.QuoteThread addSubscription ) where -import ATrade.Quotes.HistoryProvider (HistoryProvider (..)) -import ATrade.Quotes.TickerInfoProvider (TickerInfoProvider (..)) -import ATrade.QuoteSource.Client (QuoteData (QDBar, QDTick), - QuoteSourceClientHandle, - quoteSourceClientSubscribe, - startQuoteSourceClient, - stopQuoteSourceClient) -import ATrade.RoboCom.Types (Bar (barSecurity), - BarSeries (..), - BarSeriesId (BarSeriesId), - Bars, InstrumentParameters) -import ATrade.Types (BarTimeframe (BarTimeframe), ClientSecurityParams (ClientSecurityParams), - Tick (security), TickerId) -import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Concurrent.BoundedChan (BoundedChan, newBoundedChan, - readChan, writeChan) -import Control.Monad (forever) -import Control.Monad.Reader (MonadIO (liftIO), - ReaderT (runReaderT), lift) -import Control.Monad.Reader.Class (asks) -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HM -import Data.IORef (IORef, atomicModifyIORef', - newIORef, readIORef) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Data.Time (addUTCTime, getCurrentTime) -import GHC.Generics (Generic) -import System.ZMQ4 (Context) -import System.ZMQ4.ZAP (CurveCertificate) +import ATrade.Driver.Junction.QuoteStream (QuoteSubscription (..)) +import ATrade.Quotes.HistoryProvider (HistoryProvider (..)) +import ATrade.Quotes.TickerInfoProvider (TickerInfoProvider (..)) +import ATrade.QuoteSource.Client (QuoteData (QDBar, QDTick), + QuoteSourceClientHandle, + quoteSourceClientSubscribe, + startQuoteSourceClient, + stopQuoteSourceClient) +import ATrade.RoboCom.Types (Bar (barSecurity), + BarSeries (..), + BarSeriesId (BarSeriesId), + Bars, InstrumentParameters) +import ATrade.Types (BarTimeframe (BarTimeframe), + ClientSecurityParams (ClientSecurityParams), + Tick (security), TickerId) +import Control.Concurrent (ThreadId, forkIO, + killThread) +import Control.Concurrent.BoundedChan (BoundedChan, + newBoundedChan, readChan, + writeChan) +import Control.Monad (forever) +import Control.Monad.Reader (MonadIO (liftIO), + ReaderT (runReaderT), lift) +import Control.Monad.Reader.Class (asks) +import qualified Data.HashMap.Strict as HM +import Data.IORef (IORef, atomicModifyIORef', + newIORef, readIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Time (addUTCTime, getCurrentTime) +import System.ZMQ4 (Context) +import System.ZMQ4.ZAP (CurveCertificate) -data QuoteSubscription = - QuoteSubscription TickerId BarTimeframe - deriving (Generic, Eq) - -instance Hashable BarTimeframe -instance Hashable QuoteSubscription data QuoteThreadHandle = QuoteThreadHandle ThreadId ThreadId QuoteThreadEnv @@ -56,48 +53,48 @@ data QuoteThreadEnv = endpoints :: IORef (HM.HashMap QuoteSubscription [BoundedChan QuoteData]), qsclient :: QuoteSourceClientHandle, paramsCache :: IORef (M.Map TickerId InstrumentParameters), - historyProvider :: HistoryProvider, - tickerInfoProvider :: TickerInfoProvider, downloaderChan :: BoundedChan QuoteSubscription } -startQuoteThread :: (MonadIO m) => +startQuoteThread :: (MonadIO m, + MonadIO m1, + HistoryProvider m1, + TickerInfoProvider m1) => IORef Bars -> Context -> T.Text -> Maybe CurveCertificate -> Maybe CurveCertificate -> - HistoryProvider -> - TickerInfoProvider -> + (m1 () -> IO ()) -> m QuoteThreadHandle -startQuoteThread barsRef ctx ep clientCert serverCert hp tip = do +startQuoteThread barsRef ctx ep clientCert serverCert downloadThreadRunner = do chan <- liftIO $ newBoundedChan 2000 dChan <- liftIO $ newBoundedChan 2000 qsc <- liftIO $ startQuoteSourceClient chan [] ctx ep (ClientSecurityParams clientCert serverCert) - env <- liftIO $ QuoteThreadEnv barsRef <$> newIORef HM.empty <*> pure qsc <*> newIORef M.empty <*> pure hp <*> pure tip <*> pure dChan + env <- liftIO $ QuoteThreadEnv barsRef <$> newIORef HM.empty <*> pure qsc <*> newIORef M.empty <*> pure dChan tid <- liftIO . forkIO $ quoteThread env chan - downloaderTid <- liftIO . forkIO $ downloaderThread env dChan + downloaderTid <- liftIO . forkIO $ downloadThreadRunner (downloaderThread env dChan) return $ QuoteThreadHandle tid downloaderTid env where downloaderThread env chan = forever $ do - QuoteSubscription tickerid tf <- readChan chan + QuoteSubscription tickerid tf <- liftIO $ readChan chan paramsMap <- liftIO $ readIORef $ paramsCache env mbParams <- case M.lookup tickerid paramsMap of Nothing -> do - paramsList <- liftIO $ getInstrumentParameters (tickerInfoProvider env) [tickerid] + paramsList <- getInstrumentParameters [tickerid] case paramsList of (params:_) -> liftIO $ atomicModifyIORef' (paramsCache env) (\m -> (M.insert tickerid params m, Just params)) _ -> return Nothing Just params -> return $ Just params - barsMap <- readIORef (bars env) + barsMap <- liftIO $ readIORef (bars env) case M.lookup (BarSeriesId tickerid tf) barsMap of Just _ -> return () -- already downloaded Nothing -> case mbParams of Just params -> do now <- liftIO getCurrentTime - barsData <- liftIO $ getHistory (historyProvider env) tickerid tf ((-86400 * 60) `addUTCTime` now) now + barsData <- getHistory tickerid tf ((-86400 * 60) `addUTCTime` now) now let barSeries = BarSeries tickerid tf barsData params - atomicModifyIORef' (bars env) (\m -> (M.insert (BarSeriesId tickerid tf) barSeries m, ())) + liftIO $ atomicModifyIORef' (bars env) (\m -> (M.insert (BarSeriesId tickerid tf) barSeries m, ())) _ -> return () -- TODO log diff --git a/src/ATrade/Quotes/HistoryProvider.hs b/src/ATrade/Quotes/HistoryProvider.hs index ad7a9a4..96147a1 100644 --- a/src/ATrade/Quotes/HistoryProvider.hs +++ b/src/ATrade/Quotes/HistoryProvider.hs @@ -7,8 +7,6 @@ module ATrade.Quotes.HistoryProvider import ATrade.RoboCom.Types (Bar) import ATrade.Types (BarTimeframe, TickerId) import Data.Time (UTCTime) -newtype HistoryProvider = - HistoryProvider - { - getHistory :: TickerId -> BarTimeframe -> UTCTime -> UTCTime -> IO [Bar] - } + +class (Monad m) => HistoryProvider m where + getHistory :: TickerId -> BarTimeframe -> UTCTime -> UTCTime -> m [Bar] diff --git a/src/ATrade/Quotes/TickerInfoProvider.hs b/src/ATrade/Quotes/TickerInfoProvider.hs index f66efae..c38097a 100644 --- a/src/ATrade/Quotes/TickerInfoProvider.hs +++ b/src/ATrade/Quotes/TickerInfoProvider.hs @@ -6,8 +6,7 @@ module ATrade.Quotes.TickerInfoProvider import ATrade.RoboCom.Types (InstrumentParameters) import ATrade.Types (TickerId) -newtype TickerInfoProvider = - TickerInfoProvider - { - getInstrumentParameters :: [TickerId] -> IO [InstrumentParameters] - } + +class (Monad m) => TickerInfoProvider m where + getInstrumentParameters :: [TickerId] -> m [InstrumentParameters] + diff --git a/test/Test/Driver/Junction/QuoteThread.hs b/test/Test/Driver/Junction/QuoteThread.hs index 4413764..827fffa 100644 --- a/test/Test/Driver/Junction/QuoteThread.hs +++ b/test/Test/Driver/Junction/QuoteThread.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} module Test.Driver.Junction.QuoteThread ( @@ -13,6 +16,8 @@ import Test.Tasty.SmallCheck as SC import ATrade.Driver.Junction.QuoteThread (addSubscription, startQuoteThread, stopQuoteThread) +import ATrade.Quotes.HistoryProvider (HistoryProvider (..)) +import ATrade.Quotes.TickerInfoProvider (TickerInfoProvider (..)) import ATrade.QuoteSource.Client (QuoteData (QDBar)) import ATrade.QuoteSource.Server (QuoteSourceServerData (..), startQuoteSourceServer, @@ -26,6 +31,7 @@ import Control.Concurrent.BoundedChan (newBoundedChan, readChan, writeChan) import Control.Exception (bracket) import Control.Monad (forever) +import Control.Monad.Reader import Data.IORef (newIORef, readIORef) import qualified Data.Map.Strict as M import qualified Data.Text as T @@ -38,8 +44,31 @@ import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import System.Log.Logger import System.ZMQ4 (withContext) -import Test.Mock.HistoryProvider (mkMockHistoryProvider) -import Test.Mock.TickerInfoProvider (mkMockTickerInfoProvider) +import Test.Mock.HistoryProvider (MockHistoryProvider, + mkMockHistoryProvider, + mockGetHistory) +import Test.Mock.TickerInfoProvider (MockTickerInfoProvider, + mkMockTickerInfoProvider, + mockGetInstrumentParameters) + +data TestEnv = + TestEnv + { + historyProvider :: MockHistoryProvider, + tickerInfoProvider :: MockTickerInfoProvider + } + +type TestM = ReaderT TestEnv IO + +instance HistoryProvider TestM where + getHistory tid tf from to = do + hp <- asks historyProvider + liftIO $ mockGetHistory hp tid tf from to + +instance TickerInfoProvider TestM where + getInstrumentParameters tickers = do + tip <- asks tickerInfoProvider + liftIO $ mockGetInstrumentParameters tip tickers qsEndpoint = "inproc://qs" @@ -61,7 +90,8 @@ testSubscription = testCase "Subscription" $ withContext $ \ctx -> do (startQuoteSourceServer serverChan ctx qsEndpoint defaultServerSecurityParams) stopQuoteSourceServer $ \_ -> bracket - (startQuoteThread barsRef ctx qsEndpoint Nothing Nothing mockHistoryProvider mockTickerInfoProvider) + (startQuoteThread barsRef ctx qsEndpoint Nothing Nothing (`runReaderT` (TestEnv mockHistoryProvider mockTickerInfoProvider))) + stopQuoteThread $ \qt -> do chan <- newBoundedChan 2000 addSubscription qt "FOO" (BarTimeframe 3600) chan diff --git a/test/Test/Mock/HistoryProvider.hs b/test/Test/Mock/HistoryProvider.hs index 0630e9f..3dbef67 100644 --- a/test/Test/Mock/HistoryProvider.hs +++ b/test/Test/Mock/HistoryProvider.hs @@ -1,7 +1,9 @@ module Test.Mock.HistoryProvider ( - mkMockHistoryProvider + MockHistoryProvider, + mkMockHistoryProvider, + mockGetHistory ) where import ATrade.Quotes.HistoryProvider @@ -9,17 +11,17 @@ import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), Bars) import ATrade.Types (Bar (Bar, barTimestamp), BarTimeframe (BarTimeframe), TickerId) +import Control.Monad.IO.Class (MonadIO) import qualified Data.Map.Strict as M import Data.Time (UTCTime) -mkMockHistoryProvider :: M.Map BarSeriesId [Bar] -> HistoryProvider -mkMockHistoryProvider bars = HistoryProvider $ mockGetHistory bars +data MockHistoryProvider = MockHistoryProvider (M.Map BarSeriesId [Bar]) -mockGetHistory :: M.Map BarSeriesId [Bar] -> TickerId -> BarTimeframe -> UTCTime -> UTCTime -> IO [Bar] -mockGetHistory bars tid tf from to = +mkMockHistoryProvider :: M.Map BarSeriesId [Bar] -> MockHistoryProvider +mkMockHistoryProvider = MockHistoryProvider + +mockGetHistory :: (MonadIO m) => MockHistoryProvider -> TickerId -> BarTimeframe -> UTCTime -> UTCTime -> m [Bar] +mockGetHistory (MockHistoryProvider bars) tid tf from to = case M.lookup (BarSeriesId tid tf) bars of Just series -> return $ filter (\bar -> (barTimestamp bar >= from) && (barTimestamp bar <= to)) series Nothing -> return [] - - - diff --git a/test/Test/Mock/TickerInfoProvider.hs b/test/Test/Mock/TickerInfoProvider.hs index 18d79c7..a0bc6d5 100644 --- a/test/Test/Mock/TickerInfoProvider.hs +++ b/test/Test/Mock/TickerInfoProvider.hs @@ -1,17 +1,22 @@ module Test.Mock.TickerInfoProvider ( - mkMockTickerInfoProvider + MockTickerInfoProvider, + mkMockTickerInfoProvider, + mockGetInstrumentParameters ) where import ATrade.Quotes.TickerInfoProvider import ATrade.RoboCom.Types (InstrumentParameters) import ATrade.Types (TickerId) +import Control.Monad.IO.Class (MonadIO) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, mapMaybe) -mkMockTickerInfoProvider :: M.Map TickerId InstrumentParameters -> TickerInfoProvider -mkMockTickerInfoProvider params = TickerInfoProvider $ mockGetInstrumentParameters params +data MockTickerInfoProvider = MockTickerInfoProvider (M.Map TickerId InstrumentParameters) -mockGetInstrumentParameters :: M.Map TickerId InstrumentParameters -> [TickerId] -> IO [InstrumentParameters] -mockGetInstrumentParameters params = return . mapMaybe (`M.lookup` params) +mkMockTickerInfoProvider :: (M.Map TickerId InstrumentParameters) -> MockTickerInfoProvider +mkMockTickerInfoProvider = MockTickerInfoProvider + +mockGetInstrumentParameters :: MockTickerInfoProvider -> [TickerId] -> IO [InstrumentParameters] +mockGetInstrumentParameters (MockTickerInfoProvider params) = return . mapMaybe (`M.lookup` params) From f91fb6e449e59c02a8f12f818dcf0c448e61068d Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 27 Nov 2021 11:25:38 +0700 Subject: [PATCH 04/25] WIP --- robocom-zero.cabal | 1 + src/ATrade/Driver/Junction.hs | 257 +++++++++++------- .../Driver/Junction/ProgramConfiguration.hs | 37 +++ src/ATrade/Driver/Junction/QuoteStream.hs | 27 ++ src/ATrade/Driver/Junction/QuoteThread.hs | 129 ++++++--- .../Driver/Junction/RobotDriverThread.hs | 95 +++++++ src/ATrade/Driver/Junction/Types.hs | 39 ++- src/ATrade/RoboCom/ConfigStorage.hs | 14 + src/ATrade/RoboCom/Monad.hs | 5 +- src/ATrade/RoboCom/Persistence.hs | 16 ++ src/ATrade/RoboCom/Positions.hs | 19 +- src/ATrade/RoboCom/Types.hs | 1 + stack.yaml | 2 +- 13 files changed, 479 insertions(+), 163 deletions(-) create mode 100644 src/ATrade/Driver/Junction/ProgramConfiguration.hs create mode 100644 src/ATrade/Driver/Junction/QuoteStream.hs create mode 100644 src/ATrade/Driver/Junction/RobotDriverThread.hs create mode 100644 src/ATrade/RoboCom/ConfigStorage.hs create mode 100644 src/ATrade/RoboCom/Persistence.hs diff --git a/robocom-zero.cabal b/robocom-zero.cabal index ce6842f..5ca2859 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -34,6 +34,7 @@ library , ATrade.Driver.Junction.QuoteThread , ATrade.Driver.Junction.QuoteStream , ATrade.Driver.Junction.RobotDriverThread + , ATrade.Driver.Junction.ProgramConfiguration , ATrade.BarAggregator , ATrade.RoboCom , ATrade.Quotes.HistoryProvider diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index d9758da..85f5570 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -1,125 +1,182 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} module ATrade.Driver.Junction ( junctionMain ) where -import ATrade.Driver.Junction.Types (StrategyDescriptor (..), - StrategyInstance (..), - StrategyInstanceDescriptor (..)) -import ATrade.RoboCom.Types (Ticker (..)) -import Control.Concurrent (forkIO) -import Control.Concurrent.Async (forConcurrently_) -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TQueue (newTQueueIO) -import Control.Concurrent.STM.TVar (newTVarIO) -import Data.Aeson (FromJSON (..), ToJSON (..), - decode, object, withObject, - (.:), (.=)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.IORef -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Semigroup ((<>)) -import qualified Data.Text as T -import Data.Text.IO (readFile) -import Dhall (FromDhall, auto, input) -import GHC.Generics (Generic) -import Options.Applicative (Parser, execParser, fullDesc, - header, help, helper, info, - long, metavar, progDesc, short, - strOption, (<**>)) -import Prelude hiding (readFile) - -data BigConfig c = BigConfig { - confTickers :: [Ticker], - confStrategy :: c -} - -instance (FromJSON c) => FromJSON (BigConfig c) where - parseJSON = withObject "object" (\obj -> BigConfig <$> - obj .: "tickers" <*> - obj .: "params") - -instance (ToJSON c) => ToJSON (BigConfig c) where - toJSON conf = object ["tickers" .= confTickers conf, - "params" .= confStrategy conf ] - -data ProgramOptions = - ProgramOptions +import ATrade.Broker.Client (startBrokerClient, + stopBrokerClient) +import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (brokerEndpoint, brokerNotificationEndpoint, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), + ProgramOptions (ProgramOptions, configPath)) +import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription)) +import ATrade.Driver.Junction.QuoteThread (DownloaderEnv (DownloaderEnv), + withQThread) +import ATrade.Driver.Junction.RobotDriverThread (createRobotDriverThread) +import ATrade.Driver.Junction.Types (StrategyDescriptorE (StrategyDescriptorE), + StrategyInstanceDescriptor (..), + confStrategy) +import ATrade.Quotes.QHP (mkQHPHandle) +import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) +import ATrade.RoboCom.Monad (MonadRobot (..)) +import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) +import ATrade.Types (ClientSecurityParams (ClientSecurityParams)) +import Control.Exception.Safe (MonadThrow, + bracket) +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (MonadReader, ReaderT (runReaderT), + asks) +import Data.Aeson (eitherDecode, + encode) +import qualified Data.ByteString.Lazy as BL +import Data.Default (Default (def)) +import Data.IORef (IORef, newIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Text.IO (readFile) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Redis (ConnectInfo (..), + Connection, + PortID (UnixSocket), + checkedConnect, + defaultConnectInfo, + get, mset, + runRedis) +import Dhall (auto, input) +import Options.Applicative (Parser, + execParser, + fullDesc, header, + help, helper, + info, long, + metavar, progDesc, + short, strOption, + (<**>)) +import Prelude hiding (readFile) +import System.Log.Logger (warningM) +import System.ZMQ4 (withContext) + +data PersistenceEnv = + PersistenceEnv { - configPath :: FilePath + peRedisSocket :: Connection, + peConfigPath :: FilePath } -data ProgramConfiguration = - ProgramConfiguration +newtype PersistenceT a = PersistenceT { unPersistenceT :: ReaderT PersistenceEnv IO a } + deriving (Functor, Applicative, Monad, MonadReader PersistenceEnv, MonadIO, MonadThrow) + +instance ConfigStorage PersistenceT where + loadConfig key = do + basePath <- asks peConfigPath + let path = basePath <> "/" <> T.unpack key -- TODO fix path construction + liftIO $ readFile path >>= input auto + +instance MonadPersistence PersistenceT where + saveState newState key = do + conn <- asks peRedisSocket + now <- liftIO getPOSIXTime + 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" + Right _ -> return () + + loadState key = do + conn <- asks peRedisSocket + res <- liftIO $ runRedis conn $ get (encodeUtf8 key) + -- TODO: just chain eithers + case res of + Left _ -> do + liftIO $ warningM "main" "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" + return def + Right decodedState -> return decodedState + Nothing -> do + liftIO $ warningM "main" "Unable to decode state" + return def + +instance QuoteStream PersistenceT where + addSubscription sub chan = undefined + removeSubscription sub = undefined + +data RobotEnv c s = + RobotEnv { - brokerEndpoint :: T.Text, - brokerServerCert :: Maybe FilePath, - brokerClientCert :: Maybe FilePath, - quotesourceEndpoint :: T.Text, - quotesourceServerCert :: Maybe FilePath, - quotesourceClientCert :: Maybe FilePath, - qhpEndpoint :: T.Text, - qtisEndpoint :: T.Text, - redisSocket :: T.Text, - globalLog :: FilePath, - instances :: [StrategyInstanceDescriptor] - } deriving (Generic, Show) - -instance FromDhall ProgramConfiguration - -load :: T.Text -> IO (Maybe B.ByteString) -load = undefined - -junctionMain :: M.Map T.Text StrategyDescriptor -> IO () + stateRef :: IORef s, + configRef :: IORef c + } + +newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a } + deriving (Functor, Applicative, Monad, MonadReader (RobotEnv c s), MonadIO, MonadThrow) + +instance MonadRobot (RobotM c s) c s where + submitOrder = undefined + cancelOrder = undefined + appendToLog = undefined + setupTimer = undefined + enqueueIOAction = undefined + getConfig = undefined + getState = undefined + setState = undefined + getEnvironment = undefined + getTicker = undefined + +junctionMain :: M.Map T.Text StrategyDescriptorE -> IO () junctionMain descriptors = do opts <- parseOptions cfg <- readFile (configPath opts) >>= input auto - bars <- newTVarIO M.empty - - strategies <- mkStrategies (instances cfg) - - start strategies bars - + barsMap <- newIORef M.empty + + redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) }) + withContext $ \ctx -> do + let env = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) + withBroker cfg ctx $ \bro -> + withQThread env barsMap cfg ctx $ \qt -> + withPersistence (PersistenceEnv redis $ robotsConfigsPath cfg) $ + forM_ (instances cfg) $ \inst -> + case M.lookup (strategyBaseName inst) descriptors of + Just (StrategyDescriptorE desc) -> do + bigConf <- loadConfig (configKey inst) + rConf <- liftIO $ newIORef (confStrategy bigConf) + rState <- loadState (stateKey inst) >>= liftIO . newIORef + let robotEnv = RobotEnv rState rConf + createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState + Nothing -> error "Unknown strategy" where + withPersistence :: PersistenceEnv -> PersistenceT () -> IO () + withPersistence env = (`runReaderT` env) . unPersistenceT + + withBroker cfg ctx f = bracket + (startBrokerClient + "broker" + ctx + (brokerEndpoint cfg) + (brokerNotificationEndpoint cfg) + [] + (ClientSecurityParams -- TODO load certificates from file + Nothing + Nothing)) + stopBrokerClient f parseOptions = execParser options options = info (optionsParser <**> helper) (fullDesc <> progDesc "Robocom-zero junction mode driver" <> header "robocom-zero-junction") - mkStrategies :: [StrategyInstanceDescriptor] -> IO [StrategyInstance] - mkStrategies = mapM mkStrategy - - mkStrategy :: StrategyInstanceDescriptor -> IO StrategyInstance - mkStrategy desc = do - sState <- load (stateKey desc) - sCfg <- load (configKey desc) - case M.lookup (strategyId desc) descriptors of - Just (StrategyDescriptor _sName sCallback sDefState) -> - case (sCfg >>= decode . BL.fromStrict, fromMaybe sDefState (sState >>= decode . BL.fromStrict)) of - (Just bigConfig, pState) -> do - cfgRef <- newIORef (confStrategy bigConfig) - stateRef <- newIORef pState - return $ StrategyInstance - { - strategyInstanceId = strategyName desc, - strategyEventCallback = sCallback, - strategyState = stateRef, - strategyConfig = cfgRef - } - _ -> error "Can't read state and config" - _ -> error $ "Can't find strategy: " ++ T.unpack (strategyId desc) - - start strategies bars = undefined - optionsParser :: Parser ProgramOptions optionsParser = ProgramOptions <$> strOption diff --git a/src/ATrade/Driver/Junction/ProgramConfiguration.hs b/src/ATrade/Driver/Junction/ProgramConfiguration.hs new file mode 100644 index 0000000..ec36c1b --- /dev/null +++ b/src/ATrade/Driver/Junction/ProgramConfiguration.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ATrade.Driver.Junction.ProgramConfiguration + ( + ProgramOptions(..), + ProgramConfiguration(..) + ) where +import ATrade.Driver.Junction.Types (StrategyInstanceDescriptor) +import qualified Data.Text as T +import Dhall (FromDhall) +import GHC.Generics (Generic) + +newtype ProgramOptions = + ProgramOptions + { + configPath :: FilePath + } + +data ProgramConfiguration = + ProgramConfiguration + { + brokerEndpoint :: T.Text, + brokerNotificationEndpoint :: T.Text, + brokerServerCert :: Maybe FilePath, + brokerClientCert :: Maybe FilePath, + quotesourceEndpoint :: T.Text, + quotesourceServerCert :: Maybe FilePath, + quotesourceClientCert :: Maybe FilePath, + qhpEndpoint :: T.Text, + qtisEndpoint :: T.Text, + redisSocket :: T.Text, + robotsConfigsPath :: FilePath, + globalLog :: FilePath, + instances :: [StrategyInstanceDescriptor] + } deriving (Generic, Show) + +instance FromDhall ProgramConfiguration diff --git a/src/ATrade/Driver/Junction/QuoteStream.hs b/src/ATrade/Driver/Junction/QuoteStream.hs new file mode 100644 index 0000000..d391147 --- /dev/null +++ b/src/ATrade/Driver/Junction/QuoteStream.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ATrade.Driver.Junction.QuoteStream + ( + QuoteSubscription(..), + QuoteStream(..), + SubscriptionId(..) + ) where + +import ATrade.QuoteSource.Client (QuoteData) +import ATrade.Types (BarTimeframe, TickerId) +import Control.Concurrent.BoundedChan (BoundedChan) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + +data QuoteSubscription = + QuoteSubscription TickerId BarTimeframe + deriving (Generic, Eq) + +instance Hashable BarTimeframe +instance Hashable QuoteSubscription + +newtype SubscriptionId = SubscriptionId { unSubscriptionId :: Int } + +class (Monad m) => QuoteStream m where + addSubscription :: QuoteSubscription -> BoundedChan QuoteData -> m SubscriptionId + removeSubscription :: SubscriptionId -> m () diff --git a/src/ATrade/Driver/Junction/QuoteThread.hs b/src/ATrade/Driver/Junction/QuoteThread.hs index 9c8bac4..d9261df 100644 --- a/src/ATrade/Driver/Junction/QuoteThread.hs +++ b/src/ATrade/Driver/Junction/QuoteThread.hs @@ -1,47 +1,64 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module ATrade.Driver.Junction.QuoteThread ( QuoteThreadHandle, startQuoteThread, stopQuoteThread, - addSubscription + addSubscription, + DownloaderM, + DownloaderEnv(..), + runDownloaderM, + withQThread ) where -import ATrade.Driver.Junction.QuoteStream (QuoteSubscription (..)) -import ATrade.Quotes.HistoryProvider (HistoryProvider (..)) -import ATrade.Quotes.TickerInfoProvider (TickerInfoProvider (..)) -import ATrade.QuoteSource.Client (QuoteData (QDBar, QDTick), - QuoteSourceClientHandle, - quoteSourceClientSubscribe, - startQuoteSourceClient, - stopQuoteSourceClient) -import ATrade.RoboCom.Types (Bar (barSecurity), - BarSeries (..), - BarSeriesId (BarSeriesId), - Bars, InstrumentParameters) -import ATrade.Types (BarTimeframe (BarTimeframe), - ClientSecurityParams (ClientSecurityParams), - Tick (security), TickerId) -import Control.Concurrent (ThreadId, forkIO, - killThread) -import Control.Concurrent.BoundedChan (BoundedChan, - newBoundedChan, readChan, - writeChan) -import Control.Monad (forever) -import Control.Monad.Reader (MonadIO (liftIO), - ReaderT (runReaderT), lift) -import Control.Monad.Reader.Class (asks) -import qualified Data.HashMap.Strict as HM -import Data.IORef (IORef, atomicModifyIORef', - newIORef, readIORef) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import Data.Time (addUTCTime, getCurrentTime) -import System.ZMQ4 (Context) -import System.ZMQ4.ZAP (CurveCertificate) +import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (..)) +import ATrade.Driver.Junction.QuoteStream (QuoteSubscription (..)) +import ATrade.Quotes.HistoryProvider (HistoryProvider (..)) +import ATrade.Quotes.QHP (QHPHandle, requestHistoryFromQHP) +import ATrade.Quotes.QTIS (TickerInfo (tiLotSize, tiTickSize, tiTicker), + qtisGetTickersInfo) +import ATrade.Quotes.TickerInfoProvider (TickerInfoProvider (..)) +import ATrade.QuoteSource.Client (QuoteData (QDBar, QDTick), + QuoteSourceClientHandle, + quoteSourceClientSubscribe, + startQuoteSourceClient, + stopQuoteSourceClient) +import ATrade.RoboCom.Types (Bar (barSecurity), + BarSeries (..), + BarSeriesId (BarSeriesId), + Bars, + InstrumentParameters (InstrumentParameters)) +import ATrade.Types (BarTimeframe (BarTimeframe), + ClientSecurityParams (ClientSecurityParams), + Tick (security), + TickerId) +import Control.Concurrent (ThreadId, forkIO, + killThread) +import Control.Concurrent.BoundedChan (BoundedChan, + newBoundedChan, + readChan, + writeChan) +import Control.Exception.Safe (MonadThrow, + bracket) +import Control.Monad (forM, forever) +import Control.Monad.Reader (MonadIO (liftIO), ReaderT (runReaderT), + lift) +import Control.Monad.Reader.Class (MonadReader, asks) +import qualified Data.HashMap.Strict as HM +import Data.IORef (IORef, + atomicModifyIORef', + newIORef, + readIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Time (addUTCTime, + getCurrentTime) +import System.ZMQ4 (Context) +import System.ZMQ4.ZAP (CurveCertificate) data QuoteThreadHandle = QuoteThreadHandle ThreadId ThreadId QuoteThreadEnv @@ -140,5 +157,45 @@ updateBarsMap barsMap bar tf = M.adjust (addToSeries bar) (BarSeriesId (barSecur addToSeries :: Bar -> BarSeries -> BarSeries addToSeries bar series = series { bsBars = bar : bsBars series } +data DownloaderEnv = + DownloaderEnv + { + qhp :: QHPHandle, + downloaderContext :: Context, + downloaderQtisEndpoint :: T.Text + } + +newtype DownloaderM a = DownloaderM { unDownloaderM :: ReaderT DownloaderEnv IO a } + deriving (Functor, Applicative, Monad, MonadReader DownloaderEnv, MonadIO, MonadThrow) + +instance HistoryProvider DownloaderM where + getHistory tid tf from to = do + q <- asks qhp + requestHistoryFromQHP q tid tf from to + +instance TickerInfoProvider DownloaderM where + getInstrumentParameters tickers = do + ctx <- asks downloaderContext + ep <- asks downloaderQtisEndpoint + tis <- liftIO $ forM tickers (qtisGetTickersInfo ctx ep) + pure $ convert `fmap` tis + where + convert ti = InstrumentParameters + (tiTicker ti) + (fromInteger $ tiLotSize ti) + (tiTickSize ti) +withQThread :: DownloaderEnv -> IORef Bars -> ProgramConfiguration -> Context -> (QuoteThreadHandle -> IO ()) -> IO () +withQThread env barsMap cfg ctx = + bracket + (startQuoteThread + barsMap + ctx + (quotesourceEndpoint cfg) + Nothing + Nothing + (runDownloaderM env)) + stopQuoteThread +runDownloaderM :: DownloaderEnv -> DownloaderM () -> IO () +runDownloaderM env = (`runReaderT` env) . unDownloaderM diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs new file mode 100644 index 0000000..7a46b4d --- /dev/null +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} + +module ATrade.Driver.Junction.RobotDriverThread + ( + createRobotDriverThread + ) where + +import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), + QuoteSubscription (QuoteSubscription)) +import ATrade.Driver.Junction.Types (BigConfig, + StrategyDescriptor, + StrategyInstance (StrategyInstance, strategyEventCallback), + StrategyInstanceDescriptor (configKey), + confStrategy, confTickers, + eventCallback, stateKey, + strategyId, tickerId, + timeframe) +import ATrade.QuoteSource.Client (QuoteData (..)) +import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) +import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderUpdate), + EventCallback, MonadRobot) +import ATrade.RoboCom.Persistence (MonadPersistence (loadState)) +import ATrade.Types (OrderId, OrderState, Trade) +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.BoundedChan (BoundedChan, + newBoundedChan, readChan, + writeChan) +import Control.Monad (forM_, forever) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson (FromJSON, ToJSON) +import Data.IORef (IORef, newIORef) +import Dhall (FromDhall) + +data RobotDriverHandle = forall c s. RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) + +data RobotDriverRequest + +data RobotDriverEvent = + EventRequest RobotDriverRequest + | QuoteEvent QuoteData + | NewTradeEvent Trade + | OrderEvent OrderId OrderState + + +robotDriverThread :: (MonadIO m, + MonadRobot m c s) => + StrategyInstance c s -> + BoundedChan RobotDriverEvent -> + m () + +robotDriverThread inst eventQueue = + forever $ liftIO (readChan eventQueue) >>= handleEvent + where + handleEvent (EventRequest _) = return () + handleEvent (QuoteEvent d) = + case d of + QDTick tick -> strategyEventCallback inst (NewTick tick) + QDBar (tf, bar) -> strategyEventCallback inst (NewBar (tf, bar)) + handleEvent (NewTradeEvent trade) = strategyEventCallback inst (NewTrade trade) + handleEvent (OrderEvent oid newState) = strategyEventCallback inst (OrderUpdate oid newState) + +createRobotDriverThread :: (MonadIO m1, + ConfigStorage m1, + MonadPersistence m1, + QuoteStream m1, + FromJSON s, + ToJSON s, + FromDhall c, + MonadIO m, + MonadRobot m c s) => + StrategyInstanceDescriptor + -> StrategyDescriptor c s + -> (m () -> IO ()) + -> BigConfig c + -> IORef c + -> IORef s + -> m1 RobotDriverHandle + +createRobotDriverThread instDesc strDesc runner bigConf rConf rState = do + eventQueue <- liftIO $ newBoundedChan 2000 + + let inst = StrategyInstance (strategyId instDesc) (eventCallback strDesc) rState rConf + + quoteQueue <- liftIO $ newBoundedChan 2000 + forM_ (confTickers bigConf) (\x -> addSubscription (QuoteSubscription (tickerId x) (timeframe x)) quoteQueue) + qthread <- liftIO . forkIO $ forever $ passQuoteEvents eventQueue quoteQueue + + driver <- liftIO . forkIO $ runner $ robotDriverThread inst eventQueue + return $ RobotDriverHandle inst driver qthread eventQueue + + where + passQuoteEvents eventQueue quoteQueue = do + v <- readChan quoteQueue + writeChan eventQueue (QuoteEvent v) diff --git a/src/ATrade/Driver/Junction/Types.hs b/src/ATrade/Driver/Junction/Types.hs index bc23b80..3590cd1 100644 --- a/src/ATrade/Driver/Junction/Types.hs +++ b/src/ATrade/Driver/Junction/Types.hs @@ -8,19 +8,20 @@ module ATrade.Driver.Junction.Types StrategyDescriptor(..), TickerConfig(..), StrategyInstanceDescriptor(..), - StrategyInstance(..) - ) where + StrategyInstance(..), + BigConfig(..) + ,StrategyDescriptorE(..)) where import ATrade.RoboCom.Monad (EventCallback) -import ATrade.Types (BarTimeframe, TickerId) +import ATrade.Types (BarTimeframe (..), TickerId) import Data.Aeson (FromJSON (..), ToJSON (..)) -import Data.IORef +import Data.Default (Default) +import Data.IORef (IORef) import qualified Data.Text as T import Dhall (FromDhall) import GHC.Generics (Generic) -data StrategyDescriptor = - forall c s. (FromJSON s, ToJSON s, FromJSON c) => +data StrategyDescriptor c s = StrategyDescriptor { baseStrategyName :: T.Text, @@ -28,27 +29,39 @@ data StrategyDescriptor = defaultState :: s } +data StrategyDescriptorE = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => StrategyDescriptorE (StrategyDescriptor c s) + data TickerConfig = TickerConfig { tickerId :: TickerId, timeframe :: BarTimeframe } + deriving (Generic) + +instance FromDhall BarTimeframe +instance FromDhall TickerConfig + +data BigConfig c = BigConfig { + confTickers :: [TickerConfig], + confStrategy :: c +} deriving (Generic) + +instance (FromDhall c) => FromDhall (BigConfig c) data StrategyInstanceDescriptor = StrategyInstanceDescriptor { - strategyId :: T.Text, - strategyName :: T.Text, - configKey :: T.Text, - stateKey :: T.Text, - logPath :: T.Text + strategyId :: T.Text, + strategyBaseName :: T.Text, + configKey :: T.Text, + stateKey :: T.Text, + logPath :: T.Text } deriving (Generic, Show) instance FromDhall StrategyInstanceDescriptor -data StrategyInstance = - forall c s. (FromJSON s, ToJSON s, FromJSON c) => +data StrategyInstance c s = StrategyInstance { strategyInstanceId :: T.Text, diff --git a/src/ATrade/RoboCom/ConfigStorage.hs b/src/ATrade/RoboCom/ConfigStorage.hs new file mode 100644 index 0000000..4a18ef8 --- /dev/null +++ b/src/ATrade/RoboCom/ConfigStorage.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE RankNTypes #-} + +module ATrade.RoboCom.ConfigStorage +( + ConfigStorage(..) +) where + +import qualified Data.Text as T +import Dhall (FromDhall) + +class (Monad m) => ConfigStorage m where + loadConfig :: forall c. (FromDhall c) => T.Text -> m c + + diff --git a/src/ATrade/RoboCom/Monad.hs b/src/ATrade/RoboCom/Monad.hs index b9cd3be..f043279 100644 --- a/src/ATrade/RoboCom/Monad.hs +++ b/src/ATrade/RoboCom/Monad.hs @@ -13,7 +13,6 @@ module ATrade.RoboCom.Monad ( seInstanceId, seAccount, seVolume, - seBars, seLastTimestamp, EventCallback, Event(..), @@ -48,13 +47,14 @@ class (Monad m) => MonadRobot m c s | m -> c, m -> s where oldState <- getState setState (f oldState) getEnvironment :: m StrategyEnvironment + getTicker :: TickerId -> BarTimeframe -> m (Maybe BarSeries) st :: QuasiQuoter st = t type EventCallback c s = forall m . MonadRobot m c s => Event -> m () -data Event = NewBar Bar +data Event = NewBar (BarTimeframe, Bar) | NewTick Tick | OrderSubmitted Order | OrderUpdate OrderId OrderState @@ -68,7 +68,6 @@ data StrategyEnvironment = StrategyEnvironment { _seInstanceId :: !T.Text, -- ^ Strategy instance identifier. Should be unique among all strategies (very desirable) _seAccount :: !T.Text, -- ^ Account string to use for this strategy instance. Broker-dependent _seVolume :: !Int, -- ^ Volume to use for this instance (in lots/contracts) - _seBars :: !Bars, -- ^ List of tickers which is used by this strategy _seLastTimestamp :: !UTCTime } deriving (Eq) makeLenses ''StrategyEnvironment diff --git a/src/ATrade/RoboCom/Persistence.hs b/src/ATrade/RoboCom/Persistence.hs new file mode 100644 index 0000000..602a1fc --- /dev/null +++ b/src/ATrade/RoboCom/Persistence.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE RankNTypes #-} + +module ATrade.RoboCom.Persistence +( + MonadPersistence(..) +) where + +import Data.Aeson +import Data.Default (Default) +import qualified Data.Text as T + +class (Monad m) => MonadPersistence m where + saveState :: forall s. (ToJSON s) => s -> T.Text -> m () + loadState :: forall s. (Default s, FromJSON s) => T.Text -> m s + + diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index d4e74d6..4fa2443 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -79,7 +79,6 @@ import Control.Monad import Data.Aeson import qualified Data.List as L -import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time.Clock @@ -145,7 +144,7 @@ modifyPositions f = do modifyState (\s -> setPositions s (f pos)) class ParamsHasMainTicker a where - mainTicker :: a -> BarSeriesId + mainTicker :: a -> (BarTimeframe, TickerId) -- | Helper function. Finds first element in list which satisfies predicate 'p' and if found, applies 'm' to it, leaving other elements intact. findAndModify :: (a -> Bool) -> (a -> a) -> [a] -> [a] @@ -388,16 +387,16 @@ modifyPosition f oldpos = do getCurrentTicker :: (ParamsHasMainTicker c, MonadRobot m c s) => m [Bar] getCurrentTicker = do - mainTicker' <- mainTicker <$> getConfig - maybeBars <- view (seBars . at mainTicker') <$> getEnvironment + (tf, mainTicker') <- mainTicker <$> getConfig + maybeBars <- getTicker mainTicker' tf case maybeBars of Just b -> return $ bsBars b _ -> return [] getCurrentTickerSeries :: (ParamsHasMainTicker c, MonadRobot m c s) => m (Maybe BarSeries) getCurrentTickerSeries = do - bars <- view seBars <$> getEnvironment - flip M.lookup bars . mainTicker <$> getConfig + (tf, mainTicker') <- mainTicker <$> getConfig + getTicker mainTicker' tf getLastActivePosition :: (StateHasPositions s, MonadRobot m c s) => m (Maybe Position) getLastActivePosition = L.find (\pos -> posState pos == PositionOpen) . getPositions <$> getState @@ -418,8 +417,8 @@ getAllActiveAndPendingPositions = L.filter onNewBarEvent :: (MonadRobot m c s) => Event -> (Bar -> m ()) -> m () onNewBarEvent event f = case event of - NewBar bar -> f bar - _ -> doNothing + NewBar (_, bar) -> f bar + _ -> doNothing onNewTickEvent :: (MonadRobot m c s) => Event -> (Tick -> m ()) -> m () onNewTickEvent event f = case event of @@ -464,7 +463,7 @@ enterAtMarket operationSignalName operation = do enterAtMarketWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position enterAtMarketWithParams account quantity signalId operation = do - tickerId <- bsidTickerId . mainTicker <$> getConfig + tickerId <- snd . mainTicker <$> getConfig submitOrder $ order tickerId newPosition (order tickerId) account tickerId operation quantity 20 where @@ -490,7 +489,7 @@ enterAtLimitWithVolume timeToCancel operationSignalName price vol operation = do enterAtLimitWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position enterAtLimitWithParams timeToCancel account quantity signalId price operation = do - tickerId <- bsidTickerId . mainTicker <$> getConfig + tickerId <- snd . mainTicker <$> getConfig enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation enterAtLimitForTickerWithVolume :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position diff --git a/src/ATrade/RoboCom/Types.hs b/src/ATrade/RoboCom/Types.hs index e5b8878..136ebcf 100644 --- a/src/ATrade/RoboCom/Types.hs +++ b/src/ATrade/RoboCom/Types.hs @@ -26,6 +26,7 @@ import GHC.Generics (Generic) data InstrumentParameters = InstrumentParameters { + ipTickerId :: TickerId, ipLotSize :: Int, ipTickSize :: Price } deriving (Show, Eq) diff --git a/stack.yaml b/stack.yaml index ae397ab..2011e3d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-17.14 +resolver: lts-18.18 # User packages to be built. # Various formats can be used as shown in the example below. From d8c5ea63a0567ff8a596069a456172a54c552553 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 27 Nov 2021 23:29:04 +0700 Subject: [PATCH 05/25] Refactoring --- src/ATrade/Driver/Junction.hs | 84 +++++++++---------- .../Driver/Junction/RobotDriverThread.hs | 57 +++++++++++-- 2 files changed, 92 insertions(+), 49 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index 85f5570..ed468bc 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -10,25 +10,32 @@ module ATrade.Driver.Junction junctionMain ) where -import ATrade.Broker.Client (startBrokerClient, +import ATrade.Broker.Client (BrokerClientHandle, + startBrokerClient, stopBrokerClient) import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (brokerEndpoint, brokerNotificationEndpoint, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), ProgramOptions (ProgramOptions, configPath)) -import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription)) +import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription), + QuoteSubscription (QuoteSubscription), + SubscriptionId (SubscriptionId)) import ATrade.Driver.Junction.QuoteThread (DownloaderEnv (DownloaderEnv), + QuoteThreadHandle, withQThread) -import ATrade.Driver.Junction.RobotDriverThread (createRobotDriverThread) +import qualified ATrade.Driver.Junction.QuoteThread as QT +import ATrade.Driver.Junction.RobotDriverThread (RobotEnv (..), + RobotM (..), + createRobotDriverThread) import ATrade.Driver.Junction.Types (StrategyDescriptorE (StrategyDescriptorE), StrategyInstanceDescriptor (..), confStrategy) import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) -import ATrade.RoboCom.Monad (MonadRobot (..)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) import ATrade.Types (ClientSecurityParams (ClientSecurityParams)) import Control.Exception.Safe (MonadThrow, bracket) import Control.Monad (forM_) +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (MonadReader, ReaderT (runReaderT), asks) @@ -36,7 +43,7 @@ import Data.Aeson (eitherDecode, encode) import qualified Data.ByteString.Lazy as BL import Data.Default (Default (def)) -import Data.IORef (IORef, newIORef) +import Data.IORef (newIORef) import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -62,23 +69,25 @@ import Prelude hiding (readFile) import System.Log.Logger (warningM) import System.ZMQ4 (withContext) -data PersistenceEnv = - PersistenceEnv +data JunctionEnv = + JunctionEnv { peRedisSocket :: Connection, - peConfigPath :: FilePath + peConfigPath :: FilePath, + peQuoteThread :: QuoteThreadHandle, + peBroker :: BrokerClientHandle } -newtype PersistenceT a = PersistenceT { unPersistenceT :: ReaderT PersistenceEnv IO a } - deriving (Functor, Applicative, Monad, MonadReader PersistenceEnv, MonadIO, MonadThrow) +newtype JunctionM a = JunctionM { unJunctionM :: ReaderT JunctionEnv IO a } + deriving (Functor, Applicative, Monad, MonadReader JunctionEnv, MonadIO, MonadThrow) -instance ConfigStorage PersistenceT where +instance ConfigStorage JunctionM where loadConfig key = do basePath <- asks peConfigPath let path = basePath <> "/" <> T.unpack key -- TODO fix path construction liftIO $ readFile path >>= input auto -instance MonadPersistence PersistenceT where +instance MonadPersistence JunctionM where saveState newState key = do conn <- asks peRedisSocket now <- liftIO getPOSIXTime @@ -107,31 +116,12 @@ instance MonadPersistence PersistenceT where liftIO $ warningM "main" "Unable to decode state" return def -instance QuoteStream PersistenceT where - addSubscription sub chan = undefined - removeSubscription sub = undefined - -data RobotEnv c s = - RobotEnv - { - stateRef :: IORef s, - configRef :: IORef c - } - -newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a } - deriving (Functor, Applicative, Monad, MonadReader (RobotEnv c s), MonadIO, MonadThrow) - -instance MonadRobot (RobotM c s) c s where - submitOrder = undefined - cancelOrder = undefined - appendToLog = undefined - setupTimer = undefined - enqueueIOAction = undefined - getConfig = undefined - getState = undefined - setState = undefined - getEnvironment = undefined - getTicker = undefined +instance QuoteStream JunctionM where + addSubscription (QuoteSubscription ticker timeframe) chan = do + qt <- asks peQuoteThread + QT.addSubscription qt ticker timeframe chan + return (SubscriptionId 0) -- TODO subscription Ids + removeSubscription _ = undefined junctionMain :: M.Map T.Text StrategyDescriptorE -> IO () junctionMain descriptors = do @@ -143,22 +133,30 @@ junctionMain descriptors = do redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) }) withContext $ \ctx -> do - let env = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) + let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) withBroker cfg ctx $ \bro -> - withQThread env barsMap cfg ctx $ \qt -> - withPersistence (PersistenceEnv redis $ robotsConfigsPath cfg) $ + withQThread downloaderEnv barsMap cfg ctx $ \qt -> do + let env = + JunctionEnv + { + peRedisSocket = redis, + peConfigPath = robotsConfigsPath cfg, + peQuoteThread = qt, + peBroker = bro + } + withJunction env $ forM_ (instances cfg) $ \inst -> case M.lookup (strategyBaseName inst) descriptors of Just (StrategyDescriptorE desc) -> do bigConf <- loadConfig (configKey inst) rConf <- liftIO $ newIORef (confStrategy bigConf) rState <- loadState (stateKey inst) >>= liftIO . newIORef - let robotEnv = RobotEnv rState rConf + let robotEnv = RobotEnv rState rConf bro barsMap createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState Nothing -> error "Unknown strategy" where - withPersistence :: PersistenceEnv -> PersistenceT () -> IO () - withPersistence env = (`runReaderT` env) . unPersistenceT + withJunction :: JunctionEnv -> JunctionM () -> IO () + withJunction env = (`runReaderT` env) . unJunctionM withBroker cfg ctx f = bracket (startBrokerClient diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index 7a46b4d..4a55568 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -1,11 +1,18 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module ATrade.Driver.Junction.RobotDriverThread ( - createRobotDriverThread + createRobotDriverThread, + RobotEnv(..), + RobotM(..) ) where +import ATrade.Broker.Client (BrokerClientHandle (submitOrder)) +import qualified ATrade.Broker.Client as Bro import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), QuoteSubscription (QuoteSubscription)) import ATrade.Driver.Junction.Types (BigConfig, @@ -19,17 +26,23 @@ import ATrade.Driver.Junction.Types (BigConfig, import ATrade.QuoteSource.Client (QuoteData (..)) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderUpdate), - EventCallback, MonadRobot) + MonadRobot (..)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState)) +import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), + Bars) import ATrade.Types (OrderId, OrderState, Trade) import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.BoundedChan (BoundedChan, newBoundedChan, readChan, writeChan) -import Control.Monad (forM_, forever) +import Control.Exception.Safe (MonadThrow) +import Control.Monad (forM_, forever, void) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, ReaderT, asks) import Data.Aeson (FromJSON, ToJSON) -import Data.IORef (IORef, newIORef) +import Data.IORef (IORef, readIORef, + writeIORef) +import qualified Data.Map.Strict as M import Dhall (FromDhall) data RobotDriverHandle = forall c s. RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) @@ -93,3 +106,35 @@ createRobotDriverThread instDesc strDesc runner bigConf rConf rState = do passQuoteEvents eventQueue quoteQueue = do v <- readChan quoteQueue writeChan eventQueue (QuoteEvent v) + +data RobotEnv c s = + RobotEnv + { + stateRef :: IORef s, + configRef :: IORef c, + broker :: BrokerClientHandle, + bars :: IORef Bars + } + +newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a } + deriving (Functor, Applicative, Monad, MonadReader (RobotEnv c s), MonadIO, MonadThrow) + +instance MonadRobot (RobotM c s) c s where + submitOrder order = do + bro <- asks broker + liftIO $ void $ Bro.submitOrder bro order + + cancelOrder oid = do + bro <- asks broker + liftIO $ void $ Bro.cancelOrder bro oid + + appendToLog = undefined + setupTimer = undefined + enqueueIOAction = undefined + getConfig = asks configRef >>= liftIO . readIORef + getState = asks stateRef >>= liftIO . readIORef + setState newState = asks stateRef >>= liftIO . flip writeIORef newState + getEnvironment = undefined + getTicker tid tf = do + b <- asks bars >>= liftIO . readIORef + return $ M.lookup (BarSeriesId tid tf) b From 9c8a95e55775f43bf7b3ed0eefe02a4a24db94ec Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 27 Nov 2021 23:35:18 +0700 Subject: [PATCH 06/25] Junction: MonadRobot: appendToLog implementation --- src/ATrade/Driver/Junction/RobotDriverThread.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index 4a55568..7266b79 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -43,7 +43,9 @@ import Data.Aeson (FromJSON, ToJSON) import Data.IORef (IORef, readIORef, writeIORef) import qualified Data.Map.Strict as M +import qualified Data.Text.Lazy as TL import Dhall (FromDhall) +import System.Log.Logger (infoM) data RobotDriverHandle = forall c s. RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) @@ -128,7 +130,8 @@ instance MonadRobot (RobotM c s) c s where bro <- asks broker liftIO $ void $ Bro.cancelOrder bro oid - appendToLog = undefined + appendToLog = liftIO . infoM "Robot" . TL.unpack + setupTimer = undefined enqueueIOAction = undefined getConfig = asks configRef >>= liftIO . readIORef From 19893d77dfd788991f3b1e2f9bbe2e120dfa9c71 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 28 Nov 2021 08:40:28 +0700 Subject: [PATCH 07/25] junction: StrategyDescriptor: cleanup --- src/ATrade/Driver/Junction/Types.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/ATrade/Driver/Junction/Types.hs b/src/ATrade/Driver/Junction/Types.hs index 3590cd1..602ad4d 100644 --- a/src/ATrade/Driver/Junction/Types.hs +++ b/src/ATrade/Driver/Junction/Types.hs @@ -25,8 +25,7 @@ data StrategyDescriptor c s = StrategyDescriptor { baseStrategyName :: T.Text, - eventCallback :: EventCallback c s, - defaultState :: s + eventCallback :: EventCallback c s } data StrategyDescriptorE = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => StrategyDescriptorE (StrategyDescriptor c s) From ca2927106c7f0f4e96104bcc5c11288b8fce4475 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 28 Nov 2021 08:40:54 +0700 Subject: [PATCH 08/25] junction: setupTimer implementation --- src/ATrade/Driver/Junction.hs | 3 ++- src/ATrade/Driver/Junction/RobotDriverThread.hs | 11 ++++++++--- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index ed468bc..a1573ca 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -151,7 +151,8 @@ junctionMain descriptors = do bigConf <- loadConfig (configKey inst) rConf <- liftIO $ newIORef (confStrategy bigConf) rState <- loadState (stateKey inst) >>= liftIO . newIORef - let robotEnv = RobotEnv rState rConf bro barsMap + rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef + let robotEnv = RobotEnv rState rConf rTimers bro barsMap createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState Nothing -> error "Unknown strategy" where diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index 7266b79..bf53bd2 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -40,10 +40,11 @@ import Control.Monad (forM_, forever, void) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ReaderT, asks) import Data.Aeson (FromJSON, ToJSON) -import Data.IORef (IORef, readIORef, - writeIORef) +import Data.IORef (IORef, atomicModifyIORef', + readIORef, writeIORef) 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) @@ -114,6 +115,7 @@ data RobotEnv c s = { stateRef :: IORef s, configRef :: IORef c, + timersRef :: IORef [UTCTime], broker :: BrokerClientHandle, bars :: IORef Bars } @@ -132,7 +134,10 @@ instance MonadRobot (RobotM c s) c s where appendToLog = liftIO . infoM "Robot" . TL.unpack - setupTimer = undefined + setupTimer t = do + ref <- asks timersRef + liftIO $ atomicModifyIORef' ref (\s -> (t : s, ())) + enqueueIOAction = undefined getConfig = asks configRef >>= liftIO . readIORef getState = asks stateRef >>= liftIO . readIORef From 517fb4d4d391e1822756e8b21ebb38d96ecf3121 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 28 Nov 2021 09:38:25 +0700 Subject: [PATCH 09/25] junction: save periodically robots state --- src/ATrade/Driver/Junction.hs | 67 +++++++++++++------ .../Driver/Junction/RobotDriverThread.hs | 18 +++-- src/ATrade/Driver/Junction/Types.hs | 8 ++- 3 files changed, 67 insertions(+), 26 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index a1573ca..0cd0f94 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -22,20 +23,24 @@ import ATrade.Driver.Junction.QuoteThread (DownloaderEnv (Dow QuoteThreadHandle, withQThread) import qualified ATrade.Driver.Junction.QuoteThread as QT -import ATrade.Driver.Junction.RobotDriverThread (RobotEnv (..), +import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, + RobotEnv (..), RobotM (..), - createRobotDriverThread) + createRobotDriverThread, + onStrategyInstance) import ATrade.Driver.Junction.Types (StrategyDescriptorE (StrategyDescriptorE), + StrategyInstance (strategyInstanceId), StrategyInstanceDescriptor (..), - confStrategy) + confStrategy, + strategyState) import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) import ATrade.Types (ClientSecurityParams (ClientSecurityParams)) +import Control.Concurrent import Control.Exception.Safe (MonadThrow, bracket) -import Control.Monad (forM_) -import Control.Monad (void) +import Control.Monad (forM_, forever) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (MonadReader, ReaderT (runReaderT), asks) @@ -43,7 +48,11 @@ import Data.Aeson (eitherDecode, encode) import qualified Data.ByteString.Lazy as BL import Data.Default (Default (def)) -import Data.IORef (newIORef) +import Data.Foldable (traverse_) +import Data.IORef (IORef, + atomicModifyIORef', + newIORef, + readIORef) import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -75,7 +84,8 @@ data JunctionEnv = peRedisSocket :: Connection, peConfigPath :: FilePath, peQuoteThread :: QuoteThreadHandle, - peBroker :: BrokerClientHandle + peBroker :: BrokerClientHandle, + peRobots :: IORef (M.Map T.Text RobotDriverHandle) } newtype JunctionM a = JunctionM { unJunctionM :: ReaderT JunctionEnv IO a } @@ -136,26 +146,45 @@ junctionMain descriptors = do let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) withBroker cfg ctx $ \bro -> withQThread downloaderEnv barsMap cfg ctx $ \qt -> do + robotsMap <- newIORef M.empty let env = JunctionEnv { peRedisSocket = redis, peConfigPath = robotsConfigsPath cfg, peQuoteThread = qt, - peBroker = bro + peBroker = bro, + peRobots = robotsMap } - withJunction env $ - forM_ (instances cfg) $ \inst -> - case M.lookup (strategyBaseName inst) descriptors of - Just (StrategyDescriptorE desc) -> do - bigConf <- loadConfig (configKey inst) - 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 - createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState - Nothing -> error "Unknown strategy" + withJunction env $ do + startRobots cfg bro barsMap + forever $ do + saveRobots + liftIO $ threadDelay 5000000 where + saveRobots :: JunctionM () + saveRobots = do + robotsMap <- asks peRobots >>= (liftIO . readIORef) + traverse_ saveRobotState robotsMap + + saveRobotState :: RobotDriverHandle -> JunctionM () + saveRobotState handle = onStrategyInstance handle $ \inst -> do + currentState <- liftIO $ readIORef (strategyState inst) + saveState currentState (strategyInstanceId inst) + + startRobots cfg bro barsMap = forM_ (instances cfg) $ \inst -> + case M.lookup (strategyBaseName inst) descriptors of + Just (StrategyDescriptorE desc) -> do + bigConf <- loadConfig (configKey inst) + 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 + robot <- createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState + robotsMap' <- asks peRobots + liftIO $ atomicModifyIORef' robotsMap' (\s -> (M.insert (strategyId inst) robot s, ())) + Nothing -> error "Unknown strategy" + withJunction :: JunctionEnv -> JunctionM () -> IO () withJunction env = (`runReaderT` env) . unJunctionM diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index bf53bd2..d9093f1 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -8,10 +8,12 @@ module ATrade.Driver.Junction.RobotDriverThread ( createRobotDriverThread, RobotEnv(..), - RobotM(..) + RobotM(..), + RobotDriverHandle, + onStrategyInstance ) where -import ATrade.Broker.Client (BrokerClientHandle (submitOrder)) +import ATrade.Broker.Client (BrokerClientHandle) import qualified ATrade.Broker.Client as Bro import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), QuoteSubscription (QuoteSubscription)) @@ -24,10 +26,10 @@ import ATrade.Driver.Junction.Types (BigConfig, strategyId, tickerId, timeframe) import ATrade.QuoteSource.Client (QuoteData (..)) -import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) +import ATrade.RoboCom.ConfigStorage (ConfigStorage) import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderUpdate), MonadRobot (..)) -import ATrade.RoboCom.Persistence (MonadPersistence (loadState)) +import ATrade.RoboCom.Persistence (MonadPersistence) import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), Bars) import ATrade.Types (OrderId, OrderState, Trade) @@ -40,6 +42,7 @@ import Control.Monad (forM_, forever, void) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader, ReaderT, asks) import Data.Aeson (FromJSON, ToJSON) +import Data.Default import Data.IORef (IORef, atomicModifyIORef', readIORef, writeIORef) import qualified Data.Map.Strict as M @@ -48,7 +51,8 @@ import Data.Time (UTCTime) import Dhall (FromDhall) import System.Log.Logger (infoM) -data RobotDriverHandle = forall c s. RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) +data RobotDriverHandle = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => + RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) data RobotDriverRequest @@ -80,6 +84,7 @@ createRobotDriverThread :: (MonadIO m1, ConfigStorage m1, MonadPersistence m1, QuoteStream m1, + Default s, FromJSON s, ToJSON s, FromDhall c, @@ -110,6 +115,9 @@ createRobotDriverThread instDesc strDesc runner bigConf rConf rState = do v <- readChan quoteQueue writeChan eventQueue (QuoteEvent v) +onStrategyInstance :: RobotDriverHandle -> forall r. (forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => StrategyInstance c s -> r) -> r +onStrategyInstance (RobotDriverHandle inst _ _ _) f = f inst + data RobotEnv c s = RobotEnv { diff --git a/src/ATrade/Driver/Junction/Types.hs b/src/ATrade/Driver/Junction/Types.hs index 602ad4d..ac175e2 100644 --- a/src/ATrade/Driver/Junction/Types.hs +++ b/src/ATrade/Driver/Junction/Types.hs @@ -9,8 +9,10 @@ module ATrade.Driver.Junction.Types TickerConfig(..), StrategyInstanceDescriptor(..), StrategyInstance(..), - BigConfig(..) - ,StrategyDescriptorE(..)) where + BigConfig(..), + StrategyDescriptorE(..), + StrategyInstanceE(..) + ) where import ATrade.RoboCom.Monad (EventCallback) import ATrade.Types (BarTimeframe (..), TickerId) @@ -68,3 +70,5 @@ data StrategyInstance c s = strategyState :: IORef s, strategyConfig :: IORef c } + +data StrategyInstanceE = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => StrategyInstanceE (StrategyInstance c s) From e3adb5bafc1e187f30abf7a95d24540c93dfdd7a Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 28 Nov 2021 10:42:31 +0700 Subject: [PATCH 10/25] junction: save timers --- src/ATrade/Driver/Junction.hs | 7 +++++-- src/ATrade/Driver/Junction/RobotDriverThread.hs | 5 +++-- src/ATrade/Driver/Junction/Types.hs | 4 +++- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index 0cd0f94..ac902a3 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -32,7 +32,8 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor StrategyInstance (strategyInstanceId), StrategyInstanceDescriptor (..), confStrategy, - strategyState) + strategyState, + strategyTimers) import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) @@ -171,6 +172,8 @@ junctionMain descriptors = do saveRobotState handle = onStrategyInstance handle $ \inst -> do currentState <- liftIO $ readIORef (strategyState inst) saveState currentState (strategyInstanceId inst) + currentTimers <- liftIO $ readIORef (strategyTimers inst) + saveState currentTimers (strategyInstanceId inst <> ":timers") startRobots cfg bro barsMap = forM_ (instances cfg) $ \inst -> case M.lookup (strategyBaseName inst) descriptors of @@ -180,7 +183,7 @@ junctionMain descriptors = do rState <- loadState (stateKey inst) >>= liftIO . newIORef rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef let robotEnv = RobotEnv rState rConf rTimers bro barsMap - robot <- createRobotDriverThread inst desc (flip runReaderT robotEnv . unRobotM) bigConf rConf rState + 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, ())) Nothing -> error "Unknown strategy" diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index d9093f1..1652f3f 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -96,12 +96,13 @@ createRobotDriverThread :: (MonadIO m1, -> BigConfig c -> IORef c -> IORef s + -> IORef [UTCTime] -> m1 RobotDriverHandle -createRobotDriverThread instDesc strDesc runner bigConf rConf rState = do +createRobotDriverThread instDesc strDesc runner bigConf rConf rState rTimers = do eventQueue <- liftIO $ newBoundedChan 2000 - let inst = StrategyInstance (strategyId instDesc) (eventCallback strDesc) rState rConf + let inst = StrategyInstance (strategyId instDesc) (eventCallback strDesc) rState rConf rTimers quoteQueue <- liftIO $ newBoundedChan 2000 forM_ (confTickers bigConf) (\x -> addSubscription (QuoteSubscription (tickerId x) (timeframe x)) quoteQueue) diff --git a/src/ATrade/Driver/Junction/Types.hs b/src/ATrade/Driver/Junction/Types.hs index ac175e2..8ff13e1 100644 --- a/src/ATrade/Driver/Junction/Types.hs +++ b/src/ATrade/Driver/Junction/Types.hs @@ -20,6 +20,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Default (Default) import Data.IORef (IORef) import qualified Data.Text as T +import Data.Time (UTCTime) import Dhall (FromDhall) import GHC.Generics (Generic) @@ -68,7 +69,8 @@ data StrategyInstance c s = strategyInstanceId :: T.Text, strategyEventCallback :: EventCallback c s, strategyState :: IORef s, - strategyConfig :: IORef c + strategyConfig :: IORef c, + strategyTimers :: IORef [UTCTime] } data StrategyInstanceE = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => StrategyInstanceE (StrategyInstance c s) From 46674b0d4910d88ef97c668ed22adba475140daa Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 28 Nov 2021 13:17:08 +0700 Subject: [PATCH 11/25] junction: order notifications routing --- robocom-zero.cabal | 1 + src/ATrade/Driver/Junction.hs | 47 ++++++++++++++++--- .../Driver/Junction/RobotDriverThread.hs | 13 ++++- 3 files changed, 53 insertions(+), 8 deletions(-) diff --git a/robocom-zero.cabal b/robocom-zero.cabal index 5ca2859..921f893 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -85,6 +85,7 @@ library , stm , async , dhall + , extra default-language: Haskell2010 other-modules: ATrade.Exceptions diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index ac902a3..81580b7 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -14,6 +14,9 @@ module ATrade.Driver.Junction import ATrade.Broker.Client (BrokerClientHandle, startBrokerClient, stopBrokerClient) +import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification), + NotificationSqnum, + getNotificationSqnum) import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (brokerEndpoint, brokerNotificationEndpoint, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), ProgramOptions (ProgramOptions, configPath)) import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription), @@ -27,7 +30,8 @@ import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, RobotEnv (..), RobotM (..), createRobotDriverThread, - onStrategyInstance) + onStrategyInstance, + postNotificationEvent) import ATrade.Driver.Junction.Types (StrategyDescriptorE (StrategyDescriptorE), StrategyInstance (strategyInstanceId), StrategyInstanceDescriptor (..), @@ -37,11 +41,14 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) -import ATrade.Types (ClientSecurityParams (ClientSecurityParams)) +import ATrade.Types (ClientSecurityParams (ClientSecurityParams), + OrderId, + Trade (tradeOrderId)) import Control.Concurrent import Control.Exception.Safe (MonadThrow, bracket) import Control.Monad (forM_, forever) +import Control.Monad.Extra (whenM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (MonadReader, ReaderT (runReaderT), asks) @@ -55,6 +62,8 @@ import Data.IORef (IORef, newIORef, readIORef) import qualified Data.Map.Strict as M +import Data.Set (notMember) +import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.IO (readFile) @@ -145,9 +154,11 @@ junctionMain descriptors = do redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) }) withContext $ \ctx -> do let downloaderEnv = DownloaderEnv (mkQHPHandle ctx (qhpEndpoint cfg)) ctx (qtisEndpoint cfg) - withBroker cfg ctx $ \bro -> + 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 - robotsMap <- newIORef M.empty let env = JunctionEnv { @@ -191,13 +202,37 @@ junctionMain descriptors = do withJunction :: JunctionEnv -> JunctionM () -> IO () withJunction env = (`runReaderT` env) . unJunctionM - withBroker cfg ctx f = bracket + handleBrokerNotification :: IORef (M.Map T.Text RobotDriverHandle) -> + IORef (M.Map OrderId T.Text) -> + IORef (S.Set NotificationSqnum) -> + Notification -> + IO () + handleBrokerNotification robotsRef ordersMapRef handled notification = + whenM (notMember (getNotificationSqnum notification) <$> readIORef handled) $ do + robotsMap <- readIORef robotsRef + ordersMap <- readIORef ordersMapRef + + case getNotificationTarget robotsMap ordersMap notification of + Just robot -> postNotificationEvent robot notification + Nothing -> warningM "Junction" "Unknown order" + + atomicModifyIORef' handled (\s -> (S.insert (getNotificationSqnum notification) s, ())) + + getNotificationTarget :: M.Map T.Text RobotDriverHandle -> M.Map OrderId T.Text -> Notification -> Maybe RobotDriverHandle + getNotificationTarget robotsMap ordersMap notification = do + robotId <- M.lookup (notificationOrderId notification) ordersMap + M.lookup robotId robotsMap + + notificationOrderId (OrderNotification _ oid _) = oid + notificationOrderId (TradeNotification _ trade) = tradeOrderId trade + + withBroker cfg ctx robotsMap ordersMap handled f = bracket (startBrokerClient "broker" ctx (brokerEndpoint cfg) (brokerNotificationEndpoint cfg) - [] + [handleBrokerNotification robotsMap ordersMap handled] (ClientSecurityParams -- TODO load certificates from file Nothing Nothing)) diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index 1652f3f..ae7e235 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -10,11 +10,12 @@ module ATrade.Driver.Junction.RobotDriverThread RobotEnv(..), RobotM(..), RobotDriverHandle, - onStrategyInstance - ) where + onStrategyInstance, + postNotificationEvent) where import ATrade.Broker.Client (BrokerClientHandle) import qualified ATrade.Broker.Client as Bro +import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification)) import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), QuoteSubscription (QuoteSubscription)) import ATrade.Driver.Junction.Types (BigConfig, @@ -155,3 +156,11 @@ instance MonadRobot (RobotM c s) c s where getTicker tid tf = do b <- asks bars >>= liftIO . readIORef return $ M.lookup (BarSeriesId tid tf) b + +postNotificationEvent :: (MonadIO m) => RobotDriverHandle -> Notification -> m () +postNotificationEvent (RobotDriverHandle _ _ _ eventQueue) notification = liftIO $ + case notification of + OrderNotification _ oid state -> writeChan eventQueue (OrderEvent oid state) + TradeNotification _ trade -> writeChan eventQueue (NewTradeEvent trade) + + From cc910cdfa272ad04bd04a26a8ae01ca6fa1e3b29 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 28 Nov 2021 15:06:20 +0700 Subject: [PATCH 12/25] junction: qs certificates --- src/ATrade/Driver/Junction/QuoteThread.hs | 39 +++++++++++++++-------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/src/ATrade/Driver/Junction/QuoteThread.hs b/src/ATrade/Driver/Junction/QuoteThread.hs index d9261df..c78f8c7 100644 --- a/src/ATrade/Driver/Junction/QuoteThread.hs +++ b/src/ATrade/Driver/Junction/QuoteThread.hs @@ -58,7 +58,7 @@ import qualified Data.Text as T import Data.Time (addUTCTime, getCurrentTime) import System.ZMQ4 (Context) -import System.ZMQ4.ZAP (CurveCertificate) +import System.ZMQ4.ZAP (loadCertificateFromFile) data QuoteThreadHandle = QuoteThreadHandle ThreadId ThreadId QuoteThreadEnv @@ -80,14 +80,13 @@ startQuoteThread :: (MonadIO m, IORef Bars -> Context -> T.Text -> - Maybe CurveCertificate -> - Maybe CurveCertificate -> + ClientSecurityParams -> (m1 () -> IO ()) -> m QuoteThreadHandle -startQuoteThread barsRef ctx ep clientCert serverCert downloadThreadRunner = do +startQuoteThread barsRef ctx ep secparams downloadThreadRunner = do chan <- liftIO $ newBoundedChan 2000 dChan <- liftIO $ newBoundedChan 2000 - qsc <- liftIO $ startQuoteSourceClient chan [] ctx ep (ClientSecurityParams clientCert serverCert) + qsc <- liftIO $ startQuoteSourceClient chan [] ctx ep secparams env <- liftIO $ QuoteThreadEnv barsRef <$> newIORef HM.empty <*> pure qsc <*> newIORef M.empty <*> pure dChan tid <- liftIO . forkIO $ quoteThread env chan downloaderTid <- liftIO . forkIO $ downloadThreadRunner (downloaderThread env dChan) @@ -186,16 +185,28 @@ instance TickerInfoProvider DownloaderM where (tiTickSize ti) withQThread :: DownloaderEnv -> IORef Bars -> ProgramConfiguration -> Context -> (QuoteThreadHandle -> IO ()) -> IO () -withQThread env barsMap cfg ctx = +withQThread env barsMap cfg ctx f = do + securityParameters <- loadSecurityParameters bracket - (startQuoteThread - barsMap - ctx - (quotesourceEndpoint cfg) - Nothing - Nothing - (runDownloaderM env)) - stopQuoteThread + (startQuoteThread + barsMap + ctx + (quotesourceEndpoint cfg) + securityParameters + (runDownloaderM env)) + stopQuoteThread f + where + loadSecurityParameters :: IO ClientSecurityParams + loadSecurityParameters = + case (quotesourceClientCert cfg, quotesourceServerCert 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 runDownloaderM :: DownloaderEnv -> DownloaderM () -> IO () runDownloaderM env = (`runReaderT` env) . unDownloaderM From bf7df5e98caaf78006429459dd74561c2ee56bc9 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 28 Nov 2021 15:09:34 +0700 Subject: [PATCH 13/25] junction: broker certificates --- src/ATrade/Driver/Junction.hs | 39 +++++++++++++++++++++++------------ 1 file changed, 26 insertions(+), 13 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index 81580b7..b6963e0 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -17,7 +17,7 @@ import ATrade.Broker.Client (BrokerClientHandle import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification), NotificationSqnum, getNotificationSqnum) -import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (brokerEndpoint, brokerNotificationEndpoint, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), +import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (brokerClientCert, brokerEndpoint, brokerNotificationEndpoint, brokerServerCert, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), ProgramOptions (ProgramOptions, configPath)) import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription), QuoteSubscription (QuoteSubscription), @@ -44,7 +44,7 @@ import ATrade.RoboCom.Persistence (MonadPersistence ( import ATrade.Types (ClientSecurityParams (ClientSecurityParams), OrderId, Trade (tradeOrderId)) -import Control.Concurrent +import Control.Concurrent (threadDelay) import Control.Exception.Safe (MonadThrow, bracket) import Control.Monad (forM_, forever) @@ -87,6 +87,7 @@ import Options.Applicative (Parser, import Prelude hiding (readFile) import System.Log.Logger (warningM) import System.ZMQ4 (withContext) +import System.ZMQ4.ZAP (loadCertificateFromFile) data JunctionEnv = JunctionEnv @@ -226,17 +227,29 @@ junctionMain descriptors = do notificationOrderId (OrderNotification _ oid _) = oid notificationOrderId (TradeNotification _ trade) = tradeOrderId trade - withBroker cfg ctx robotsMap ordersMap handled f = bracket - (startBrokerClient - "broker" - ctx - (brokerEndpoint cfg) - (brokerNotificationEndpoint cfg) - [handleBrokerNotification robotsMap ordersMap handled] - (ClientSecurityParams -- TODO load certificates from file - Nothing - Nothing)) - stopBrokerClient f + withBroker cfg ctx robotsMap ordersMap handled f = do + securityParameters <- loadBrokerSecurityParameters cfg + bracket + (startBrokerClient + "broker" + ctx + (brokerEndpoint cfg) + (brokerNotificationEndpoint cfg) + [handleBrokerNotification robotsMap ordersMap handled] + securityParameters) + 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 options = info (optionsParser <**> helper) (fullDesc <> From 632ca49d15e0d04a832e32460ba1b952b8643fcd Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Mon, 29 Nov 2021 21:06:12 +0700 Subject: [PATCH 14/25] 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: {} From b1993cc3492374a78faec61f90710b2996979a9f Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Tue, 30 Nov 2021 23:45:33 +0700 Subject: [PATCH 15/25] junction: correct order submission --- robocom-zero.cabal | 1 + src/ATrade/Driver/Junction.hs | 52 +++++--- src/ATrade/Driver/Junction/BrokerService.hs | 56 +++++++++ .../Driver/Junction/RobotDriverThread.hs | 114 ++++++++++-------- src/ATrade/RoboCom/Monad.hs | 2 +- src/ATrade/RoboCom/Positions.hs | 39 +++--- 6 files changed, 179 insertions(+), 85 deletions(-) create mode 100644 src/ATrade/Driver/Junction/BrokerService.hs diff --git a/robocom-zero.cabal b/robocom-zero.cabal index 37cf0b1..c94e3bc 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -34,6 +34,7 @@ library , ATrade.Driver.Junction.QuoteStream , ATrade.Driver.Junction.RobotDriverThread , ATrade.Driver.Junction.ProgramConfiguration + , ATrade.Driver.Junction.BrokerService , ATrade.BarAggregator , ATrade.RoboCom , ATrade.Quotes.HistoryProvider diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index ac72ded..ecc5371 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -17,7 +17,9 @@ import ATrade.Broker.Client (BrokerClientHandle import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification), NotificationSqnum, getNotificationSqnum) -import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (brokerClientCert, brokerEndpoint, brokerNotificationEndpoint, brokerServerCert, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), +import ATrade.Driver.Junction.BrokerService (BrokerService, + mkBrokerService) +import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (ProgramConfiguration, brokerClientCert, brokerEndpoint, brokerNotificationEndpoint, brokerServerCert, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), ProgramOptions (ProgramOptions, configPath)) import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription), QuoteSubscription (QuoteSubscription), @@ -38,16 +40,17 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor confStrategy, strategyState, strategyTimers) -import ATrade.Logging (Message, - Severity (Info), +import ATrade.Logging (Message, Severity (Debug, Error, Info, Trace, Warning), fmtMessage, logWarning, logWith) import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) +import ATrade.RoboCom.Monad (StrategyEnvironment (..)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) +import ATrade.RoboCom.Types (Bars) import ATrade.Types (ClientSecurityParams (ClientSecurityParams), - OrderId, + Order, OrderId, Trade (tradeOrderId)) import Colog (HasLog (getLogAction, setLogAction), LogAction, @@ -76,6 +79,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.IO (readFile) +import Data.Time (getCurrentTime) import Data.Time.Clock.POSIX (getPOSIXTime) import Database.Redis (ConnectInfo (..), Connection, @@ -162,8 +166,8 @@ junctionMain :: M.Map T.Text StrategyDescriptorE -> IO () junctionMain descriptors = do opts <- parseOptions - let bootstrapLogAction = fmtMessage >$< logTextStdout - let log = logWith bootstrapLogAction + let logger = fmtMessage >$< logTextStdout + let log = logWith logger log Info "Junction" $ "Reading config from: " <> (T.pack . show) (configPath opts) @@ -171,15 +175,19 @@ junctionMain descriptors = do barsMap <- newIORef M.empty + log Info "Junction" $ "Connecting to redis: " <> redisSocket cfg redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) }) + log Info "Junction" "redis: connected" withContext $ \ctx -> do + log Debug "Junction" "0mq context created" 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 -> + withBroker cfg ctx robotsMap ordersMap handledNotifications logger $ \bro -> withQThread downloaderEnv barsMap cfg ctx $ \qt -> do + broService <- mkBrokerService bro ordersMap let junctionLogAction = fmtMessage >$< logTextStdout let env = JunctionEnv @@ -192,7 +200,7 @@ junctionMain descriptors = do peLogAction = junctionLogAction } withJunction env $ do - startRobots cfg bro barsMap + startRobots cfg barsMap broService forever $ do saveRobots liftIO $ threadDelay 5000000 @@ -209,7 +217,9 @@ junctionMain descriptors = do currentTimers <- liftIO $ readIORef (strategyTimers inst) saveState currentTimers (strategyInstanceId inst <> ":timers") - startRobots cfg bro barsMap = forM_ (instances cfg) $ \inst -> + startRobots :: ProgramConfiguration -> IORef Bars -> BrokerService -> JunctionM () + startRobots cfg barsMap broService = forM_ (instances cfg) $ \inst -> do + now <- liftIO getCurrentTime case M.lookup (strategyBaseName inst) descriptors of Just (StrategyDescriptorE desc) -> do bigConf <- loadConfig (configKey inst) @@ -217,7 +227,14 @@ junctionMain descriptors = do rState <- loadState (stateKey inst) >>= liftIO . newIORef rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef let robotLogAction = fmtMessage >$< logTextStdout - let robotEnv = RobotEnv rState rConf rTimers bro barsMap robotLogAction + stratEnv <- liftIO $ newIORef StrategyEnvironment + { + _seInstanceId = strategyId inst, + _seAccount = "test", -- TODO configure + _seVolume = 1, + _seLastTimestamp = now + } + let robotEnv = RobotEnv rState rConf rTimers barsMap stratEnv robotLogAction broService 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, ())) @@ -229,16 +246,20 @@ junctionMain descriptors = do handleBrokerNotification :: IORef (M.Map T.Text RobotDriverHandle) -> IORef (M.Map OrderId T.Text) -> IORef (S.Set NotificationSqnum) -> + LogAction IO Message -> Notification -> IO () - handleBrokerNotification robotsRef ordersMapRef handled notification = + handleBrokerNotification robotsRef ordersMapRef handled logger notification= do + logWith logger Trace "Junction" $ "Incoming notification: " <> (T.pack . show) notification whenM (notMember (getNotificationSqnum notification) <$> readIORef handled) $ do robotsMap <- readIORef robotsRef ordersMap <- readIORef ordersMapRef case getNotificationTarget robotsMap ordersMap notification of Just robot -> postNotificationEvent robot notification - Nothing -> return () --logWarning "Junction" "Unknown order" -- TODO log + Nothing -> do + logWith logger Warning "Junction" $ "Unknown order: " <> (T.pack . show) (notificationOrderId notification) + logWith logger Debug "Junction" $ "Ordermap: " <> (T.pack . show) (M.toList ordersMap) atomicModifyIORef' handled (\s -> (S.insert (getNotificationSqnum notification) s, ())) @@ -250,7 +271,7 @@ junctionMain descriptors = do notificationOrderId (OrderNotification _ oid _) = oid notificationOrderId (TradeNotification _ trade) = tradeOrderId trade - withBroker cfg ctx robotsMap ordersMap handled f = do + withBroker cfg ctx robotsMap ordersMap handled logger f = do securityParameters <- loadBrokerSecurityParameters cfg bracket (startBrokerClient @@ -258,8 +279,9 @@ junctionMain descriptors = do ctx (brokerEndpoint cfg) (brokerNotificationEndpoint cfg) - [handleBrokerNotification robotsMap ordersMap handled] - securityParameters) + [handleBrokerNotification robotsMap ordersMap handled logger] + securityParameters + logger) stopBrokerClient f loadBrokerSecurityParameters cfg = diff --git a/src/ATrade/Driver/Junction/BrokerService.hs b/src/ATrade/Driver/Junction/BrokerService.hs new file mode 100644 index 0000000..a03f085 --- /dev/null +++ b/src/ATrade/Driver/Junction/BrokerService.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module ATrade.Driver.Junction.BrokerService + ( + BrokerService, + mkBrokerService, + submitOrder, + cancelOrder, + getNotifications + ) where + +import qualified ATrade.Broker.Client as Bro +import ATrade.Broker.Protocol (Notification (..)) +import ATrade.Logging (Message, logDebug) +import ATrade.Types (Order (..), OrderId) +import Colog (WithLog) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader.Class (MonadReader) +import Data.IORef (IORef, atomicModifyIORef', + newIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text as T + +data BrokerService = + BrokerService + { + broker :: Bro.BrokerClientHandle, + orderMap :: IORef (M.Map OrderId T.Text), + orderIdCounter :: IORef OrderId + } + +mkBrokerService :: Bro.BrokerClientHandle -> IORef (M.Map OrderId T.Text) -> IO BrokerService +mkBrokerService h om = BrokerService h om <$> newIORef 1 + +submitOrder :: (MonadIO m, WithLog env Message m, MonadReader env m) => BrokerService -> T.Text -> Order -> m OrderId +submitOrder service identity order = do + oid <- nextOrderId service + logDebug "BrokerService" $ "New order, id: " <> (T.pack . show) oid + liftIO $ atomicModifyIORef' (orderMap service) (\s -> (M.insert oid identity s, ())) + _ <- liftIO $ Bro.submitOrder (broker service) order { orderId = oid } + return oid + where + nextOrderId srv = liftIO $ atomicModifyIORef' (orderIdCounter srv) (\s -> (s + 1, s)) + +cancelOrder :: BrokerService -> OrderId -> IO () +cancelOrder service oid = do + _ <- Bro.cancelOrder (broker service) oid + return () + +getNotifications :: BrokerService -> IO [Notification] +getNotifications service = do + v <- Bro.getNotifications (broker service) + case v of + Left _ -> return [] + Right n -> return n diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index 8c726bc..f8177bb 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -15,46 +15,51 @@ module ATrade.Driver.Junction.RobotDriverThread onStrategyInstance, postNotificationEvent) where -import ATrade.Broker.Client (BrokerClientHandle) -import qualified ATrade.Broker.Client as Bro -import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification)) -import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), - QuoteSubscription (QuoteSubscription)) -import ATrade.Driver.Junction.Types (BigConfig, - StrategyDescriptor, - StrategyInstance (StrategyInstance, strategyEventCallback), - StrategyInstanceDescriptor (configKey), - confStrategy, confTickers, - 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), - MonadRobot (..)) -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, - writeChan) -import Control.Exception.Safe (MonadThrow) -import Control.Monad (forM_, forever, void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader, ReaderT, asks) -import Data.Aeson (FromJSON, ToJSON) +import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification)) +import qualified ATrade.Driver.Junction.BrokerService as Bro +import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), + QuoteSubscription (QuoteSubscription)) +import ATrade.Driver.Junction.Types (BigConfig, + StrategyDescriptor, + StrategyInstance (StrategyInstance, strategyEventCallback), + StrategyInstanceDescriptor (configKey), + confStrategy, + confTickers, + eventCallback, stateKey, + strategyId, tickerId, + timeframe) +import ATrade.Logging (Message, logDebug, + logInfo, logWarning) +import ATrade.QuoteSource.Client (QuoteData (..)) +import ATrade.RoboCom.ConfigStorage (ConfigStorage) +import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderSubmitted, OrderUpdate), + MonadRobot (..), + StrategyEnvironment (StrategyEnvironment, _seInstanceId, _seLastTimestamp)) +import ATrade.RoboCom.Persistence (MonadPersistence) +import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), + Bars) +import ATrade.Types (Order (orderId), OrderId, + OrderState, Trade) +import Colog (HasLog (getLogAction, setLogAction), + LogAction) +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.BoundedChan (BoundedChan, + newBoundedChan, readChan, + writeChan) +import Control.Exception.Safe (MonadThrow) +import Control.Monad (forM_, forever, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader (local), + ReaderT, asks) +import Data.Aeson (FromJSON, ToJSON) import Data.Default -import Data.IORef (IORef, atomicModifyIORef', - readIORef, writeIORef) -import qualified Data.Map.Strict as M -import qualified Data.Text.Lazy as TL -import Data.Time (UTCTime) -import Dhall (FromDhall) +import Data.IORef (IORef, + atomicModifyIORef', + readIORef, writeIORef) +import qualified Data.Map.Strict as M +import qualified Data.Text.Lazy as TL +import Data.Time (UTCTime, getCurrentTime) +import Dhall (FromDhall) data RobotDriverHandle = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) @@ -94,6 +99,7 @@ createRobotDriverThread :: (MonadIO m1, ToJSON s, FromDhall c, MonadIO m, + MonadReader (RobotEnv c s) m, MonadRobot m c s) => StrategyInstanceDescriptor -> StrategyDescriptor c s @@ -113,7 +119,7 @@ createRobotDriverThread instDesc strDesc runner bigConf rConf rState rTimers = d forM_ (confTickers bigConf) (\x -> addSubscription (QuoteSubscription (tickerId x) (timeframe x)) quoteQueue) qthread <- liftIO . forkIO $ forever $ passQuoteEvents eventQueue quoteQueue - driver <- liftIO . forkIO $ runner $ robotDriverThread inst eventQueue + driver <- liftIO . forkIO $ runner $ robotDriverThread inst eventQueue return $ RobotDriverHandle inst driver qthread eventQueue where @@ -127,12 +133,13 @@ onStrategyInstance (RobotDriverHandle inst _ _ _) f = f inst data RobotEnv c s = RobotEnv { - stateRef :: IORef s, - configRef :: IORef c, - timersRef :: IORef [UTCTime], - broker :: BrokerClientHandle, - bars :: IORef Bars, - logAction :: LogAction (RobotM c s) Message + stateRef :: IORef s, + configRef :: IORef c, + timersRef :: IORef [UTCTime], + bars :: IORef Bars, + env :: IORef StrategyEnvironment, + logAction :: LogAction (RobotM c s) Message, + brokerService :: Bro.BrokerService } newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a } @@ -144,12 +151,13 @@ instance HasLog (RobotEnv c s) Message (RobotM c s) where instance MonadRobot (RobotM c s) c s where submitOrder order = do - bro <- asks broker - liftIO $ void $ Bro.submitOrder bro order + instId <- _seInstanceId <$> (asks env >>= liftIO . readIORef) + bro <- asks brokerService + Bro.submitOrder bro instId order cancelOrder oid = do - bro <- asks broker - liftIO $ void $ Bro.cancelOrder bro oid + bro <- asks brokerService + liftIO . void $ Bro.cancelOrder bro oid appendToLog = logInfo "RobotM" . TL.toStrict -- TODO get instance id from environment and better use it instead of generic 'RobotM' @@ -161,7 +169,11 @@ instance MonadRobot (RobotM c s) c s where getConfig = asks configRef >>= liftIO . readIORef getState = asks stateRef >>= liftIO . readIORef setState newState = asks stateRef >>= liftIO . flip writeIORef newState - getEnvironment = undefined + getEnvironment = do + ref <- asks env + now <- liftIO getCurrentTime + liftIO $ atomicModifyIORef' ref (\e -> (e { _seLastTimestamp = now }, e { _seLastTimestamp = now})) + getTicker tid tf = do b <- asks bars >>= liftIO . readIORef return $ M.lookup (BarSeriesId tid tf) b diff --git a/src/ATrade/RoboCom/Monad.hs b/src/ATrade/RoboCom/Monad.hs index f043279..69eb915 100644 --- a/src/ATrade/RoboCom/Monad.hs +++ b/src/ATrade/RoboCom/Monad.hs @@ -34,7 +34,7 @@ import Language.Haskell.Printf import Language.Haskell.TH.Quote (QuasiQuoter) class (Monad m) => MonadRobot m c s | m -> c, m -> s where - submitOrder :: Order -> m () + submitOrder :: Order -> m OrderId cancelOrder :: OrderId -> m () appendToLog :: TL.Text -> m () setupTimer :: UTCTime -> m () diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index 4fa2443..e0ebeda 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -65,7 +65,8 @@ module ATrade.RoboCom.Positions setStopLoss, setLimitStopLoss, setTakeProfit, - setStopLossAndTakeProfit + setStopLossAndTakeProfit, + handlePositions ) where import GHC.Generics @@ -191,9 +192,9 @@ dispatchPosition event pos = case posState pos of if orderDeadline (posSubmissionDeadline pos) lastTs then return $ pos { posState = PositionCancelled } -- TODO call TimeoutHandler if present else case event of - OrderSubmitted order -> - return $ if order `orderCorrespondsTo` pendingOrder - then pos { posCurrentOrder = Just order, + OrderUpdate oid Submitted -> do + return $ if orderId pendingOrder == oid + then pos { posCurrentOrder = Just pendingOrder, posState = PositionWaitingOpen, posSubmissionDeadline = Nothing } else pos @@ -206,7 +207,6 @@ dispatchPosition event pos = case posState pos of then if posBalance pos == 0 then do - appendToLog $ [t|"In PositionWaitingOpen: execution timeout: %?/%?"|] (posExecutionDeadline pos) lastTs cancelOrder $ orderId order return $ pos { posState = PositionWaitingPendingCancellation, posNextState = Just PositionCancelled } else do @@ -271,8 +271,11 @@ dispatchPosition event pos = case posState pos of (OrderUpdate _ newstate, Just _, Just (PositionWaitingCloseSubmission nextOrder)) -> if newstate == Cancelled then do - submitOrder nextOrder - return pos { posState = PositionWaitingCloseSubmission nextOrder, posSubmissionDeadline = Just (10 `addUTCTime` lastTs), posExecutionDeadline = Nothing } + oid <- submitOrder nextOrder + return pos + { posState = PositionWaitingCloseSubmission nextOrder { orderId = oid }, + posSubmissionDeadline = Just (10 `addUTCTime` lastTs), + posExecutionDeadline = Nothing } else return pos (OrderUpdate _ newstate, Just _, Just PositionCancelled) -> if newstate == Cancelled @@ -292,9 +295,9 @@ dispatchPosition event pos = case posState pos of Nothing -> doNothing return $ pos { posCurrentOrder = Nothing, posState = PositionOpen, posSubmissionDeadline = Nothing } -- TODO call TimeoutHandler if present else case event of - OrderSubmitted order -> - return $ if order `orderCorrespondsTo` pendingOrder - then pos { posCurrentOrder = Just order, + OrderUpdate oid Submitted -> + return $ if orderId pendingOrder == oid + then pos { posCurrentOrder = Just pendingOrder, posState = PositionWaitingClose, posSubmissionDeadline = Nothing } else pos @@ -464,8 +467,8 @@ enterAtMarket operationSignalName operation = do enterAtMarketWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position enterAtMarketWithParams account quantity signalId operation = do tickerId <- snd . mainTicker <$> getConfig - submitOrder $ order tickerId - newPosition (order tickerId) account tickerId operation quantity 20 + oid <- submitOrder $ order tickerId + newPosition ((order tickerId) { orderId = oid }) account tickerId operation quantity 20 where order tickerId = mkOrder { orderAccountId = account, @@ -508,9 +511,9 @@ enterAtLimitForTicker tickerId timeToCancel operationSignalName price operation enterAtLimitForTickerWithParams :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do lastTs <- view seLastTimestamp <$> getEnvironment - submitOrder order + oid <- submitOrder order appendToLog $ [t|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) - newPosition order account tickerId operation quantity 20 >>= + newPosition (order {orderId = oid}) account tickerId operation quantity 20 >>= modifyPosition (\p -> p { posExecutionDeadline = Just $ timeToCancel `addUTCTime` lastTs }) where order = mkOrder { @@ -554,10 +557,10 @@ exitAtMarket position operationSignalName = do posExecutionDeadline = Nothing }) position Nothing -> do - submitOrder (closeOrder inst) + oid <- submitOrder (closeOrder inst) modifyPosition (\pos -> pos { posCurrentOrder = Nothing, - posState = PositionWaitingCloseSubmission (closeOrder inst), + posState = PositionWaitingCloseSubmission (closeOrder inst) { orderId = oid }, posNextState = Just PositionClosed, posSubmissionDeadline = Just $ 10 `addUTCTime` lastTs, posExecutionDeadline = Nothing }) position @@ -578,11 +581,11 @@ exitAtLimit timeToCancel price position operationSignalName = do case posCurrentOrder position of Just order -> cancelOrder (orderId order) Nothing -> doNothing - submitOrder (closeOrder inst) + oid <- submitOrder (closeOrder inst) appendToLog $ [t|exitAtLimit: %?, deadline: %?|] (posTicker position) (timeToCancel `addUTCTime` lastTs) modifyPosition (\pos -> pos { posCurrentOrder = Nothing, - posState = PositionWaitingCloseSubmission (closeOrder inst), + posState = PositionWaitingCloseSubmission (closeOrder inst) { orderId = oid }, posNextState = Just PositionClosed, posSubmissionDeadline = Just $ 10 `addUTCTime` lastTs, posExecutionDeadline = Just $ timeToCancel `addUTCTime` lastTs }) position From 6303886f84086bcfd3c47f3b9c28b51a6bfd0001 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Tue, 30 Nov 2021 23:57:19 +0700 Subject: [PATCH 16/25] BarTimeframe: Correct FromDhall instance --- src/ATrade/Driver/Junction/Types.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/ATrade/Driver/Junction/Types.hs b/src/ATrade/Driver/Junction/Types.hs index 8ff13e1..d16f76e 100644 --- a/src/ATrade/Driver/Junction/Types.hs +++ b/src/ATrade/Driver/Junction/Types.hs @@ -21,7 +21,7 @@ import Data.Default (Default) import Data.IORef (IORef) import qualified Data.Text as T import Data.Time (UTCTime) -import Dhall (FromDhall) +import Dhall (FromDhall, autoWith, natural) import GHC.Generics (Generic) data StrategyDescriptor c s = @@ -41,7 +41,9 @@ data TickerConfig = } deriving (Generic) -instance FromDhall BarTimeframe +instance FromDhall BarTimeframe where + autoWith _ = BarTimeframe . fromIntegral <$> natural + instance FromDhall TickerConfig data BigConfig c = BigConfig { From e0ebeb9496437e07d307651dc8fc9b666c44cf14 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Wed, 1 Dec 2021 21:34:36 +0700 Subject: [PATCH 17/25] Some cleanup --- src/ATrade/Driver/Junction.hs | 9 +- src/ATrade/Driver/Junction/OrderRouter.hs | 178 ---------------------- 2 files changed, 4 insertions(+), 183 deletions(-) delete mode 100644 src/ATrade/Driver/Junction/OrderRouter.hs diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index ecc5371..95e0936 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -19,7 +19,7 @@ import ATrade.Broker.Protocol (Notification (Orde getNotificationSqnum) import ATrade.Driver.Junction.BrokerService (BrokerService, mkBrokerService) -import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (ProgramConfiguration, brokerClientCert, brokerEndpoint, brokerNotificationEndpoint, brokerServerCert, instances, qhpEndpoint, qtisEndpoint, redisSocket, robotsConfigsPath), +import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (..), ProgramOptions (ProgramOptions, configPath)) import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription), QuoteSubscription (QuoteSubscription), @@ -28,8 +28,7 @@ import ATrade.Driver.Junction.QuoteThread (DownloaderEnv (Dow QuoteThreadHandle, withQThread) import qualified ATrade.Driver.Junction.QuoteThread as QT -import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, - RobotEnv (..), +import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, RobotEnv (RobotEnv), RobotM (..), createRobotDriverThread, onStrategyInstance, @@ -40,7 +39,7 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor confStrategy, strategyState, strategyTimers) -import ATrade.Logging (Message, Severity (Debug, Error, Info, Trace, Warning), +import ATrade.Logging (Message, Severity (Debug, Info, Trace, Warning), fmtMessage, logWarning, logWith) @@ -50,7 +49,7 @@ import ATrade.RoboCom.Monad (StrategyEnvironmen import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) import ATrade.RoboCom.Types (Bars) import ATrade.Types (ClientSecurityParams (ClientSecurityParams), - Order, OrderId, + OrderId, Trade (tradeOrderId)) import Colog (HasLog (getLogAction, setLogAction), LogAction, diff --git a/src/ATrade/Driver/Junction/OrderRouter.hs b/src/ATrade/Driver/Junction/OrderRouter.hs deleted file mode 100644 index 9fe5825..0000000 --- a/src/ATrade/Driver/Junction/OrderRouter.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -module ATrade.Driver.Junction.OrderRouter - ( - mkOrderRouter, - AccountsList - ) where - -import ATrade.Broker.Client (BrokerClientHandle (cancelOrder, getNotifications, submitOrder), - startBrokerClient, - stopBrokerClient) -import ATrade.Broker.Protocol (Notification (..)) -import ATrade.RoboCom.Monad (Event (..)) -import ATrade.Types (ClientSecurityParams, - Order (..), OrderId) -import Control.Concurrent.BoundedChan (BoundedChan, newBoundedChan, - readChan, tryReadChan, - writeChan, writeList2Chan) -import Control.Monad (forM_, forever) -import Control.Monad.Logger (MonadLogger, logDebugS, - logInfoS, logWarnS) -import qualified Data.Bimap as BM -import qualified Data.ByteString.Char8 as B8 -import Data.List (find) -import qualified Data.Text as T -import GHC.OverloadedLabels (IsLabel (..)) -import System.ZMQ4 (Context) -import UnliftIO (MonadUnliftIO, liftIO) -import UnliftIO.Concurrent (ThreadId, forkIO) -import UnliftIO.IORef (IORef, atomicModifyIORef', - newIORef, readIORef) - -data OrderRouterEvent = - SubmitOrder Order | - CancelOrder OrderId | - BrokerNotification Notification - -data OrderRouter = - OrderRouter - { - requestChan :: BoundedChan OrderRouterEvent, - eventChan :: BoundedChan Event, - routerThread :: ThreadId, - brokers :: [([T.Text], BrokerClientHandle)] - } - -instance IsLabel "requestChan" (OrderRouter -> BoundedChan OrderRouterEvent) where - fromLabel = requestChan - -instance IsLabel "eventChan" (OrderRouter -> BoundedChan Event) where - fromLabel = eventChan - -instance IsLabel "brokers" (OrderRouter -> [([T.Text], BrokerClientHandle)]) where - fromLabel = brokers - -data OrderRouterEnv = - OrderRouterEnv - { - requestChan :: BoundedChan OrderRouterEvent, - eventChan :: BoundedChan Event, - brokers :: [([T.Text], BrokerClientHandle)], - notificationRequestThread :: ThreadId, - orderIdMap :: IORef (BM.Bimap OrderId (OrderId, T.Text)), - currentOrderId :: IORef OrderId - } - -instance IsLabel "requestChan" (OrderRouterEnv -> BoundedChan OrderRouterEvent) where - fromLabel = requestChan - -instance IsLabel "eventChan" (OrderRouterEnv -> BoundedChan Event) where - fromLabel = eventChan - -instance IsLabel "brokers" (OrderRouterEnv -> [([T.Text], BrokerClientHandle)]) where - fromLabel = brokers - --- | List of pairs: ([accounts], broker-endpoint, security-params) -type AccountsList = [([T.Text], T.Text, ClientSecurityParams)] - - -mkOrderRouter :: (MonadUnliftIO m, MonadLogger m) => Context -> AccountsList -> BoundedChan Event -> m OrderRouter -mkOrderRouter ctx accounts evtChan = do - $(logInfoS) "OrderRouter" "Order Router started" - rqChan <- liftIO $ newBoundedChan 1000 - bros <- makeBrokers accounts - idmap <- newIORef BM.empty - rqThread <- forkIO $ requestNotifications bros rqChan - idcnt <- newIORef 1 - let env = OrderRouterEnv { - requestChan = rqChan, - eventChan = evtChan, - brokers = bros, - notificationRequestThread = rqThread, - orderIdMap = idmap, - currentOrderId = idcnt - } - tId <- forkIO (react env) - return $ OrderRouter rqChan evtChan tId bros - where - makeBrokers = mapM (\(accs, ep, secParams) -> do - bro <- liftIO $ startBrokerClient (B8.pack "foo") ctx ep secParams - return (accs, bro)) - - react env = do - $(logDebugS) "OrderRouter" "Order Router react" - let rqChan = #requestChan env - evts <- liftIO $ readChanMax 20 rqChan - forM_ evts (handleEvent env) - - handleEvent env evt = do - case evt of - (SubmitOrder order) -> doSubmitOrder env order - (CancelOrder oid) -> doCancelOrder env oid - (BrokerNotification notification) -> handleBrokerNotification env notification - - readChanMax n chan = do - first <- readChan chan - rest <- readChanN (n - 1) chan - return $ first : rest - - readChanN n chan - | n <= 0 = return [] - | otherwise = do - x <- tryReadChan chan - case x of - Nothing -> return [] - Just v -> do - rest <- readChanN (n - 1) chan - return $ v : rest - - doSubmitOrder env order = do - let bros = #brokers env - case findBrokerForAccount (orderAccountId order) bros of - Just bro -> do - result <- liftIO $ submitOrder bro order - case result of - Left errmsg -> $(logWarnS) "OrderRouter" $ "Unable to submit order: " <> errmsg - Right oid -> do - newOrderId <- atomicModifyIORef' (currentOrderId env) (\s -> (s + 1, s)) - atomicModifyIORef' (orderIdMap env) (\s -> (BM.insert newOrderId (oid, orderAccountId order) s, ())) - pushEvent (OrderSubmitted order { orderId = newOrderId }) - - Nothing -> $(logWarnS) "OrderRouter" $ "No broker found for account: " <> orderAccountId order - - doCancelOrder env oid = do - let bros = #brokers env - idpair <- BM.lookup oid <$> readIORef (orderIdMap env) - case idpair of - Just (brokerOrderId, account) -> - case findBrokerForAccount account bros of - Just bro -> do - result <- liftIO $ cancelOrder bro brokerOrderId - case result of - Left errmsg -> $(logWarnS) "OrderRouter" $ "Unable to cancel order: " <> (T.pack . show) brokerOrderId <> ", account: " <> account <> ", " <> errmsg - Right _ -> return () - Nothing -> $(logWarnS) "OrderRouter" $ "Can't find broker for order: " <> (T.pack . show) brokerOrderId <> ", account: " <> account - Nothing -> $(logWarnS) "OrderRouter" $ "Can't find order id map: " <> (T.pack . show) oid - - handleBrokerNotification env notification = undefined - pushEvent event = liftIO $ writeChan evtChan event - - findBrokerForAccount :: T.Text -> [([T.Text], BrokerClientHandle)] -> Maybe BrokerClientHandle - findBrokerForAccount accId bros = snd <$> find (\x -> accId `elem` fst x) bros - - requestNotifications bros rqChan = forever $ do - forM_ bros $ \(_, handle) -> do - result <- liftIO $ getNotifications handle - case result of - Left errmsg -> $(logWarnS) "OrderRouter" $ "Can't request notifications: " <> errmsg - Right nots -> liftIO $ writeList2Chan rqChan (BrokerNotification <$> nots) - - From 9963fbd536f5c732f41e9407d651e24e93b98ecd Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Thu, 2 Dec 2021 19:04:55 +0700 Subject: [PATCH 18/25] junction: logging --- src/ATrade/Driver/Junction.hs | 89 +++++++++++-------- .../Driver/Junction/ProgramConfiguration.hs | 2 +- .../Driver/Junction/RobotDriverThread.hs | 4 +- 3 files changed, 56 insertions(+), 39 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index 95e0936..e482c71 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -55,6 +55,7 @@ import Colog (HasLog (getLogActi LogAction, logTextStdout, (>$<)) +import Colog.Actions (logTextHandle) import Control.Concurrent (threadDelay) import Control.Exception.Safe (MonadThrow, bracket) @@ -98,6 +99,12 @@ import Options.Applicative (Parser, (<**>)) import Prelude hiding (log, readFile) +import System.IO (BufferMode (LineBuffering), + Handle, + IOMode (AppendMode), + hSetBuffering, + openFile, + withFile) import System.ZMQ4 (withContext) import System.ZMQ4.ZAP (loadCertificateFromFile) @@ -161,48 +168,54 @@ instance QuoteStream JunctionM where return (SubscriptionId 0) -- TODO subscription Ids removeSubscription _ = undefined +logger :: (MonadIO m) => Handle -> LogAction m Message +logger h = fmtMessage >$< (logTextStdout <> logTextHandle h) + junctionMain :: M.Map T.Text StrategyDescriptorE -> IO () junctionMain descriptors = do opts <- parseOptions - let logger = fmtMessage >$< logTextStdout - let log = logWith logger + let initialLogger = fmtMessage >$< logTextStdout - log Info "Junction" $ "Reading config from: " <> (T.pack . show) (configPath opts) + logWith initialLogger Info "Junction" $ "Reading config from: " <> (T.pack . show) (configPath opts) cfg <- readFile (configPath opts) >>= input auto - barsMap <- newIORef M.empty - - log Info "Junction" $ "Connecting to redis: " <> redisSocket cfg - redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) }) - log Info "Junction" "redis: connected" - withContext $ \ctx -> do - log Debug "Junction" "0mq context created" - 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 logger $ \bro -> - withQThread downloaderEnv barsMap cfg ctx $ \qt -> do - broService <- mkBrokerService bro ordersMap - let junctionLogAction = fmtMessage >$< logTextStdout - let env = - JunctionEnv - { - peRedisSocket = redis, - peConfigPath = robotsConfigsPath cfg, - peQuoteThread = qt, - peBroker = bro, - peRobots = robotsMap, - peLogAction = junctionLogAction - } - withJunction env $ do - startRobots cfg barsMap broService - forever $ do - saveRobots - liftIO $ threadDelay 5000000 + withFile (logBasePath cfg <> "/all.log") AppendMode $ \h -> do + + let log = logWith (logger h) + + barsMap <- newIORef M.empty + + log Info "Junction" $ "Connecting to redis: " <> redisSocket cfg + redis <- checkedConnect (defaultConnectInfo { connectPort = UnixSocket (T.unpack $ redisSocket cfg) }) + log Info "Junction" "redis: connected" + withContext $ \ctx -> do + log Debug "Junction" "0mq context created" + let downloaderLogAction = logger h + 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 (logger h) $ \bro -> + withQThread downloaderEnv barsMap cfg ctx $ \qt -> do + broService <- mkBrokerService bro ordersMap + let junctionLogAction = logger h + let env = + JunctionEnv + { + peRedisSocket = redis, + peConfigPath = robotsConfigsPath cfg, + peQuoteThread = qt, + peBroker = bro, + peRobots = robotsMap, + peLogAction = junctionLogAction + } + withJunction env $ do + startRobots h cfg barsMap broService + forever $ do + saveRobots + liftIO $ threadDelay 5000000 where saveRobots :: JunctionM () saveRobots = do @@ -216,8 +229,8 @@ junctionMain descriptors = do currentTimers <- liftIO $ readIORef (strategyTimers inst) saveState currentTimers (strategyInstanceId inst <> ":timers") - startRobots :: ProgramConfiguration -> IORef Bars -> BrokerService -> JunctionM () - startRobots cfg barsMap broService = forM_ (instances cfg) $ \inst -> do + startRobots :: Handle -> ProgramConfiguration -> IORef Bars -> BrokerService -> JunctionM () + startRobots logHandle cfg barsMap broService = forM_ (instances cfg) $ \inst -> do now <- liftIO getCurrentTime case M.lookup (strategyBaseName inst) descriptors of Just (StrategyDescriptorE desc) -> do @@ -225,7 +238,9 @@ junctionMain descriptors = do rConf <- liftIO $ newIORef (confStrategy bigConf) rState <- loadState (stateKey inst) >>= liftIO . newIORef rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef - let robotLogAction = fmtMessage >$< logTextStdout + localH <- liftIO $ openFile (logBasePath cfg <> "/" <> T.unpack (strategyId inst) <> ".log") AppendMode + liftIO $ hSetBuffering localH LineBuffering + let robotLogAction = logger logHandle <> (fmtMessage >$< logTextHandle localH) stratEnv <- liftIO $ newIORef StrategyEnvironment { _seInstanceId = strategyId inst, diff --git a/src/ATrade/Driver/Junction/ProgramConfiguration.hs b/src/ATrade/Driver/Junction/ProgramConfiguration.hs index ec36c1b..af2cde5 100644 --- a/src/ATrade/Driver/Junction/ProgramConfiguration.hs +++ b/src/ATrade/Driver/Junction/ProgramConfiguration.hs @@ -30,7 +30,7 @@ data ProgramConfiguration = qtisEndpoint :: T.Text, redisSocket :: T.Text, robotsConfigsPath :: FilePath, - globalLog :: FilePath, + logBasePath :: FilePath, instances :: [StrategyInstanceDescriptor] } deriving (Generic, Show) diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index f8177bb..d06554a 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -159,7 +159,9 @@ instance MonadRobot (RobotM c s) c s where bro <- asks brokerService liftIO . void $ Bro.cancelOrder bro oid - appendToLog = logInfo "RobotM" . TL.toStrict -- TODO get instance id from environment and better use it instead of generic 'RobotM' + appendToLog t = do + instId <- _seInstanceId <$> (asks env >>= liftIO . readIORef) + logInfo instId . TL.toStrict $ t setupTimer t = do ref <- asks timersRef From e2cdffc1f68cbf9b0bb7dbf41dee460c35fb636d Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Thu, 2 Dec 2021 21:27:13 +0700 Subject: [PATCH 19/25] junction: send getNotifications periodically --- src/ATrade/Driver/Junction.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index e482c71..a136ba6 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -15,9 +15,10 @@ import ATrade.Broker.Client (BrokerClientHandle startBrokerClient, stopBrokerClient) import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification), - NotificationSqnum, + NotificationSqnum (unNotificationSqnum), getNotificationSqnum) import ATrade.Driver.Junction.BrokerService (BrokerService, + getNotifications, mkBrokerService) import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (..), ProgramOptions (ProgramOptions, configPath)) @@ -214,8 +215,10 @@ junctionMain descriptors = do withJunction env $ do startRobots h cfg barsMap broService forever $ do + notifications <- liftIO $ getNotifications broService + forM_ notifications (liftIO . handleBrokerNotification robotsMap ordersMap handledNotifications (logger h)) saveRobots - liftIO $ threadDelay 5000000 + liftIO $ threadDelay 1000000 where saveRobots :: JunctionM () saveRobots = do @@ -264,7 +267,7 @@ junctionMain descriptors = do Notification -> IO () handleBrokerNotification robotsRef ordersMapRef handled logger notification= do - logWith logger Trace "Junction" $ "Incoming notification: " <> (T.pack . show) notification + logWith logger Trace "Junction" $ "Incoming notification: " <> (T.pack . show . unNotificationSqnum . getNotificationSqnum) notification whenM (notMember (getNotificationSqnum notification) <$> readIORef handled) $ do robotsMap <- readIORef robotsRef ordersMap <- readIORef ordersMapRef From 9ecabaffd03a601dc346fb42784ee1c2a4f2394b Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Thu, 2 Dec 2021 21:27:28 +0700 Subject: [PATCH 20/25] qhp: more logging --- src/ATrade/Quotes/QHP.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/ATrade/Quotes/QHP.hs b/src/ATrade/Quotes/QHP.hs index 1ff7f19..a33d5ee 100644 --- a/src/ATrade/Quotes/QHP.hs +++ b/src/ATrade/Quotes/QHP.hs @@ -11,7 +11,7 @@ module ATrade.Quotes.QHP ( ) where import ATrade.Exceptions -import ATrade.Logging (Message, logInfo) +import ATrade.Logging (Message, logInfo, logDebug) import ATrade.Types import Colog (WithLog) import Control.Exception.Safe (MonadThrow, throw) @@ -103,7 +103,8 @@ instance ToJSON RequestParams where 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 + logDebug "QHP" $ "From: " <> (T.pack . show) (startDate params) <> "; To: " <> (T.pack . show) (endDate params) + result <- liftIO $ withSocket ctx Req $ \sock -> do connect sock $ (T.unpack . endpoint) params send sock [] (BL.toStrict $ encode params) response <- receiveMulti sock @@ -112,6 +113,8 @@ getQuotes ctx params = do then return $ reverse $ parseBars (ticker params) $ BL.fromStrict rest else return [] _ -> return [] + logInfo "QHP" $ "Obtained bars: " <> (T.pack . show . length) result + return result parseBars :: TickerId -> BL.ByteString -> [Bar] parseBars tickerId input = From 0d350774df46548104d41da8d7e88dd3e982a14b Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Thu, 2 Dec 2021 21:28:00 +0700 Subject: [PATCH 21/25] positions: GC --- src/ATrade/RoboCom/Positions.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index e0ebeda..c054608 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -371,9 +371,7 @@ newPosition order account tickerId operation quantity submissionDeadline = do return position reapDeadPositions :: (StateHasPositions s) => EventCallback c s -reapDeadPositions _ = do - ts <- view seLastTimestamp <$> getEnvironment - when (floor (utctDayTime ts) `mod` 300 == 0) $ modifyPositions (L.filter (not . posIsDead)) +reapDeadPositions _ = modifyPositions (L.filter (not . posIsDead)) defaultHandler :: (StateHasPositions s) => EventCallback c s defaultHandler = reapDeadPositions `also` handlePositions From 7f1b7bbaf996e9d4931bf7fa330e8b4235fed4d7 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Thu, 2 Dec 2021 22:23:04 +0700 Subject: [PATCH 22/25] appendToLog: take severity as argument --- .../Driver/Junction/RobotDriverThread.hs | 7 ++-- src/ATrade/RoboCom/Monad.hs | 3 +- src/ATrade/RoboCom/Positions.hs | 35 ++++++++++--------- 3 files changed, 25 insertions(+), 20 deletions(-) diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index d06554a..93b3ac4 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -15,6 +15,7 @@ module ATrade.Driver.Junction.RobotDriverThread onStrategyInstance, postNotificationEvent) where +import Prelude hiding (log) import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification)) import qualified ATrade.Driver.Junction.BrokerService as Bro import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), @@ -29,7 +30,7 @@ import ATrade.Driver.Junction.Types (BigConfig, strategyId, tickerId, timeframe) import ATrade.Logging (Message, logDebug, - logInfo, logWarning) + logInfo, logWarning, log) import ATrade.QuoteSource.Client (QuoteData (..)) import ATrade.RoboCom.ConfigStorage (ConfigStorage) import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderSubmitted, OrderUpdate), @@ -159,9 +160,9 @@ instance MonadRobot (RobotM c s) c s where bro <- asks brokerService liftIO . void $ Bro.cancelOrder bro oid - appendToLog t = do + appendToLog s t = do instId <- _seInstanceId <$> (asks env >>= liftIO . readIORef) - logInfo instId . TL.toStrict $ t + log s instId $ TL.toStrict t setupTimer t = do ref <- asks timersRef diff --git a/src/ATrade/RoboCom/Monad.hs b/src/ATrade/RoboCom/Monad.hs index 69eb915..399d16c 100644 --- a/src/ATrade/RoboCom/Monad.hs +++ b/src/ATrade/RoboCom/Monad.hs @@ -32,11 +32,12 @@ import qualified Data.Text.Lazy as TL import Data.Time.Clock import Language.Haskell.Printf import Language.Haskell.TH.Quote (QuasiQuoter) +import ATrade.Logging (Severity) class (Monad m) => MonadRobot m c s | m -> c, m -> s where submitOrder :: Order -> m OrderId cancelOrder :: OrderId -> m () - appendToLog :: TL.Text -> m () + appendToLog :: Severity -> TL.Text -> m () setupTimer :: UTCTime -> m () enqueueIOAction :: Int -> IO Value -> m () getConfig :: m c diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index c054608..4d9f1ad 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -78,6 +78,7 @@ import ATrade.Types import Control.Lens import Control.Monad +import ATrade.Logging (Severity (Trace, Warning)) import Data.Aeson import qualified Data.List as L import qualified Data.Text as T @@ -210,45 +211,49 @@ dispatchPosition event pos = case posState pos of cancelOrder $ orderId order return $ pos { posState = PositionWaitingPendingCancellation, posNextState = Just PositionCancelled } else do - appendToLog $ [t|Order executed (partially, %? / %?): %?|] (posBalance pos) (orderQuantity order) order + appendToLog Trace $ [t|Order executed (partially, %? / %?): %?|] (posBalance pos) (orderQuantity order) order return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs} else case event of OrderUpdate oid newstate -> if oid == orderId order then case newstate of Cancelled -> do - appendToLog $ [t|Order cancelled in PositionWaitingOpen: balance %d, max %d|] (posBalance pos) (orderQuantity order) + appendToLog Trace $ [t|Order cancelled in PositionWaitingOpen: balance %d, max %d|] (posBalance pos) (orderQuantity order) if posBalance pos /= 0 then return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posEntryTime = Just lastTs} else return pos { posState = PositionCancelled } Executed -> do - appendToLog $ [t|Order executed: %?|] order - return pos { posState = PositionOpen, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = balanceForOrder order, posEntryTime = Just lastTs} + appendToLog Trace $ [t|Order executed: %?|] order + return pos { posState = PositionOpen, + posCurrentOrder = Nothing, + posExecutionDeadline = Nothing, + posBalance = balanceForOrder order, + posEntryTime = Just lastTs } Rejected -> do - appendToLog $ [t|Order rejected: %?|] order + appendToLog Trace $ [t|Order rejected: %?|] order return pos { posState = PositionCancelled, posCurrentOrder = Nothing, posExecutionDeadline = Nothing, posBalance = 0, posEntryTime = Nothing } _ -> do - appendToLog $ [t|In PositionWaitingOpen: order state update: %?|] newstate + appendToLog Trace $ [t|In PositionWaitingOpen: order state update: %?|] newstate return pos else return pos -- Update for another position's order NewTrade trade -> do - appendToLog $ [t|Order new trade: %?/%?|] order trade + appendToLog Trace $ [t|Order new trade: %?/%?|] order trade return $ if tradeOrderId trade == orderId order then pos { posBalance = if tradeOperation trade == Buy then posBalance pos + tradeQuantity trade else posBalance pos - tradeQuantity trade } else pos _ -> return pos Nothing -> do - appendToLog $ [t|W: No current order in PositionWaitingOpen state: %?|] pos + appendToLog Warning $ [t|W: No current order in PositionWaitingOpen state: %?|] pos return pos handlePositionOpen = do lastTs <- view seLastTimestamp <$> getEnvironment if | orderDeadline (posSubmissionDeadline pos) lastTs -> do - appendToLog $ [t|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos) + appendToLog Warning $ [t|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos) return pos { posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing } | orderDeadline (posExecutionDeadline pos) lastTs -> do - appendToLog $ [t|PositionId: %? : Missed execution deadline: %?, remaining in PositionOpen state|] (posId pos) (posExecutionDeadline pos) + appendToLog Warning $ [t|PositionId: %? : Missed execution deadline: %?, remaining in PositionOpen state|] (posId pos) (posExecutionDeadline pos) return pos { posExecutionDeadline = Nothing } | otherwise -> case event of NewTick tick -> if @@ -283,7 +288,7 @@ dispatchPosition event pos = case posState pos of else return pos _ -> return pos else do - appendToLog "Deadline when cancelling pending order" + appendToLog Warning "Deadline when cancelling pending order" return pos { posState = PositionCancelled } handlePositionWaitingCloseSubmission pendingOrder = do @@ -310,7 +315,7 @@ dispatchPosition event pos = case posState pos of case posCurrentOrder pos of Just order -> cancelOrder (orderId order) _ -> doNothing - appendToLog $ [t|Was unable to close position, remaining balance: %?|] (posBalance pos) + appendToLog Warning $ [t|Was unable to close position, remaining balance: %?|] (posBalance pos) return $ pos { posState = PositionOpen, posSubmissionDeadline = Nothing, posExecutionDeadline = Nothing } -- TODO call TimeoutHandler if present else case (event, posCurrentOrder pos) of (OrderUpdate oid newstate, Just order) -> @@ -366,8 +371,6 @@ newPosition order account tickerId operation quantity submissionDeadline = do posExitTime = Nothing } modifyPositions (\p -> position : p) - positions <- getPositions <$> getState - appendToLog $ [t|All positions: %?|] positions return position reapDeadPositions :: (StateHasPositions s) => EventCallback c s @@ -510,7 +513,7 @@ enterAtLimitForTickerWithParams :: (StateHasPositions s, MonadRobot m c s) => Ti enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do lastTs <- view seLastTimestamp <$> getEnvironment oid <- submitOrder order - appendToLog $ [t|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) + appendToLog Trace $ [t|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) newPosition (order {orderId = oid}) account tickerId operation quantity 20 >>= modifyPosition (\p -> p { posExecutionDeadline = Just $ timeToCancel `addUTCTime` lastTs }) where @@ -580,7 +583,7 @@ exitAtLimit timeToCancel price position operationSignalName = do Just order -> cancelOrder (orderId order) Nothing -> doNothing oid <- submitOrder (closeOrder inst) - appendToLog $ [t|exitAtLimit: %?, deadline: %?|] (posTicker position) (timeToCancel `addUTCTime` lastTs) + appendToLog Trace $ [t|exitAtLimit: %?, deadline: %?|] (posTicker position) (timeToCancel `addUTCTime` lastTs) modifyPosition (\pos -> pos { posCurrentOrder = Nothing, posState = PositionWaitingCloseSubmission (closeOrder inst) { orderId = oid }, From a8641b71f3fb98a603b5e95473b22d3d70921589 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Thu, 2 Dec 2021 22:28:39 +0700 Subject: [PATCH 23/25] Dependencies cleanup --- robocom-zero.cabal | 17 +- src/ATrade/Quotes/Finam.hs | 362 ------------------------------------- 2 files changed, 1 insertion(+), 378 deletions(-) delete mode 100644 src/ATrade/Quotes/Finam.hs diff --git a/robocom-zero.cabal b/robocom-zero.cabal index c94e3bc..2b91f61 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -26,7 +26,6 @@ library , ATrade.Quotes , ATrade.Quotes.QHP , ATrade.Quotes.QTIS --- , ATrade.Driver.Real -- , ATrade.Driver.Backtest , ATrade.Driver.Junction , ATrade.Driver.Junction.Types @@ -44,17 +43,12 @@ library , libatrade >= 0.11.0.0 && < 0.12.0.0 , text , text-icu - , errors , lens , bytestring - , cassava , containers , time , vector - , wreq , safe - , parsec - , parsec-numbers , aeson , binary , binary-ieee754 @@ -65,32 +59,23 @@ library , th-printf , BoundedChan , monad-loops - , conduit , safe-exceptions , mtl , transformers - , list-extras , optparse-applicative - , split , signal - , random , hedis , gitrev , data-default , template-haskell - , unliftio - , monad-logger , bimap - , stm - , async , dhall , extra , co-log + , text-show default-language: Haskell2010 other-modules: ATrade.Exceptions --- , ATrade.Driver.Real.BrokerClientThread --- , ATrade.Driver.Real.QuoteSourceThread , ATrade.Driver.Types test-suite robots-test diff --git a/src/ATrade/Quotes/Finam.hs b/src/ATrade/Quotes/Finam.hs deleted file mode 100644 index c7b26dc..0000000 --- a/src/ATrade/Quotes/Finam.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module ATrade.Quotes.Finam ( - downloadFinamSymbols, - Symbol(..), - Period(..), - DateFormat(..), - TimeFormat(..), - FieldSeparator(..), - RequestParams(..), - defaultParams, - downloadQuotes, - parseQuotes, - downloadAndParseQuotes, - Row(..) -) 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 -import Data.Csv hiding (Options) -import Data.List -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.ICU.Convert as TC -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.Format -import qualified Data.Vector as V -import Network.Wreq -import Safe -import Text.Parsec -import Text.ParserCombinators.Parsec.Number - -data Period = - PeriodTick | - Period1Min | - Period5Min | - Period10Min | - Period15Min | - Period30Min | - PeriodHour | - PeriodDay | - PeriodWeek | - PeriodMonth - deriving (Show, Eq) - -instance Enum Period where - fromEnum PeriodTick = 1 - fromEnum Period1Min = 2 - fromEnum Period5Min = 3 - fromEnum Period10Min = 4 - fromEnum Period15Min = 5 - fromEnum Period30Min = 6 - fromEnum PeriodHour = 7 - fromEnum PeriodDay = 8 - fromEnum PeriodWeek = 9 - fromEnum PeriodMonth = 10 - - toEnum 1 = PeriodTick - toEnum 2 = Period1Min - toEnum 3 = Period5Min - toEnum 4 = Period10Min - toEnum 5 = Period15Min - toEnum 6 = Period30Min - toEnum 7 = PeriodHour - toEnum 8 = PeriodDay - toEnum 9 = PeriodWeek - toEnum 10 = PeriodMonth - toEnum _ = PeriodDay - -data DateFormat = - FormatYYYYMMDD | - FormatYYMMDD | - FormatDDMMYY | - FormatDD_MM_YY | - FormatMM_DD_YY - deriving (Show, Eq) - -instance Enum DateFormat where - fromEnum FormatYYYYMMDD = 1 - fromEnum FormatYYMMDD = 2 - fromEnum FormatDDMMYY = 3 - fromEnum FormatDD_MM_YY = 4 - fromEnum FormatMM_DD_YY = 5 - - toEnum 1 = FormatYYYYMMDD - toEnum 2 = FormatYYMMDD - toEnum 3 = FormatDDMMYY - toEnum 4 = FormatDD_MM_YY - toEnum 5 = FormatMM_DD_YY - toEnum _ = FormatYYYYMMDD - - -data TimeFormat = - FormatHHMMSS | - FormatHHMM | - FormatHH_MM_SS | - FormatHH_MM - deriving (Show, Eq) - -instance Enum TimeFormat where - fromEnum FormatHHMMSS = 1 - fromEnum FormatHHMM = 2 - fromEnum FormatHH_MM_SS = 3 - fromEnum FormatHH_MM = 4 - - toEnum 1 = FormatHHMMSS - toEnum 2 = FormatHHMM - toEnum 3 = FormatHH_MM_SS - toEnum 4 = FormatHH_MM - toEnum _ = FormatHHMMSS - -data FieldSeparator = - SeparatorComma | - SeparatorPeriod | - SeparatorSemicolon | - SeparatorTab | - SeparatorSpace - deriving (Show, Eq) - -instance Enum FieldSeparator where - fromEnum SeparatorComma = 1 - fromEnum SeparatorPeriod = 2 - fromEnum SeparatorSemicolon = 3 - fromEnum SeparatorTab = 4 - fromEnum SeparatorSpace = 5 - - toEnum 1 = SeparatorComma - toEnum 2 = SeparatorPeriod - toEnum 3 = SeparatorSemicolon - toEnum 4 = SeparatorTab - toEnum 5 = SeparatorSpace - toEnum _ = SeparatorComma - -data RequestParams = RequestParams { - ticker :: T.Text, - startDate :: Day, - endDate :: Day, - period :: Period, - dateFormat :: DateFormat, - timeFormat :: TimeFormat, - fieldSeparator :: FieldSeparator, - includeHeader :: Bool, - fillEmpty :: Bool -} - -defaultParams :: RequestParams -defaultParams = RequestParams { - ticker = "", - startDate = fromGregorian 1970 1 1, - endDate = fromGregorian 1970 1 1, - period = PeriodDay, - dateFormat = FormatYYYYMMDD, - timeFormat = FormatHHMMSS, - fieldSeparator = SeparatorComma, - includeHeader = True, - fillEmpty = False -} - -data Symbol = Symbol { - symCode :: T.Text, - symName :: T.Text, - symId :: Integer, - symMarketCode :: Integer, - symMarketName :: T.Text -} - deriving (Show, Eq) - -data Row = Row { - rowTicker :: T.Text, - rowTime :: UTCTime, - rowOpen :: Price, - rowHigh :: Price, - rowLow :: Price, - rowClose :: Price, - rowVolume :: Integer -} deriving (Show, Eq) - -instance FromField Price where - parseField s = fromDouble <$> (parseField s :: Parser Double) - -instance FromRecord Row where - parseRecord v - | length v == 9 = do - tkr <- v .! 0 - date <- v .! 2 - time <- v .! 3 - dt <- addUTCTime (-3 * 3600) <$> (parseDt date time) - open <- v .! 4 - high <- v .! 5 - low <- v .! 6 - close <- v .! 7 - vol <- v .! 8 - return $ Row tkr dt open high low close vol - | otherwise = mzero - where - parseDt :: B.ByteString -> B.ByteString -> Parser UTCTime - parseDt d t = case parseTimeM True defaultTimeLocale "%Y%m%d %H%M%S" $ B8.unpack d ++ " " ++ B8.unpack t of - Just dt -> return dt - Nothing -> fail "Unable to parse date/time" - -downloadAndParseQuotes :: (MonadIO m, HasLog env Msg m)RequestParams -> IO (Maybe [Row]) -downloadAndParseQuotes requestParams = downloadAndParseQuotes' 3 - where - downloadAndParseQuotes' iter = do - raw <- downloadQuotes requestParams `catch` (\e -> do - debugM "History" $ "exception: " ++ show (e :: SomeException) - return Nothing) - case raw of - Just r -> return $ parseQuotes r - Nothing -> if iter <= 0 then return Nothing else downloadAndParseQuotes' (iter - 1) - -parseQuotes :: B.ByteString -> Maybe [Row] -parseQuotes csvData = case decode HasHeader $ BL.fromStrict csvData of - Left _ -> Nothing - Right d -> Just $ V.toList d - -downloadQuotes :: RequestParams -> IO (Maybe B.ByteString) -downloadQuotes requestParams = do - symbols <- downloadFinamSymbols - case requestUrl symbols requestParams of - Just (url, options') -> do - resp <- getWith options' url - return $ Just $ BL.toStrict $ resp ^. responseBody - Nothing -> return Nothing - -requestUrl :: [Symbol] -> RequestParams -> Maybe (String, Options) -requestUrl symbols requestParams = case getFinamCode symbols (ticker requestParams) of - Just (sym, market) -> Just ("http://export.finam.ru/export9.out", getOptions sym market) - Nothing -> Nothing - where - getOptions sym market = defaults & - param "market" .~ [T.pack . show $ market] & - param "f" .~ [ticker requestParams] & - param "e" .~ [".csv"] & - param "dtf" .~ [T.pack . show . fromEnum . dateFormat $ requestParams] & - param "tmf" .~ [T.pack . show . fromEnum . dateFormat $ requestParams] & - param "MSOR" .~ ["0"] & - param "mstime" .~ ["on"] & - param "mstimever" .~ ["1"] & - param "sep" .~ [T.pack . show . fromEnum . fieldSeparator $ requestParams] & - param "sep2" .~ ["1"] & - param "at" .~ [if includeHeader requestParams then "1" else "0"] & - param "fsp" .~ [if fillEmpty requestParams then "1" else "0"] & - param "p" .~ [T.pack . show . fromEnum $ period requestParams] & - param "em" .~ [T.pack . show $ sym ] & - param "df" .~ [T.pack . show $ dayFrom] & - param "mf" .~ [T.pack . show $ (monthFrom - 1)] & - param "yf" .~ [T.pack . show $ yearFrom] & - param "dt" .~ [T.pack . show $ dayTo] & - param "mt" .~ [T.pack . show $ (monthTo - 1)] & - param "yt" .~ [T.pack . show $ yearTo] & - param "code" .~ [ticker requestParams] & - param "datf" .~ if period requestParams == PeriodTick then ["11"] else ["1"] - (yearFrom, monthFrom, dayFrom) = toGregorian $ startDate requestParams - (yearTo, monthTo, dayTo) = toGregorian $ endDate requestParams - -getFinamCode :: [Symbol] -> T.Text -> Maybe (Integer, Integer) -getFinamCode symbols tickerCode = case find (\x -> symCode x == tickerCode && symMarketCode x `notElem` archives) symbols of - Just sym -> Just (symId sym, symMarketCode sym) - Nothing -> Nothing - -downloadFinamSymbols :: IO [Symbol] -downloadFinamSymbols = do - conv <- TC.open "cp1251" Nothing - result <- get "http://www.finam.ru/cache/icharts/icharts.js" - if result ^. responseStatus . statusCode == 200 - then return $ parseSymbols . T.lines $ TC.toUnicode conv $ BL.toStrict $ result ^. responseBody - else return [] - where - parseSymbols :: [T.Text] -> [Symbol] - parseSymbols strs = zipWith5 Symbol codes names ids marketCodes marketNames - where - getWithParser parser pos = fromMaybe [] $ do - s <- T.unpack <$> strs `atMay` pos - hush $ parse parser "" s - - ids :: [Integer] - ids = getWithParser intlist 0 - - names :: [T.Text] - names = T.pack <$> getWithParser strlist 1 - - codes :: [T.Text] - codes = T.pack <$> getWithParser strlist 2 - - marketCodes :: [Integer] - marketCodes = getWithParser intlist 3 - - marketNames :: [T.Text] - marketNames = fmap (\code -> fromMaybe "" $ M.lookup code codeToName) marketCodes - - intlist = do - _ <- string "var" - spaces - skipMany1 alphaNum - spaces - _ <- char '=' - spaces - _ <- char '[' - manyTill (do - i <- int - _ <- char ',' <|> char ']' - return i) (char '\'' <|> char ';') - - strlist = do - _ <- string "var" - spaces - skipMany1 alphaNum - spaces - _ <- char '=' - spaces - _ <- char '[' - (char '\'' >> manyTill ((char '\\' >> char '\'') <|> anyChar) (char '\'')) `sepBy` char ',' - -codeToName :: M.Map Integer T.Text -codeToName = M.fromList [ - (200, "МосБиржа топ"), - (1 , "МосБиржа акции"), - (14 , "МосБиржа фьючерсы"), - (41, "Курс рубля"), - (45, "МосБиржа валютный рынок"), - (2, "МосБиржа облигации"), - (12, "МосБиржа внесписочные облигации"), - (29, "МосБиржа пифы"), - (8, "Расписки"), - (6, "Мировые Индексы"), - (24, "Товары"), - (5, "Мировые валюты"), - (25, "Акции США(BATS)"), - (7, "Фьючерсы США"), - (27, "Отрасли экономики США"), - (26, "Гособлигации США"), - (28, "ETF"), - (30, "Индексы мировой экономики"), - (3, "РТС"), - (20, "RTS Board"), - (10, "РТС-GAZ"), - (17, "ФОРТС Архив"), - (31, "Сырье Архив"), - (38, "RTS Standard Архив"), - (16, "ММВБ Архив"), - (18, "РТС Архив"), - (9, "СПФБ Архив"), - (32, "РТС-BOARD Архив"), - (39, "Расписки Архив"), - (-1, "Отрасли") ] - - -archives :: [Integer] -archives = [3, 8, 16, 17, 18, 31, 32, 38, 39, 517] From 610a67f9aff25b08f7f983c5981e0ad478b25b57 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Fri, 3 Dec 2021 00:21:05 +0700 Subject: [PATCH 24/25] Get rid of ParamsHasMainTicker --- src/ATrade/Driver/Junction.hs | 50 +++++++++++-------- .../Driver/Junction/RobotDriverThread.hs | 12 +++-- src/ATrade/RoboCom/Monad.hs | 10 +++- src/ATrade/RoboCom/Positions.hs | 33 ++++++------ 4 files changed, 63 insertions(+), 42 deletions(-) diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index a136ba6..f832c86 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -38,9 +38,12 @@ import ATrade.Driver.Junction.Types (StrategyDescriptor StrategyInstance (strategyInstanceId), StrategyInstanceDescriptor (..), confStrategy, + confTickers, strategyState, - strategyTimers) -import ATrade.Logging (Message, Severity (Debug, Info, Trace, Warning), + strategyTimers, + tickerId, + timeframe) +import ATrade.Logging (Message, Severity (Debug, Error, Info, Trace, Warning), fmtMessage, logWarning, logWith) @@ -48,7 +51,8 @@ import ATrade.Quotes.QHP (mkQHPHandle) import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) import ATrade.RoboCom.Monad (StrategyEnvironment (..)) import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) -import ATrade.RoboCom.Types (Bars) +import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), + Bars) import ATrade.Types (ClientSecurityParams (ClientSecurityParams), OrderId, Trade (tradeOrderId)) @@ -74,6 +78,7 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.Map.Strict as M import Data.Set (notMember) import qualified Data.Set as S @@ -238,25 +243,30 @@ junctionMain descriptors = do case M.lookup (strategyBaseName inst) descriptors of Just (StrategyDescriptorE desc) -> do bigConf <- loadConfig (configKey inst) - rConf <- liftIO $ newIORef (confStrategy bigConf) - rState <- loadState (stateKey inst) >>= liftIO . newIORef - rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef - localH <- liftIO $ openFile (logBasePath cfg <> "/" <> T.unpack (strategyId inst) <> ".log") AppendMode - liftIO $ hSetBuffering localH LineBuffering - let robotLogAction = logger logHandle <> (fmtMessage >$< logTextHandle localH) - stratEnv <- liftIO $ newIORef StrategyEnvironment - { - _seInstanceId = strategyId inst, - _seAccount = "test", -- TODO configure - _seVolume = 1, - _seLastTimestamp = now - } - let robotEnv = RobotEnv rState rConf rTimers barsMap stratEnv robotLogAction broService - 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, ())) + case confTickers bigConf of + (firstTicker:restTickers) -> do + rConf <- liftIO $ newIORef (confStrategy bigConf) + rState <- loadState (stateKey inst) >>= liftIO . newIORef + rTimers <- loadState (stateKey inst <> ":timers") >>= liftIO . newIORef + localH <- liftIO $ openFile (logBasePath cfg <> "/" <> T.unpack (strategyId inst) <> ".log") AppendMode + liftIO $ hSetBuffering localH LineBuffering + let robotLogAction = logger logHandle <> (fmtMessage >$< logTextHandle localH) + stratEnv <- liftIO $ newIORef StrategyEnvironment + { + _seInstanceId = strategyId inst, + _seAccount = "test", -- TODO configure + _seVolume = 1, + _seLastTimestamp = now + } + let robotEnv = RobotEnv rState rConf rTimers barsMap stratEnv robotLogAction broService (toBarSeriesId <$> (firstTicker :| restTickers)) + 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, ())) + _ -> logWith (logger logHandle) Error (strategyId inst) $ "No tickers configured !!!" Nothing -> error "Unknown strategy" + toBarSeriesId t = BarSeriesId (tickerId t) (timeframe t) + withJunction :: JunctionEnv -> JunctionM () -> IO () withJunction env = (`runReaderT` env) . unJunctionM diff --git a/src/ATrade/Driver/Junction/RobotDriverThread.hs b/src/ATrade/Driver/Junction/RobotDriverThread.hs index 93b3ac4..ae40d36 100644 --- a/src/ATrade/Driver/Junction/RobotDriverThread.hs +++ b/src/ATrade/Driver/Junction/RobotDriverThread.hs @@ -15,7 +15,6 @@ module ATrade.Driver.Junction.RobotDriverThread onStrategyInstance, postNotificationEvent) where -import Prelude hiding (log) import ATrade.Broker.Protocol (Notification (OrderNotification, TradeNotification)) import qualified ATrade.Driver.Junction.BrokerService as Bro import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription), @@ -29,8 +28,8 @@ import ATrade.Driver.Junction.Types (BigConfig, eventCallback, stateKey, strategyId, tickerId, timeframe) -import ATrade.Logging (Message, logDebug, - logInfo, logWarning, log) +import ATrade.Logging (Message, log, logDebug, + logInfo, logWarning) import ATrade.QuoteSource.Client (QuoteData (..)) import ATrade.RoboCom.ConfigStorage (ConfigStorage) import ATrade.RoboCom.Monad (Event (NewBar, NewTick, NewTrade, OrderSubmitted, OrderUpdate), @@ -57,10 +56,12 @@ import Data.Default import Data.IORef (IORef, atomicModifyIORef', readIORef, writeIORef) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import qualified Data.Text.Lazy as TL import Data.Time (UTCTime, getCurrentTime) import Dhall (FromDhall) +import Prelude hiding (log) data RobotDriverHandle = forall c s. (FromDhall c, Default s, FromJSON s, ToJSON s) => RobotDriverHandle (StrategyInstance c s) ThreadId ThreadId (BoundedChan RobotDriverEvent) @@ -140,7 +141,8 @@ data RobotEnv c s = bars :: IORef Bars, env :: IORef StrategyEnvironment, logAction :: LogAction (RobotM c s) Message, - brokerService :: Bro.BrokerService + brokerService :: Bro.BrokerService, + tickers :: NonEmpty BarSeriesId } newtype RobotM c s a = RobotM { unRobotM :: ReaderT (RobotEnv c s) IO a } @@ -181,6 +183,8 @@ instance MonadRobot (RobotM c s) c s where b <- asks bars >>= liftIO . readIORef return $ M.lookup (BarSeriesId tid tf) b + getAvailableTickers = asks tickers + postNotificationEvent :: (MonadIO m) => RobotDriverHandle -> Notification -> m () postNotificationEvent (RobotDriverHandle _ _ _ eventQueue) notification = liftIO $ case notification of diff --git a/src/ATrade/RoboCom/Monad.hs b/src/ATrade/RoboCom/Monad.hs index 399d16c..c30c18c 100644 --- a/src/ATrade/RoboCom/Monad.hs +++ b/src/ATrade/RoboCom/Monad.hs @@ -19,8 +19,8 @@ module ATrade.RoboCom.Monad ( MonadRobot(..), also, t, - st -) where + st, + getFirstTickerId) where import ATrade.RoboCom.Types import ATrade.Types @@ -33,6 +33,8 @@ import Data.Time.Clock import Language.Haskell.Printf import Language.Haskell.TH.Quote (QuasiQuoter) import ATrade.Logging (Severity) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE class (Monad m) => MonadRobot m c s | m -> c, m -> s where submitOrder :: Order -> m OrderId @@ -49,6 +51,10 @@ class (Monad m) => MonadRobot m c s | m -> c, m -> s where setState (f oldState) getEnvironment :: m StrategyEnvironment getTicker :: TickerId -> BarTimeframe -> m (Maybe BarSeries) + getAvailableTickers :: m (NonEmpty BarSeriesId) + +getFirstTickerId :: forall c s m. (Monad m, MonadRobot m c s) => m BarSeriesId +getFirstTickerId = NE.head <$> getAvailableTickers st :: QuasiQuoter st = t diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index 4d9f1ad..c71d8bf 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -20,7 +20,6 @@ module ATrade.RoboCom.Positions ( StateHasPositions(..), - ParamsHasMainTicker(..), PositionState(..), Position(..), posIsOpen, @@ -79,8 +78,10 @@ import Control.Lens import Control.Monad import ATrade.Logging (Severity (Trace, Warning)) +import ATrade.RoboCom.Monad (MonadRobot (getAvailableTickers)) import Data.Aeson import qualified Data.List as L +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time.Clock @@ -389,17 +390,17 @@ modifyPosition f oldpos = do return $ f oldpos Nothing -> return oldpos -getCurrentTicker :: (ParamsHasMainTicker c, MonadRobot m c s) => m [Bar] +getCurrentTicker :: (MonadRobot m c s) => m [Bar] getCurrentTicker = do - (tf, mainTicker') <- mainTicker <$> getConfig + (BarSeriesId mainTicker' tf) <- NE.head <$> getAvailableTickers maybeBars <- getTicker mainTicker' tf case maybeBars of Just b -> return $ bsBars b _ -> return [] -getCurrentTickerSeries :: (ParamsHasMainTicker c, MonadRobot m c s) => m (Maybe BarSeries) +getCurrentTickerSeries :: (MonadRobot m c s) => m (Maybe BarSeries) getCurrentTickerSeries = do - (tf, mainTicker') <- mainTicker <$> getConfig + (BarSeriesId mainTicker' tf) <- NE.head <$> getAvailableTickers getTicker mainTicker' tf getLastActivePosition :: (StateHasPositions s, MonadRobot m c s) => m (Maybe Position) @@ -460,14 +461,14 @@ onActionCompletedEvent event f = case event of ActionCompleted tag v -> f tag v _ -> doNothing -enterAtMarket :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Operation -> m Position +enterAtMarket :: (StateHasPositions s, MonadRobot m c s) => T.Text -> Operation -> m Position enterAtMarket operationSignalName operation = do env <- getEnvironment enterAtMarketWithParams (env ^. seAccount) (env ^. seVolume) (SignalId (env ^. seInstanceId) operationSignalName "") operation -enterAtMarketWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position +enterAtMarketWithParams :: (StateHasPositions s, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position enterAtMarketWithParams account quantity signalId operation = do - tickerId <- snd . mainTicker <$> getConfig + BarSeriesId tickerId _ <- getFirstTickerId oid <- submitOrder $ order tickerId newPosition ((order tickerId) { orderId = oid }) account tickerId operation quantity 20 where @@ -480,20 +481,20 @@ enterAtMarketWithParams account quantity signalId operation = do orderSignalId = signalId } -enterAtLimit :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Operation -> m Position +enterAtLimit :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Operation -> m Position enterAtLimit timeToCancel operationSignalName price operation = do env <- getEnvironment enterAtLimitWithParams timeToCancel (env ^. seAccount) (env ^. seVolume) (SignalId (env ^. seInstanceId) operationSignalName "") price operation -enterAtLimitWithVolume :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position +enterAtLimitWithVolume :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position enterAtLimitWithVolume timeToCancel operationSignalName price vol operation = do acc <- view seAccount <$> getEnvironment inst <- view seInstanceId <$> getEnvironment enterAtLimitWithParams timeToCancel acc vol (SignalId inst operationSignalName "") price operation -enterAtLimitWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position +enterAtLimitWithParams :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position enterAtLimitWithParams timeToCancel account quantity signalId price operation = do - tickerId <- snd . mainTicker <$> getConfig + BarSeriesId tickerId _ <- getFirstTickerId enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation enterAtLimitForTickerWithVolume :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position @@ -526,19 +527,19 @@ enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId orderSignalId = signalId } -enterLongAtMarket :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> m Position +enterLongAtMarket :: (StateHasPositions s, MonadRobot m c s) => T.Text -> m Position enterLongAtMarket operationSignalName = enterAtMarket operationSignalName Buy -enterShortAtMarket :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> m Position +enterShortAtMarket :: (StateHasPositions s, MonadRobot m c s) => T.Text -> m Position enterShortAtMarket operationSignalName = enterAtMarket operationSignalName Sell -enterLongAtLimit :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> Price -> T.Text -> m Position +enterLongAtLimit :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> Price -> T.Text -> m Position enterLongAtLimit timeToCancel price operationSignalName = enterAtLimit timeToCancel operationSignalName price Buy enterLongAtLimitForTicker :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> Price -> T.Text -> m Position enterLongAtLimitForTicker tickerId timeToCancel price operationSignalName = enterAtLimitForTicker tickerId timeToCancel operationSignalName price Buy -enterShortAtLimit :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> Price -> T.Text -> m Position +enterShortAtLimit :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> Price -> T.Text -> m Position enterShortAtLimit timeToCancel price operationSignalName = enterAtLimit timeToCancel operationSignalName price Sell enterShortAtLimitForTicker :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> Price -> T.Text -> m Position From 4d82a19cc6b561b18fcd15f52fed04b677fec8bb Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sun, 12 Dec 2021 18:46:51 +0700 Subject: [PATCH 25/25] junction: account configuration --- robocom-zero.cabal | 2 +- src/ATrade/Driver/Junction.hs | 4 ++-- src/ATrade/Driver/Junction/QuoteThread.hs | 12 +++++++----- src/ATrade/Driver/Junction/Types.hs | 1 + 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/robocom-zero.cabal b/robocom-zero.cabal index 2b91f61..04fd3b6 100644 --- a/robocom-zero.cabal +++ b/robocom-zero.cabal @@ -40,7 +40,7 @@ library , ATrade.Quotes.TickerInfoProvider other-modules: Paths_robocom_zero build-depends: base >= 4.7 && < 5 - , libatrade >= 0.11.0.0 && < 0.12.0.0 + , libatrade >= 0.12.0.0 && < 0.13.0.0 , text , text-icu , lens diff --git a/src/ATrade/Driver/Junction.hs b/src/ATrade/Driver/Junction.hs index f832c86..45276be 100644 --- a/src/ATrade/Driver/Junction.hs +++ b/src/ATrade/Driver/Junction.hs @@ -204,7 +204,7 @@ junctionMain descriptors = do ordersMap <- newIORef M.empty handledNotifications <- newIORef S.empty withBroker cfg ctx robotsMap ordersMap handledNotifications (logger h) $ \bro -> - withQThread downloaderEnv barsMap cfg ctx $ \qt -> do + withQThread downloaderEnv barsMap cfg ctx (logger h) $ \qt -> do broService <- mkBrokerService bro ordersMap let junctionLogAction = logger h let env = @@ -254,7 +254,7 @@ junctionMain descriptors = do stratEnv <- liftIO $ newIORef StrategyEnvironment { _seInstanceId = strategyId inst, - _seAccount = "test", -- TODO configure + _seAccount = accountId inst, _seVolume = 1, _seLastTimestamp = now } diff --git a/src/ATrade/Driver/Junction/QuoteThread.hs b/src/ATrade/Driver/Junction/QuoteThread.hs index bd3090f..baa5230 100644 --- a/src/ATrade/Driver/Junction/QuoteThread.hs +++ b/src/ATrade/Driver/Junction/QuoteThread.hs @@ -92,11 +92,12 @@ startQuoteThread :: (MonadIO m, T.Text -> ClientSecurityParams -> (m1 () -> IO ()) -> + LogAction IO Message -> m QuoteThreadHandle -startQuoteThread barsRef ctx ep secparams downloadThreadRunner = do +startQuoteThread barsRef ctx ep secparams downloadThreadRunner logger = do chan <- liftIO $ newBoundedChan 2000 dChan <- liftIO $ newBoundedChan 2000 - qsc <- liftIO $ startQuoteSourceClient chan [] ctx ep secparams + qsc <- liftIO $ startQuoteSourceClient chan [] ctx ep secparams logger env <- liftIO $ QuoteThreadEnv barsRef <$> newIORef HM.empty <*> pure qsc <*> newIORef M.empty <*> pure dChan tid <- liftIO . forkIO $ quoteThread env chan downloaderTid <- liftIO . forkIO $ downloadThreadRunner (downloaderThread env dChan) @@ -199,8 +200,8 @@ instance TickerInfoProvider DownloaderM where (fromInteger $ tiLotSize ti) (tiTickSize ti) -withQThread :: DownloaderEnv -> IORef Bars -> ProgramConfiguration -> Context -> (QuoteThreadHandle -> IO ()) -> IO () -withQThread env barsMap cfg ctx f = do +withQThread :: DownloaderEnv -> IORef Bars -> ProgramConfiguration -> Context -> LogAction IO Message -> (QuoteThreadHandle -> IO ()) -> IO () +withQThread env barsMap cfg ctx logger f = do securityParameters <- loadSecurityParameters bracket (startQuoteThread @@ -208,7 +209,8 @@ withQThread env barsMap cfg ctx f = do ctx (quotesourceEndpoint cfg) securityParameters - (runDownloaderM env)) + (runDownloaderM env) + logger) stopQuoteThread f where loadSecurityParameters = diff --git a/src/ATrade/Driver/Junction/Types.hs b/src/ATrade/Driver/Junction/Types.hs index d16f76e..8054daf 100644 --- a/src/ATrade/Driver/Junction/Types.hs +++ b/src/ATrade/Driver/Junction/Types.hs @@ -56,6 +56,7 @@ instance (FromDhall c) => FromDhall (BigConfig c) data StrategyInstanceDescriptor = StrategyInstanceDescriptor { + accountId :: T.Text, strategyId :: T.Text, strategyBaseName :: T.Text, configKey :: T.Text,