Compare commits
46 Commits
24 changed files with 1642 additions and 763 deletions
@ -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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
|
||||||
|
{-# 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