Compare commits
46 Commits
24 changed files with 1642 additions and 763 deletions
@ -0,0 +1,258 @@
@@ -0,0 +1,258 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
||||
{-# LANGUAGE MultiParamTypeClasses #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
|
||||
module ATrade.Driver.Junction.JunctionMonad |
||||
( |
||||
JunctionEnv(..), |
||||
JunctionM(..), |
||||
startRobot, |
||||
saveRobots, |
||||
reloadConfig, |
||||
getState, |
||||
setState |
||||
) where |
||||
|
||||
import ATrade.Broker.Client (BrokerClientHandle) |
||||
import ATrade.Driver.Junction.BrokerService (BrokerService) |
||||
import ATrade.Driver.Junction.ProgramConfiguration (ProgramConfiguration (logBasePath)) |
||||
import ATrade.Driver.Junction.QuoteStream (QuoteStream (addSubscription, removeSubscription), |
||||
QuoteSubscription (QuoteSubscription)) |
||||
import ATrade.Driver.Junction.QuoteThread (QuoteThreadHandle) |
||||
import qualified ATrade.Driver.Junction.QuoteThread as QT |
||||
import ATrade.Driver.Junction.RobotDriverThread (RobotDriverHandle, RobotEnv (RobotEnv), |
||||
RobotM (unRobotM), |
||||
createRobotDriverThread, |
||||
getInstanceDescriptor, |
||||
onStrategyInstance, |
||||
onStrategyInstanceM) |
||||
import ATrade.Driver.Junction.Types (StrategyDescriptorE (StrategyDescriptorE), |
||||
StrategyInstanceDescriptor, |
||||
accountId, |
||||
confStrategy, |
||||
confTickers, |
||||
configKey, |
||||
stateKey, |
||||
strategyBaseName, |
||||
strategyConfig, |
||||
strategyId, |
||||
strategyInstanceId, |
||||
strategyState, |
||||
strategyTimers, |
||||
tickerId, |
||||
timeframe) |
||||
import ATrade.Logging (Message, Severity (Error, Info), |
||||
fmtMessage, |
||||
logWarning, |
||||
logWith) |
||||
import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig)) |
||||
import ATrade.RoboCom.Monad (StrategyEnvironment (..)) |
||||
import ATrade.RoboCom.Persistence (MonadPersistence (loadState, saveState)) |
||||
import ATrade.RoboCom.Types (BarSeriesId (BarSeriesId), |
||||
Bars, |
||||
TickerInfoMap) |
||||
import Colog (HasLog (getLogAction, setLogAction), |
||||
LogAction, |
||||
hoistLogAction, |
||||
logTextHandle, |
||||
(>$<)) |
||||
import Control.Exception.Safe (finally) |
||||
import Control.Monad.Reader (MonadIO (liftIO), |
||||
MonadReader, |
||||
ReaderT (runReaderT), |
||||
asks) |
||||
import Data.Aeson (decode, |
||||
eitherDecode, |
||||
encode) |
||||
import qualified Data.ByteString as B |
||||
import qualified Data.ByteString.Lazy as BL |
||||
import Data.Default (Default (def)) |
||||
import Data.Foldable (traverse_) |
||||
import Data.IORef (IORef, |
||||
atomicModifyIORef', |
||||
newIORef, |
||||
readIORef, |
||||
writeIORef) |
||||
import Data.List.NonEmpty (NonEmpty ((:|))) |
||||
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 (getCurrentTime) |
||||
import Data.Time.Clock.POSIX (getPOSIXTime) |
||||
import Database.Redis (Connection, get, |
||||
mset, runRedis) |
||||
import Dhall (auto, input) |
||||
import Prelude hiding (log, |
||||
readFile) |
||||
import System.IO (BufferMode (LineBuffering), |
||||
IOMode (AppendMode), |
||||
hClose, |
||||
hSetBuffering, |
||||
openFile) |
||||
import System.ZMQ4 (Router, Socket) |
||||
import UnliftIO (MonadUnliftIO) |
||||
import UnliftIO.Exception (catchAny, |
||||
onException) |
||||
|
||||
data JunctionEnv = |
||||
JunctionEnv |
||||
{ |
||||
peRedisSocket :: Connection, |
||||
peConfigPath :: FilePath, |
||||
peQuoteThread :: QuoteThreadHandle, |
||||
peBroker :: BrokerClientHandle, |
||||
peRobots :: IORef (M.Map T.Text RobotDriverHandle), |
||||
peRemoteControlSocket :: Socket Router, |
||||
peLogAction :: LogAction JunctionM Message, |
||||
peIoLogAction :: LogAction IO Message, |
||||
peProgramConfiguration :: ProgramConfiguration, |
||||
peBarsMap :: IORef Bars, |
||||
peTickerInfoMap :: IORef TickerInfoMap, |
||||
peBrokerService :: BrokerService, |
||||
peDescriptors :: M.Map T.Text StrategyDescriptorE |
||||
} |
||||
|
||||
newtype JunctionM a = JunctionM { unJunctionM :: ReaderT JunctionEnv IO a } |
||||
deriving (Functor, Applicative, Monad, MonadReader JunctionEnv, MonadIO, MonadUnliftIO) |
||||
|
||||
instance HasLog JunctionEnv Message JunctionM where |
||||
getLogAction = peLogAction |
||||
setLogAction a e = e { peLogAction = a } |
||||
|
||||
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 JunctionM 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 _ -> logWarning "Junction " "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 |
||||
logWarning "Junction" "Unable to load state" |
||||
return def |
||||
Right maybeRawState -> |
||||
case maybeRawState of |
||||
Just rawState -> case eitherDecode $ BL.fromStrict rawState of |
||||
Left _ -> do |
||||
logWarning "Junction" "Unable to decode state" |
||||
return def |
||||
Right decodedState -> return decodedState |
||||
Nothing -> do |
||||
logWarning "Junction" "Unable to decode state" |
||||
return def |
||||
|
||||
instance QuoteStream JunctionM where |
||||
addSubscription (QuoteSubscription ticker tf) chan = do |
||||
qt <- asks peQuoteThread |
||||
QT.addSubscription qt ticker tf chan |
||||
removeSubscription subId = do |
||||
qt <- asks peQuoteThread |
||||
QT.removeSubscription qt subId |
||||
|
||||
startRobot :: StrategyInstanceDescriptor -> JunctionM () |
||||
startRobot inst = do |
||||
ioLogger <- asks peIoLogAction |
||||
descriptors <- asks peDescriptors |
||||
cfg <- asks peProgramConfiguration |
||||
barsMap <- asks peBarsMap |
||||
tickerInfoMap <- asks peTickerInfoMap |
||||
broService <- asks peBrokerService |
||||
now <- liftIO getCurrentTime |
||||
let lLogger = hoistLogAction liftIO ioLogger |
||||
logWith lLogger Info "Junction" $ "Starting strategy: " <> strategyBaseName inst |
||||
case M.lookup (strategyBaseName inst) descriptors of |
||||
Just (StrategyDescriptorE desc) -> flip catchAny (\e -> logWith lLogger Error "Junction" $ "Exception: " <> (T.pack . show $ e)) $ do |
||||
bigConf <- loadConfig (configKey inst) |
||||
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 = hoistLogAction liftIO ioLogger <> (fmtMessage >$< logTextHandle localH) |
||||
stratEnv <- liftIO $ newIORef StrategyEnvironment |
||||
{ |
||||
_seInstanceId = strategyId inst, |
||||
_seAccount = accountId inst, |
||||
_seVolume = 1, |
||||
_seLastTimestamp = now |
||||
} |
||||
let robotEnv = |
||||
RobotEnv rState rConf rTimers barsMap tickerInfoMap stratEnv robotLogAction broService (toBarSeriesId <$> (firstTicker :| restTickers)) |
||||
robot <- createRobotDriverThread inst desc (\a -> (flip runReaderT robotEnv . unRobotM) a `finally` hClose localH) bigConf rConf rState rTimers |
||||
robotsMap' <- asks peRobots |
||||
liftIO $ atomicModifyIORef' robotsMap' (\s -> (M.insert (strategyId inst) robot s, ())) |
||||
_ -> logWith lLogger Error (strategyId inst) "No tickers configured !!!" |
||||
Nothing -> logWith lLogger Error "Junction" $ "Unknown strategy: " <> strategyBaseName inst |
||||
|
||||
where |
||||
toBarSeriesId t = BarSeriesId (tickerId t) (timeframe t) |
||||
|
||||
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) |
||||
currentTimers <- liftIO $ readIORef (strategyTimers inst) |
||||
saveState currentTimers (strategyInstanceId inst <> ":timers") |
||||
|
||||
reloadConfig :: T.Text -> JunctionM (Either T.Text ()) |
||||
reloadConfig instId = flip catchAny (\_ -> return $ Left "Exception") $ do |
||||
robotsMap' <- asks peRobots |
||||
robots <- liftIO $ readIORef robotsMap' |
||||
case M.lookup instId robots of |
||||
Just robot -> do |
||||
onStrategyInstanceM robot |
||||
(\inst -> do |
||||
let instDesc = getInstanceDescriptor robot |
||||
bigConf <- loadConfig (configKey instDesc) |
||||
liftIO $ writeIORef (strategyConfig inst) (confStrategy bigConf)) |
||||
return $ Right () |
||||
Nothing -> return $ Left "Unable to load config" |
||||
|
||||
getState :: T.Text -> JunctionM (Either T.Text B.ByteString) |
||||
getState instId = do |
||||
robotsMap' <- asks peRobots |
||||
robots <- liftIO $ readIORef robotsMap' |
||||
case M.lookup instId robots of |
||||
Just robot -> do |
||||
Right <$> onStrategyInstanceM robot |
||||
(\inst -> do |
||||
v <- liftIO $ readIORef (strategyState inst) |
||||
return $ BL.toStrict $ encode v) |
||||
Nothing -> return $ Left $ "Unknown robot: " <> instId |
||||
|
||||
setState :: T.Text -> B.ByteString -> JunctionM (Either T.Text ()) |
||||
setState instId newState = do |
||||
robotsMap' <- asks peRobots |
||||
robots <- liftIO $ readIORef robotsMap' |
||||
case M.lookup instId robots of |
||||
Just robot -> do |
||||
onStrategyInstanceM robot |
||||
(\inst -> do |
||||
case decode . BL.fromStrict $ newState of |
||||
Just newS -> do |
||||
liftIO $ writeIORef (strategyState inst) newS |
||||
return $ Right () |
||||
Nothing -> return $ Left $ "Unable to decode state for " <> instId) |
||||
Nothing -> return $ Left $ "Unknown robot: " <> instId |
||||
@ -0,0 +1,151 @@
@@ -0,0 +1,151 @@
|
||||
{-# LANGUAGE FlexibleContexts #-} |
||||
{-# LANGUAGE MultiWayIf #-} |
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module ATrade.Driver.Junction.RemoteControl |
||||
( |
||||
handleRemoteControl |
||||
) where |
||||
|
||||
import ATrade.Driver.Junction.JunctionMonad (JunctionEnv (peLogAction, peRemoteControlSocket, peRobots), |
||||
JunctionM, getState, |
||||
reloadConfig, |
||||
setState, startRobot) |
||||
import ATrade.Driver.Junction.RobotDriverThread (stopRobot) |
||||
import ATrade.Driver.Junction.Types (StrategyInstanceDescriptor) |
||||
import ATrade.Logging (Severity (Info), |
||||
logErrorWith, |
||||
logWith) |
||||
import Control.Monad (unless) |
||||
import Control.Monad.Reader (asks) |
||||
import Data.Aeson (decode) |
||||
import qualified Data.ByteString as B |
||||
import qualified Data.ByteString.Lazy as BL |
||||
import Data.List.NonEmpty (NonEmpty ((:|))) |
||||
import qualified Data.Map.Strict as M |
||||
import qualified Data.Text as T |
||||
import Data.Text.Encoding (decodeUtf8', |
||||
encodeUtf8) |
||||
import System.ZMQ4 (Event (In), |
||||
Poll (Sock), poll, |
||||
receiveMulti, |
||||
sendMulti) |
||||
import UnliftIO (MonadIO (liftIO), |
||||
atomicModifyIORef', |
||||
readIORef) |
||||
|
||||
data RemoteControlResponse = |
||||
ResponseOk |
||||
| ResponseError T.Text |
||||
| ResponseData B.ByteString |
||||
deriving (Show, Eq) |
||||
|
||||
data RemoteControlRequest = |
||||
StartRobot StrategyInstanceDescriptor |
||||
| StopRobot T.Text |
||||
| ReloadConfig T.Text |
||||
| GetState T.Text |
||||
| SetState T.Text B.ByteString |
||||
| Ping |
||||
deriving (Show) |
||||
|
||||
data ParseError = |
||||
UnknownCmd |
||||
| UtfDecodeError |
||||
| JsonDecodeError |
||||
deriving (Show, Eq) |
||||
|
||||
parseRemoteControlRequest :: B.ByteString -> Either ParseError RemoteControlRequest |
||||
parseRemoteControlRequest bs = |
||||
if |
||||
| cmd == "START" -> parseStart |
||||
| cmd == "STOP" -> parseStop |
||||
| cmd == "RELOAD_CONFIG" -> parseReloadConfig |
||||
| cmd == "GET_STATE" -> parseGetState |
||||
| cmd == "SET_STATE" -> parseSetState |
||||
| cmd == "PING" -> Right Ping |
||||
| otherwise -> Left UnknownCmd |
||||
where |
||||
cmd = B.takeWhile (/= 0x20) bs |
||||
rest = B.dropWhile (== 0x20) . B.dropWhile (/= 0x20) $ bs |
||||
|
||||
parseStart = case decode . BL.fromStrict $ rest of |
||||
Just inst -> Right (StartRobot inst) |
||||
Nothing -> Left JsonDecodeError |
||||
|
||||
parseStop = case decodeUtf8' rest of |
||||
Left _ -> Left UtfDecodeError |
||||
Right r -> Right (StopRobot (T.strip r)) |
||||
|
||||
parseReloadConfig = case decodeUtf8' rest of |
||||
Left _ -> Left UtfDecodeError |
||||
Right r -> Right (ReloadConfig (T.strip r)) |
||||
|
||||
parseGetState = case decodeUtf8' (B.takeWhile (/= 0x20) rest) of |
||||
Left _ -> Left UtfDecodeError |
||||
Right r -> Right (GetState r) |
||||
|
||||
parseSetState = case decodeUtf8' (B.takeWhile (/= 0x20) rest) of |
||||
Left _ -> Left UtfDecodeError |
||||
Right r -> Right (SetState r (B.dropWhile (== 0x20) . B.dropWhile (/= 0x20) $ rest)) |
||||
|
||||
|
||||
makeRemoteControlResponse :: RemoteControlResponse -> B.ByteString |
||||
makeRemoteControlResponse ResponseOk = "OK" |
||||
makeRemoteControlResponse (ResponseError msg) = "ERROR " <> encodeUtf8 msg |
||||
makeRemoteControlResponse (ResponseData d) = "DATA\n" <> d |
||||
|
||||
handleRemoteControl :: Int -> JunctionM () |
||||
handleRemoteControl timeout = do |
||||
sock <- asks peRemoteControlSocket |
||||
logger <- asks peLogAction |
||||
evs <- poll (fromIntegral timeout) [Sock sock [In] Nothing] |
||||
case evs of |
||||
(x:_) -> unless (null x) $ do |
||||
frames <- liftIO $ receiveMulti sock |
||||
case frames of |
||||
[peerId, _, rawRequest] -> do |
||||
case parseRemoteControlRequest rawRequest of |
||||
Left err -> logErrorWith logger "RemoteControl" ("Unable to parse request: " <> (T.pack . show) err) |
||||
Right request -> do |
||||
response <- handleRequest request |
||||
liftIO $ sendMulti sock $ peerId :| [B.empty, makeRemoteControlResponse response] |
||||
_ -> logErrorWith logger "RemoteControl" "Invalid incoming request" |
||||
_ -> return () |
||||
where |
||||
handleRequest (StartRobot inst) = do |
||||
startRobot inst |
||||
return ResponseOk |
||||
handleRequest (StopRobot instId) = do |
||||
robotsRef <- asks peRobots |
||||
robots <- readIORef robotsRef |
||||
case M.lookup instId robots of |
||||
Just robot -> do |
||||
logger <- asks peLogAction |
||||
logWith logger Info "RemoteControl" $ "Stopping robot: " <> instId |
||||
stopRobot robot |
||||
liftIO $ atomicModifyIORef' robotsRef (\r -> (M.delete instId r, ())) |
||||
return ResponseOk |
||||
Nothing -> return $ ResponseError $ "Not started: " <> instId |
||||
|
||||
handleRequest (ReloadConfig instId) = do |
||||
res <- reloadConfig instId |
||||
case res of |
||||
Left errmsg -> return $ ResponseError errmsg |
||||
Right () -> return ResponseOk |
||||
|
||||
handleRequest (GetState instId) = do |
||||
res <- getState instId |
||||
case res of |
||||
Left errmsg -> return $ ResponseError errmsg |
||||
Right d -> return $ ResponseData d |
||||
|
||||
handleRequest (SetState instId rawState) = do |
||||
res <- setState instId rawState |
||||
case res of |
||||
Left errmsg -> return $ ResponseError errmsg |
||||
Right () -> return ResponseOk |
||||
|
||||
handleRequest Ping = return ResponseOk |
||||
|
||||
|
||||
@ -0,0 +1,165 @@
@@ -0,0 +1,165 @@
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module Test.RoboCom.Positions |
||||
( |
||||
unitTests |
||||
) where |
||||
|
||||
import Test.Tasty |
||||
import Test.Tasty.HUnit |
||||
|
||||
import ATrade.Types |
||||
import qualified Data.List as L |
||||
import qualified Data.Map.Strict as M |
||||
import qualified Data.Text as T |
||||
import Data.Time.Calendar |
||||
import Data.Time.Clock |
||||
|
||||
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" "" |
||||
} |
||||
|
||||
|
||||
Loading…
Reference in new issue