Compare commits
No commits in common. 'master' and 'junction' have entirely different histories.
24 changed files with 763 additions and 1642 deletions
@ -1,258 +0,0 @@ |
|||||||
{-# 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 |
|
||||||
@ -1,151 +0,0 @@ |
|||||||
{-# 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 |
|
||||||
|
|
||||||
|
|
||||||
@ -1,165 +0,0 @@ |
|||||||
|
|
||||||
{-# 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