From c424dc217a0da2af6e87bb1f336e4ee81dd0e3c6 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 20 Nov 2021 19:33:03 +0700 Subject: [PATCH] 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" "" - } - -