asakul
/
robocom-zero
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

Backtest driver fixed

master
Denis Tereshkin 4 years ago
parent
467dcb066e
commit
764e02dd43
4 changed files with 330 additions and 234 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 5
      robocom-zero.cabal
  2. 533
      src/ATrade/Driver/Backtest.hs
  3. 3
      src/ATrade/Quotes/QTIS.hs
  4. 23
      src/ATrade/RoboCom/Positions.hs

5
robocom-zero.cabal
Unescape View File

@ -26,7 +26,7 @@ library
, ATrade.Quotes , ATrade.Quotes
, ATrade.Quotes.QHP , ATrade.Quotes.QHP
, ATrade.Quotes.QTIS , ATrade.Quotes.QTIS
-- , ATrade.Driver.Backtest , ATrade.Driver.Backtest
, ATrade.Driver.Junction , ATrade.Driver.Junction
, ATrade.Driver.Junction.Types , ATrade.Driver.Junction.Types
, ATrade.Driver.Junction.QuoteThread , ATrade.Driver.Junction.QuoteThread
@ -76,6 +76,9 @@ library
, co-log , co-log
, text-show , text-show
, unliftio , unliftio
, conduit
, split
, cassava
default-language: Haskell2010 default-language: Haskell2010
other-modules: ATrade.Exceptions other-modules: ATrade.Exceptions

533
src/ATrade/Driver/Backtest.hs
Unescape View File

@ -13,59 +13,101 @@ module ATrade.Driver.Backtest (
backtestMain backtestMain
) where ) where
import ATrade.Driver.Types (InitializationCallback, import ATrade.Driver.Junction.Types (StrategyDescriptor (StrategyDescriptor),
StrategyInstanceParams (..)) StrategyDescriptorE (StrategyDescriptorE),
import ATrade.Exceptions TickerConfig, confStrategy,
import ATrade.Quotes confTickers, eventCallback,
import ATrade.Quotes.Finam as QF strategyBaseName, tickerId,
import ATrade.Quotes.QTIS timeframe)
import ATrade.RoboCom.Monad (Event (..), EventCallback, import ATrade.Exceptions (RoboComException (UnableToLoadConfig, UnableToLoadFeed))
MonadRobot (..), import ATrade.Logging (Message, Severity (Error, Trace),
StrategyEnvironment (..), fmtMessage, logWith)
appendToLog, seBars, seLastTimestamp) import ATrade.Quotes.QTIS (TickerInfo (tiLotSize, tiTickSize),
import ATrade.RoboCom.Positions qtisGetTickersInfo)
import ATrade.RoboCom.Types (BarSeries (..), Bars, InstrumentParameters (InstrumentParameters), import ATrade.RoboCom.ConfigStorage (ConfigStorage (loadConfig))
Ticker (..), Timeframe (..)) import ATrade.RoboCom.Monad (Event (..), MonadRobot (..),
import ATrade.Types StrategyEnvironment (..),
import Conduit (awaitForever, runConduit, yield, appendToLog, seLastTimestamp)
(.|)) import ATrade.RoboCom.Types (BarSeries (..),
import Control.Exception.Safe BarSeriesId (BarSeriesId), Bars,
import Control.Lens hiding (ix, (<|), (|>)) InstrumentParameters (InstrumentParameters),
import Control.Monad.ST (runST) Ticker (..))
import Control.Monad.State import ATrade.Types (Bar (Bar, barHigh, barLow, barOpen, barSecurity, barTimestamp),
import Data.Aeson (FromJSON (..), Value (..), decode) BarTimeframe (BarTimeframe),
import Data.Aeson.Types (parseMaybe) Operation (Buy),
import Data.ByteString.Lazy (readFile, toStrict) Order (orderAccountId, orderId, orderOperation, orderPrice, orderQuantity, orderSecurity, orderSignalId),
import Data.Default OrderId,
import Data.HashMap.Strict (lookup) OrderPrice (Limit, Market),
import Data.List (partition) OrderState (Cancelled, Executed, Submitted),
import Data.List.Split (splitOn) Price, TickerId, Trade (..),
import qualified Data.Map.Strict as M fromDouble)
import Data.Sequence (Seq (..), (<|), (|>)) import Colog (LogAction, (>$<))
import qualified Data.Sequence as Seq import Colog.Actions (logTextStdout)
import Data.STRef (newSTRef, readSTRef, writeSTRef) import Conduit (ConduitT, Void, awaitForever,
import qualified Data.Text as T runConduit, yield, (.|))
import Data.Text.IO (putStrLn) import Control.Exception.Safe (catchAny, throw)
import qualified Data.Text.Lazy as TL import Control.Lens (makeLenses, use, (%=), (+=),
import Data.Time.Calendar (fromGregorian) (.=), (^.))
import Data.Time.Clock (DiffTime, UTCTime (..)) import Control.Monad.ST (runST)
import Data.Vector ((!), (!?), (//)) import Control.Monad.State (MonadIO, MonadPlus (mzero),
import qualified Data.Vector as V MonadState, MonadTrans (lift),
import Options.Applicative hiding (Success) State, StateT (StateT),
import Prelude hiding (lookup, putStrLn, readFile) execState, forM_, gets, when)
import Safe (headMay) import Data.Aeson (FromJSON (..), Value (..),
import System.ZMQ4 hiding (Event) decode)
import Data.Aeson.Types (parseMaybe)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.ByteString.Lazy (readFile, toStrict)
import qualified Data.ByteString.Lazy as BL
import Data.Csv (FromField (parseField),
FromRecord (parseRecord),
HasHeader (HasHeader), (.!))
import qualified Data.Csv as Csv
import Data.Default (Default (def))
import Data.HashMap.Strict (lookup)
import Data.IORef (newIORef)
import Data.List (partition)
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.Split (splitOn)
import qualified Data.Map.Strict as M
import Data.Sequence (Seq (..), (<|), (|>))
import qualified Data.Sequence as Seq
import Data.STRef (newSTRef, readSTRef, writeSTRef)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Text.IO (putStrLn)
import qualified Data.Text.Lazy as TL
import Data.Time (defaultTimeLocale, parseTimeM)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime (..), addUTCTime)
import Data.Vector ((!), (!?), (//))
import qualified Data.Vector as V
import Dhall (FromDhall, auto, input)
import Options.Applicative (Alternative (some), Parser,
ReadM, eitherReader, execParser,
fullDesc, header, helper, info,
long, metavar, option, short,
strOption)
import Prelude hiding (log, lookup, putStrLn,
readFile)
import Safe (headMay)
import System.IO (IOMode (ReadMode), withFile)
import System.ZMQ4 (withContext)
data Feed = Feed TickerId FilePath data Feed = Feed TickerId FilePath
deriving (Show, Eq) deriving (Show, Eq)
data Params = Params { data Params = Params {
strategyBasename :: String,
strategyConfigFile :: FilePath, strategyConfigFile :: FilePath,
qtisEndpoint :: String, qtisEndpoint :: String,
paramsFeeds :: [Feed] paramsFeeds :: [Feed]
} deriving (Show, Eq) } deriving (Show, Eq)
data BacktestState c s = BacktestState { data BacktestState c s = BacktestState {
_descriptor :: StrategyDescriptor c s,
_cash :: Double, _cash :: Double,
_robotState :: s, _robotState :: s,
_robotParams :: c, _robotParams :: c,
@ -75,101 +117,135 @@ data BacktestState c s = BacktestState {
_tradesLog :: [Trade], _tradesLog :: [Trade],
_orderIdCounter :: Integer, _orderIdCounter :: Integer,
_pendingTimers :: [UTCTime], _pendingTimers :: [UTCTime],
_logs :: [T.Text] _logs :: [T.Text],
_barsMap :: M.Map BarSeriesId BarSeries,
_availableTickers :: NonEmpty BarSeriesId
} }
makeLenses ''BacktestState makeLenses ''BacktestState
data Row = Row {
rowTicker :: T.Text,
rowTimeframe :: Int,
rowTime :: UTCTime,
rowOpen :: Price,
rowHigh :: Price,
rowLow :: Price,
rowClose :: Price,
rowVolume :: Integer
} deriving (Show, Eq)
instance FromField Price where
parseField s = fromDouble <$> (parseField s :: Csv.Parser Double)
instance FromRecord Row where
parseRecord v
| length v == 9 = do
tkr <- v .! 0
tf <- v .! 1
date <- v .! 2
time <- v .! 3
dt <- addUTCTime (-3 * 3600) <$> parseDt date time
open <- v .! 4
high <- v .! 5
low <- v .! 6
close <- v .! 7
vol <- v .! 8
return $ Row tkr tf dt open high low close vol
| otherwise = mzero
where
parseDt :: B.ByteString -> B.ByteString -> Csv.Parser UTCTime
parseDt d t = case parseTimeM True defaultTimeLocale "%Y%m%d %H%M%S" $ B8.unpack d ++ " " ++ B8.unpack t of
Just dt -> return dt
Nothing -> fail "Unable to parse date/time"
parseQuotes :: B.ByteString -> Maybe [Row]
parseQuotes csvData = case Csv.decode HasHeader $ BL.fromStrict csvData of
Left _ -> Nothing
Right d -> Just $ V.toList d
paramsParser :: Parser Params paramsParser :: Parser Params
paramsParser = Params paramsParser = Params
<$> strOption ( <$> strOption (
long "config" <> short 'c' long "strategy-name" <> short 'n')
) <*> strOption (
long "config" <> short 'c')
<*> strOption <*> strOption
( long "qtis" <> short 'q' <> metavar "ENDPOINT/ID" ) ( long "qtis" <> short 'q' <> metavar "ENDPOINT/ID")
<*> some (option feedArgParser ( <*> some (option feedArgParser (
long "feed" <> short 'f' long "feed" <> short 'f'))
))
feedArgParser :: ReadM Feed feedArgParser :: ReadM Feed
feedArgParser = eitherReader (\s -> case splitOn ":" s of feedArgParser = eitherReader (\s -> case splitOn ":" s of
[tid, fpath] -> Right $ Feed (T.pack tid) fpath [tid, fpath] -> Right $ Feed (T.pack tid) fpath
_ -> Left $ "Unable to parse feed id: " ++ s) _ -> Left $ "Unable to parse feed id: " ++ s)
backtestMain :: (FromJSON c, StateHasPositions s) => DiffTime -> s -> EventCallback c s -> IO () logger :: (MonadIO m) => LogAction m Message
backtestMain _dataDownloadDelta defaultState callback = do logger = fmtMessage >$< logTextStdout
params <- execParser opts
(tickerList, config) <- loadStrategyConfig params
let instanceParams = StrategyInstanceParams { backtestMain :: M.Map T.Text StrategyDescriptorE -> IO ()
strategyInstanceId = "foo", backtestMain descriptors = do
strategyAccount = "foo", params <- execParser opts
strategyVolume = 1, let log = logWith logger
tickers = tickerList, let strategyName = T.pack $ strategyBasename params
strategyQTISEp = Nothing }
feeds <- loadFeeds (paramsFeeds params) feeds <- loadFeeds (paramsFeeds params)
bars <- makeBars (T.pack $ qtisEndpoint params) tickerList case M.lookup strategyName descriptors of
Just (StrategyDescriptorE desc) -> flip catchAny (\e -> log Error "Backtest" $ "Exception: " <> (T.pack . show $ e)) $
runBacktestDriver feeds config bars runBacktestDriver desc feeds params
Nothing -> log Error "Backtest" $ "Can't find strategy: " <> strategyName
where where
opts = info (helper <*> paramsParser) opts = info (helper <*> paramsParser)
( fullDesc <> header "ATrade strategy backtesting framework" ) ( fullDesc <> header "ATrade strategy backtesting framework" )
makeBars :: T.Text -> [Ticker] -> IO (M.Map TickerId BarSeries) makeBars :: T.Text -> [TickerConfig] -> IO (M.Map BarSeriesId BarSeries)
makeBars qtisEp tickersList = makeBars qtisEp confs =
withContext $ \ctx -> withContext $ \ctx ->
M.fromList <$> mapM (mkBarEntry ctx qtisEp) tickersList M.fromList <$> mapM (mkBarEntry ctx qtisEp) confs
mkBarEntry ctx qtisEp tickerEntry = do mkBarEntry ctx qtisEp conf = do
info <- qtisGetTickersInfo ctx qtisEp (code tickerEntry) info <- qtisGetTickersInfo ctx qtisEp (tickerId conf)
return (code tickerEntry, BarSeries (code tickerEntry) (Timeframe (timeframeSeconds tickerEntry)) [] (InstrumentParameters (fromInteger $ tiLotSize info) (tiTickSize info))) return (BarSeriesId (tickerId conf) (timeframe conf),
BarSeries
(tickerId conf)
(timeframe conf)
runBacktestDriver feeds params tickerList = do []
let s = runConduit $ barStreamFromFeeds feeds .| backtestLoop (InstrumentParameters (tickerId conf) (fromInteger $ tiLotSize info) (tiTickSize info)))
let finalState = execState (unBacktestingMonad s) $ defaultBacktestState defaultState params tickerList
print $ finalState ^. cash runBacktestDriver desc feeds params = do
print $ finalState ^. tradesLog bigConf <- loadConfig (T.pack $ strategyConfigFile params)
forM_ (reverse $ finalState ^. logs) putStrLn case confTickers bigConf of
tickerList@(firstTicker:restTickers) -> do
loadStrategyConfig :: (FromJSON c) => Params -> IO ([Ticker], c) bars <- makeBars (T.pack $ qtisEndpoint params) tickerList
loadStrategyConfig params = do let s = runConduit $ barStreamFromFeeds feeds .| backtestLoop desc
content <- readFile (strategyConfigFile params) let finalState =
case loadStrategyConfig' content of execState (unBacktestingMonad s) $ defaultBacktestState def (confStrategy bigConf) desc bars (fmap toBarSeriesId (firstTicker :| restTickers))
Just (tickersList, config) -> return (tickersList, config) print $ finalState ^. cash
_ -> throw $ UnableToLoadConfig (T.pack . strategyConfigFile $ params) print $ finalState ^. tradesLog
forM_ (reverse $ finalState ^. logs) putStrLn
loadStrategyConfig' content = do _ -> return ()
v <- decode content
case v of toBarSeriesId conf = BarSeriesId (tickerId conf) (timeframe conf)
Object o -> do
mbTickers <- "tickers" `lookup` o
mbParams <- "params" `lookup` o
tickers' <- parseMaybe parseJSON mbTickers
params <- parseMaybe parseJSON mbParams
return (tickers', params)
_ -> Nothing
barStreamFromFeeds :: (Monad m) => V.Vector (BarTimeframe, [Bar]) -> ConduitT () (BarSeriesId, Bar) m ()
barStreamFromFeeds feeds = case nextBar feeds of barStreamFromFeeds feeds = case nextBar feeds of
Just (bar, feeds') -> yield bar >> barStreamFromFeeds feeds' Just (tf, bar, feeds') -> yield (BarSeriesId (barSecurity bar) tf, bar) >> barStreamFromFeeds feeds'
_ -> return () _ -> return ()
nextBar :: V.Vector [Bar] -> Maybe (Bar, V.Vector [Bar]) nextBar :: V.Vector (BarTimeframe, [Bar]) -> Maybe (BarTimeframe, Bar, V.Vector (BarTimeframe, [Bar]))
nextBar feeds = case indexOfNextFeed feeds of nextBar feeds = case indexOfNextFeed feeds of
Just ix -> do Just ix -> do
f <- feeds !? ix (tf, f) <- feeds !? ix
h <- headMay f h <- headMay f
return (h, feeds // [(ix, tail f)]) return (tf, h, feeds // [(ix, (tf, tail f))])
_ -> Nothing _ -> Nothing
indexOfNextFeed feeds = runST $ do indexOfNextFeed feeds = runST $ do
minTs <- newSTRef Nothing minTs <- newSTRef Nothing
minIx <- newSTRef Nothing minIx <- newSTRef Nothing
forM_ [0..(V.length feeds-1)] (\ix -> do forM_ [0..(V.length feeds-1)] (\ix -> do
let feed = feeds ! ix let (_, feed) = feeds ! ix
curTs <- readSTRef minTs curTs <- readSTRef minTs
case feed of case feed of
x:_ -> case curTs of x:_ -> case curTs of
@ -182,126 +258,124 @@ backtestMain _dataDownloadDelta defaultState callback = do
_ -> return ()) _ -> return ())
readSTRef minIx readSTRef minIx
backtestLoop = awaitForever (\bar -> do backtestLoop :: StrategyDescriptor c s -> ConduitT (BarSeriesId, Bar) Void (BacktestingMonad c s) ()
backtestLoop desc =
awaitForever (\(bsId, bar) -> do
_curState <- use robotState _curState <- use robotState
_env <- gets _strategyEnvironment _env <- gets _strategyEnvironment
let newTimestamp = barTimestamp bar let newTimestamp = barTimestamp bar
strategyEnvironment . seBars %= (flip updateBars bar) barsMap %= updateBars bsId bar
strategyEnvironment . seLastTimestamp .= newTimestamp strategyEnvironment . seLastTimestamp .= newTimestamp
enqueueEvent (NewBar bar) enqueueEvent (NewBar (bsIdTf bsId, bar))
lift handleEvents) lift (handleEvents desc))
handleEvents = do bsIdTf (BarSeriesId _ tf) = tf
events <- use pendingEvents
case events of
x :<| xs -> do handleEvents :: StrategyDescriptor c s -> BacktestingMonad c s ()
pendingEvents .= xs handleEvents desc = do
handleEvent x events <- use pendingEvents
handleEvents case events of
_ -> return () x :<| xs -> do
pendingEvents .= xs
executePendingOrders bar = do handleEvent desc x
executeMarketOrders bar handleEvents desc
executeLimitOrders bar _ -> return ()
executeLimitOrders bar = do executePendingOrders bar = do
(limitOrders, otherOrders'') <- partition executeMarketOrders bar
(\o -> case orderPrice o of executeLimitOrders bar
Limit _ -> True
_ -> False) <$> use pendingOrders executeLimitOrders bar = do
let (executableOrders, otherOrders') = partition (isExecutable bar) limitOrders (limitOrders, otherOrders'') <- partition
pendingOrders .= otherOrders' ++ otherOrders'' (\o -> case orderPrice o of
forM_ executableOrders $ \order -> order `executeAtPrice` priceForLimitOrder order bar Limit _ -> True
_ -> False) <$> use pendingOrders
isExecutable bar order = case orderPrice order of let (executableOrders, otherOrders') = partition (isExecutable bar) limitOrders
Limit price -> if orderOperation order == Buy pendingOrders .= otherOrders' ++ otherOrders''
then price >= barLow bar forM_ executableOrders $ \order -> order `executeAtPrice` priceForLimitOrder order bar
else price <= barHigh bar
_ -> True isExecutable bar order = case orderPrice order of
Limit price -> if orderOperation order == Buy
priceForLimitOrder order bar = case orderPrice order of then price >= barLow bar
Limit price -> if orderOperation order == Buy else price <= barHigh bar
then if price >= barOpen bar _ -> True
then barOpen bar
else price priceForLimitOrder order bar = case orderPrice order of
else if price <= barOpen bar Limit price -> if orderOperation order == Buy
then barOpen bar then if price >= barOpen bar
else price then barOpen bar
_ -> error "Should've been limit order" else price
else if price <= barOpen bar
executeMarketOrders bar = do then barOpen bar
(marketOrders, otherOrders) <- partition (\o -> orderPrice o == Market) <$> use pendingOrders else price
pendingOrders .= otherOrders _ -> error "Should've been limit order"
forM_ marketOrders $ \order ->
order `executeAtPrice` barOpen bar executeMarketOrders bar = do
(marketOrders, otherOrders) <- partition (\o -> orderPrice o == Market) <$> use pendingOrders
executeAtPrice order price = do pendingOrders .= otherOrders
ts <- use $ strategyEnvironment . seLastTimestamp forM_ marketOrders $ \order ->
let thisTrade = mkTrade order price ts order `executeAtPrice` barOpen bar
tradesLog %= (\log' -> thisTrade : log')
pendingEvents %= (\s -> (OrderUpdate (orderId order) Executed) <| s) executeAtPrice order price = do
pendingEvents %= (\s -> (NewTrade thisTrade) <| s) ts <- use $ strategyEnvironment . seLastTimestamp
let thisTrade = mkTrade order price ts
mkTrade :: Order -> Price -> UTCTime -> Trade tradesLog %= (thisTrade :)
mkTrade order price ts = Trade { pendingEvents %= (\s -> OrderUpdate (orderId order) Executed <| s)
tradeOrderId = orderId order, pendingEvents %= (\s -> NewTrade thisTrade <| s)
tradePrice = price,
tradeQuantity = orderQuantity order, mkTrade :: Order -> Price -> UTCTime -> Trade
tradeVolume = (fromIntegral . orderQuantity $ order) * price, mkTrade order price ts = Trade {
tradeVolumeCurrency = "pt", tradeOrderId = orderId order,
tradeOperation = orderOperation order, tradePrice = price,
tradeAccount = orderAccountId order, tradeQuantity = orderQuantity order,
tradeSecurity = orderSecurity order, tradeVolume = (fromIntegral . orderQuantity $ order) * price,
tradeTimestamp = ts, tradeVolumeCurrency = "pt",
tradeCommission = 0, tradeOperation = orderOperation order,
tradeSignalId = orderSignalId order tradeAccount = orderAccountId order,
} tradeSecurity = orderSecurity order,
tradeTimestamp = ts,
handleEvent event@(NewBar bar) = do tradeCommission = 0,
executePendingOrders bar tradeSignalId = orderSignalId order
handleEvents -- This should pass OrderUpdate events to the callback before NewBar events }
firedTimers <- fireTimers (barTimestamp bar)
mapM_ (\x -> enqueueEvent (TimerFired x)) firedTimers handleEvent :: StrategyDescriptor c s -> Event -> BacktestingMonad c s ()
handleEvent' event handleEvent desc event@(NewBar (_, bar)) = do
return () executePendingOrders bar
handleEvents desc -- This should pass OrderUpdate events to the callback before NewBar events
handleEvent event = handleEvent' event firedTimers <- fireTimers (barTimestamp bar)
mapM_ (enqueueEvent . TimerFired) firedTimers
handleEvent' event = callback event handleEvent' desc event
return ()
updateBars barMap newbar = M.alter (\case
Nothing -> Just BarSeries { bsTickerId = barSecurity newbar, handleEvent desc event = handleEvent' desc event
bsTimeframe = Timeframe 60,
bsBars = [newbar, newbar] } handleEvent' desc event = eventCallback desc event
Just bs -> Just bs { bsBars = updateBarList newbar (bsBars bs) }) (barSecurity newbar) barMap
updateBars bsId newbar barMap = M.adjust (\bs -> bs { bsBars = newbar : bsBars bs }) bsId barMap
updateBarList newbar (_:bs) = newbar:newbar:bs
updateBarList newbar _ = newbar:[newbar] fireTimers ts = do
(firedTimers, otherTimers) <- partition (< ts) <$> use pendingTimers
fireTimers ts = do pendingTimers .= otherTimers
(firedTimers, otherTimers) <- partition (< ts) <$> use pendingTimers return firedTimers
pendingTimers .= otherTimers
return firedTimers loadFeeds :: [Feed] -> IO (V.Vector (BarTimeframe, [Bar]))
loadFeeds feeds = V.fromList <$> mapM loadFeed feeds
loadFeeds :: [Feed] -> IO (V.Vector [Bar]) loadFeed (Feed tid path) = do
loadFeeds feeds = V.fromList <$> mapM loadFeed feeds content <- readFile path
loadFeed (Feed tid path) = do case parseQuotes $ toStrict content of
content <- readFile path Just quotes -> case headMay quotes of
case QF.parseQuotes $ toStrict content of Just first -> return (BarTimeframe (rowTimeframe first), fmap (rowToBar tid) quotes)
Just quotes -> return $ fmap (rowToBar tid) quotes Nothing -> throw $ UnableToLoadFeed (T.pack path)
_ -> throw $ UnableToLoadFeed (T.pack path) _ -> throw $ UnableToLoadFeed (T.pack path)
rowToBar tid r = Bar tid (rowTime r) (rowOpen r) (rowHigh r) (rowLow r) (rowClose r) (rowVolume r) rowToBar tid r = Bar tid (rowTime r) (rowOpen r) (rowHigh r) (rowLow r) (rowClose r) (rowVolume r)
enqueueEvent :: MonadState (BacktestState c s) m => Event -> m ()
enqueueEvent event = pendingEvents %= (\s -> s |> event) enqueueEvent event = pendingEvents %= (|> event)
instance (Default c, Default s) => Default (BacktestState c s) defaultBacktestState :: s -> c -> StrategyDescriptor c s -> M.Map BarSeriesId BarSeries -> NonEmpty BarSeriesId -> BacktestState c s
where defaultBacktestState s c desc = BacktestState desc 0 s c (StrategyEnvironment "" "" 1 (UTCTime (fromGregorian 1970 1 1) 0)) [] Seq.empty [] 1 [] []
def = defaultBacktestState def def def
defaultBacktestState :: s -> c -> Bars -> BacktestState c s
defaultBacktestState s c bars = BacktestState 0 s c (StrategyEnvironment "" "" 1 bars (UTCTime (fromGregorian 1970 1 1) 0)) [] Seq.empty [] 1 [] []
newtype BacktestingMonad s c a = BacktestingMonad { unBacktestingMonad :: State (BacktestState s c) a } newtype BacktestingMonad s c a = BacktestingMonad { unBacktestingMonad :: State (BacktestState s c) a }
deriving (Functor, Applicative, Monad, MonadState (BacktestState s c)) deriving (Functor, Applicative, Monad, MonadState (BacktestState s c))
@ -315,21 +389,38 @@ instance MonadRobot (BacktestingMonad c s) c s where
submitOrder order = do submitOrder order = do
oid <- nextOrderId oid <- nextOrderId
let orderWithId = order { orderId = oid } let orderWithId = order { orderId = oid }
pendingOrders %= ((:) orderWithId) pendingOrders %= (orderWithId :)
pendingEvents %= (\s -> s |> (OrderSubmitted orderWithId)) pendingEvents %= (\s -> s |> OrderUpdate oid Submitted)
return oid
cancelOrder oid = do cancelOrder oid = do
orders <- use pendingOrders orders <- use pendingOrders
let (matchingOrders, otherOrders) = partition (\o -> orderId o == oid) orders let (matchingOrders, otherOrders) = partition (\o -> orderId o == oid) orders
case matchingOrders of case matchingOrders of
[] -> return () [] -> return ()
xs -> do xs -> do
mapM_ (\o -> pendingEvents %= (\s -> s |> (OrderUpdate (orderId o) Cancelled))) xs mapM_ (\o -> pendingEvents %= (\s -> s |> OrderUpdate (orderId o) Cancelled)) xs
pendingOrders .= otherOrders pendingOrders .= otherOrders
appendToLog txt = logs %= ((:) (TL.toStrict txt)) appendToLog _ txt = logs %= ((TL.toStrict txt) :)
setupTimer time = pendingTimers %= ((:) time) setupTimer time = pendingTimers %= (time :)
enqueueIOAction _actionId _action = error "Backtesting io actions is not supported" enqueueIOAction _actionId _action = error "Backtesting io actions is not supported"
getConfig = use robotParams getConfig = use robotParams
getState = use robotState getState = use robotState
setState s = robotState .= s setState s = robotState .= s
getEnvironment = use strategyEnvironment getEnvironment = use strategyEnvironment
getTicker tid tf = do
m <- gets _barsMap
return $ M.lookup (BarSeriesId tid tf) m
getTickerInfo tid = do
tickers <- getAvailableTickers
case L.find (\(BarSeriesId t _) -> t == tid) tickers of
Just (BarSeriesId t tf) -> do
ticker <- getTicker t tf
return (bsParams <$> ticker)
Nothing -> return Nothing
getAvailableTickers = use availableTickers
instance ConfigStorage IO where
loadConfig filepath = do
cfg <- B.readFile $ T.unpack filepath
input auto (decodeUtf8 cfg)

3
src/ATrade/Quotes/QTIS.hs
Unescape View File

@ -37,9 +37,8 @@ instance ToJSON TickerInfo where
"lot_size" .= tiLotSize ti, "lot_size" .= tiLotSize ti,
"tick_size" .= tiTickSize ti ] "tick_size" .= tiTickSize ti ]
qtisGetTickersInfo :: (WithLog env Message m, MonadIO m) => Context -> T.Text -> TickerId -> m TickerInfo qtisGetTickersInfo :: (MonadIO m) => Context -> T.Text -> TickerId -> m TickerInfo
qtisGetTickersInfo ctx endpoint tickerId = do qtisGetTickersInfo ctx endpoint tickerId = do
logInfo "QTIS" $ "Requesting ticker: " <> tickerId <> " from " <> endpoint
liftIO $ withSocket ctx Req $ \sock -> do liftIO $ withSocket ctx Req $ \sock -> do
connect sock $ T.unpack endpoint connect sock $ T.unpack endpoint
send sock [] $ BL.toStrict tickerRequest send sock [] $ BL.toStrict tickerRequest

23
src/ATrade/RoboCom/Positions.hs
Unescape View File

@ -223,20 +223,23 @@ orderDeadline maybeDeadline lastTs =
dispatchPosition :: (StateHasPositions s, MonadRobot m c s) => Event -> Position -> m Position dispatchPosition :: (StateHasPositions s, MonadRobot m c s) => Event -> Position -> m Position
dispatchPosition event pos = case posState pos of dispatchPosition event pos =
PositionWaitingOpenSubmission pendingOrder -> handlePositionWaitingOpenSubmission pendingOrder case posState pos of
PositionWaitingOpen -> handlePositionWaitingOpen PositionWaitingOpenSubmission pendingOrder -> handlePositionWaitingOpenSubmission pendingOrder
PositionOpen -> handlePositionOpen PositionWaitingOpen -> handlePositionWaitingOpen
PositionWaitingPendingCancellation -> handlePositionWaitingPendingCancellation PositionOpen -> handlePositionOpen
PositionWaitingCloseSubmission pendingOrder -> handlePositionWaitingCloseSubmission pendingOrder PositionWaitingPendingCancellation -> handlePositionWaitingPendingCancellation
PositionWaitingClose -> handlePositionWaitingClose PositionWaitingCloseSubmission pendingOrder -> handlePositionWaitingCloseSubmission pendingOrder
PositionClosed -> handlePositionClosed pos PositionWaitingClose -> handlePositionWaitingClose
PositionCancelled -> handlePositionCancelled pos PositionClosed -> handlePositionClosed pos
PositionCancelled -> handlePositionCancelled pos
where where
handlePositionWaitingOpenSubmission pendingOrder = do handlePositionWaitingOpenSubmission pendingOrder = do
lastTs <- view seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
if orderDeadline (posSubmissionDeadline pos) lastTs if orderDeadline (posSubmissionDeadline pos) lastTs
then return $ pos { posState = PositionCancelled } -- TODO call TimeoutHandler if present then do
appendToLog Warning $ [t|Submission deadline: %?, %?|] lastTs (posSubmissionDeadline pos)
return $ pos { posState = PositionCancelled } -- TODO call TimeoutHandler if present
else case event of else case event of
OrderUpdate oid Submitted -> do OrderUpdate oid Submitted -> do
return $ if orderId pendingOrder == oid return $ if orderId pendingOrder == oid

Write Preview
Loading…
Cancel
Save