diff --git a/src/ATrade/Driver/Backtest.hs b/src/ATrade/Driver/Backtest.hs index 9565c24..450cb59 100644 --- a/src/ATrade/Driver/Backtest.hs +++ b/src/ATrade/Driver/Backtest.hs @@ -20,7 +20,8 @@ import ATrade.Quotes.Finam as QF import ATrade.RoboCom.Monad (Event (..), EventCallback, MonadRobot (..), StrategyAction (..), StrategyEnvironment (..), - appendToLog, runStrategyElement, st) + appendToLog, runStrategyElement, + seBars, seLastTimestamp, st) import ATrade.RoboCom.Positions import ATrade.RoboCom.Types (BarSeries (..), Ticker (..), Timeframe (..)) @@ -28,6 +29,7 @@ import ATrade.Types import Conduit (awaitForever, runConduit, yield, (.|)) import Control.Exception.Safe +import Control.Lens import Control.Monad.ST (runST) import Control.Monad.State import Data.Aeson (FromJSON (..), Result (..), @@ -162,9 +164,8 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do backtestLoop = awaitForever (\bar -> do env <- gets strategyEnvironment - let oldTimestamp = seLastTimestamp env let newTimestamp = barTimestamp bar - let newenv = env { seBars = updateBars (seBars env) bar, seLastTimestamp = newTimestamp } + let newenv = env & seBars %~ (flip updateBars $ bar) & seLastTimestamp .~ newTimestamp curState <- gets robotState modify' (\s -> s { strategyEnvironment = newenv }) handleEvents [NewBar bar]) @@ -232,7 +233,7 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do order `executeAtPrice` barOpen bar executeAtPrice order price = do - ts <- seLastTimestamp <$> gets strategyEnvironment + ts <- view seLastTimestamp <$> gets strategyEnvironment modify' (\s -> s { tradesLog = mkTrade order price ts : tradesLog s }) return $ OrderUpdate (orderId order) Executed diff --git a/src/ATrade/Driver/Real.hs b/src/ATrade/Driver/Real.hs index 7d870f9..2611f41 100644 --- a/src/ATrade/Driver/Real.hs +++ b/src/ATrade/Driver/Real.hs @@ -31,6 +31,7 @@ import Control.Monad.Reader import Control.Concurrent hiding (writeChan, readChan, writeList2Chan, yield) import Control.Concurrent.BoundedChan as BC import Control.Exception.Safe +import Control.Lens hiding (Context, (.=)) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.List as L @@ -46,7 +47,7 @@ import Data.Maybe import Data.Monoid import Database.Redis hiding (info, decode) import ATrade.Types -import ATrade.RoboCom.Monad (StrategyMonad, StrategyAction(..), EventCallback, Event(..), runStrategyElement, StrategyEnvironment(..), Event(..), MonadRobot(..)) +import ATrade.RoboCom.Monad (StrategyMonad, StrategyAction(..), EventCallback, Event(..), runStrategyElement, StrategyEnvironment(..), seBars, seLastTimestamp, Event(..), MonadRobot(..)) import ATrade.BarAggregator import ATrade.Driver.Real.BrokerClientThread import ATrade.Driver.Real.QuoteSourceThread @@ -159,7 +160,7 @@ instance MonadRobot (App c s) c s where env <- lift $ readIORef envRef nowRef <- asks envLastTimestamp now <- lift $ readIORef nowRef - return $ env { seBars = bars agg, seLastTimestamp = now } + return $ env & seBars .~ bars agg & seLastTimestamp .~ now data BigConfig c = BigConfig { confTickers :: [Ticker], @@ -244,11 +245,11 @@ robotMain dataDownloadDelta defaultState initCallback callback = do storeState params stateRef timersRef straEnv <- newIORef StrategyEnvironment { - seInstanceId = strategyInstanceId . strategyInstanceParams $ strategy, - seAccount = strategyAccount . strategyInstanceParams $ strategy, - seVolume = strategyVolume . strategyInstanceParams $ strategy, - seBars = M.empty, - seLastTimestamp = UTCTime (fromGregorian 1970 1 1) 0 + _seInstanceId = strategyInstanceId . strategyInstanceParams $ strategy, + _seAccount = strategyAccount . strategyInstanceParams $ strategy, + _seVolume = strategyVolume . strategyInstanceParams $ strategy, + _seBars = M.empty, + _seLastTimestamp = UTCTime (fromGregorian 1970 1 1) 0 } -- Event channel is for strategy events, like new tick arrival, or order execution notification eventChan <- BC.newBoundedChan 1000 @@ -515,7 +516,7 @@ barStrategyDriver ctx mbSourceTimeframe tickFilter strategy configRef stateRef t env <- getEnvironment let newTimestamp = case event of NewTick tick -> timestamp tick - _ -> seLastTimestamp env + _ -> env ^. seLastTimestamp nowRef <- asks envLastTimestamp lift $ writeIORef nowRef newTimestamp diff --git a/src/ATrade/RoboCom/Monad.hs b/src/ATrade/RoboCom/Monad.hs index 14b734d..71c8af8 100644 --- a/src/ATrade/RoboCom/Monad.hs +++ b/src/ATrade/RoboCom/Monad.hs @@ -14,6 +14,11 @@ module ATrade.RoboCom.Monad ( RActions, REnv, StrategyEnvironment(..), + seInstanceId, + seAccount, + seVolume, + seBars, + seLastTimestamp, StrategyElement, runStrategyElement, EventCallback, @@ -31,12 +36,12 @@ import ATrade.Types import Ether +import Control.Lens import Data.Aeson.Types import qualified Data.Text as T import Data.Time.Clock import Text.Printf.TH - class (Monad m) => MonadRobot m c s | m -> c, m -> s where submitOrder :: Order -> m () cancelOrder :: OrderId -> m () @@ -84,12 +89,14 @@ data StrategyAction = ActionOrder Order | ActionIO Int (IO Value) data StrategyEnvironment = StrategyEnvironment { - seInstanceId :: !T.Text, -- ^ Strategy instance identifier. Should be unique among all strategies (very desirable) - seAccount :: !T.Text, -- ^ Account string to use for this strategy instance. Broker-dependent - seVolume :: !Int, -- ^ Volume to use for this instance (in lots/contracts) - seBars :: !Bars, -- ^ List of tickers which is used by this strategy - seLastTimestamp :: !UTCTime + _seInstanceId :: !T.Text, -- ^ Strategy instance identifier. Should be unique among all strategies (very desirable) + _seAccount :: !T.Text, -- ^ Account string to use for this strategy instance. Broker-dependent + _seVolume :: !Int, -- ^ Volume to use for this instance (in lots/contracts) + _seBars :: !Bars, -- ^ List of tickers which is used by this strategy + _seLastTimestamp :: !UTCTime } deriving (Eq) +makeLenses ''StrategyEnvironment + instance Show StrategyAction where show (ActionOrder order) = "ActionOrder " ++ show order diff --git a/src/ATrade/RoboCom/Positions.hs b/src/ATrade/RoboCom/Positions.hs index 05df475..8b2d372 100644 --- a/src/ATrade/RoboCom/Positions.hs +++ b/src/ATrade/RoboCom/Positions.hs @@ -73,6 +73,7 @@ import ATrade.RoboCom.Monad import ATrade.RoboCom.Types import ATrade.Types +import Control.Lens import Control.Monad import Ether @@ -186,7 +187,7 @@ dispatchPosition event pos = case posState pos of PositionCancelled -> handlePositionCancelled pos where handlePositionWaitingOpenSubmission pendingOrder = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment if orderDeadline (posSubmissionDeadline pos) lastTs then return $ pos { posState = PositionCancelled } -- TODO call TimeoutHandler if present else case event of @@ -199,7 +200,7 @@ dispatchPosition event pos = case posState pos of _ -> return pos handlePositionWaitingOpen = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment case posCurrentOrder pos of Just order -> if orderDeadline (posExecutionDeadline pos) lastTs then do -- TODO call TimeoutHandler @@ -238,7 +239,7 @@ dispatchPosition event pos = case posState pos of return pos handlePositionOpen = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment if | orderDeadline (posSubmissionDeadline pos) lastTs -> do appendToLog $ [st|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos) @@ -261,7 +262,7 @@ dispatchPosition event pos = case posState pos of _ -> return pos handlePositionWaitingPendingCancellation = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment if not $ orderDeadline (posSubmissionDeadline pos) lastTs then case (event, posCurrentOrder pos, posNextState pos) of (OrderUpdate _ newstate, Just _, Just (PositionWaitingCloseSubmission nextOrder)) -> @@ -280,7 +281,7 @@ dispatchPosition event pos = case posState pos of return pos { posState = PositionCancelled } handlePositionWaitingCloseSubmission pendingOrder = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment if orderDeadline (posSubmissionDeadline pos) lastTs then do case posCurrentOrder pos of @@ -297,7 +298,7 @@ dispatchPosition event pos = case posState pos of _ -> return pos handlePositionWaitingClose = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment if orderDeadline (posExecutionDeadline pos) lastTs then do case posCurrentOrder pos of @@ -335,7 +336,7 @@ dispatchPosition event pos = case posState pos of newPosition :: (StateHasPositions s, MonadRobot m c s) => Order -> T.Text -> TickerId -> Operation -> Int -> NominalDiffTime -> m Position newPosition order account tickerId operation quantity submissionDeadline = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment let position = Position { posId = [st|%?/%?/%?/%?/%?|] account tickerId operation quantity lastTs, posAccount = account, @@ -359,7 +360,7 @@ newPosition order account tickerId operation quantity submissionDeadline = do reapDeadPositions :: (StateHasPositions s) => EventCallback c s reapDeadPositions _ = do - ts <- seLastTimestamp <$> getEnvironment + ts <- view seLastTimestamp <$> getEnvironment when (floor (utctDayTime ts) `mod` 300 == 0) $ modifyPositions (L.filter (not . posIsDead)) defaultHandler :: (StateHasPositions s) => EventCallback c s @@ -377,15 +378,15 @@ modifyPosition f oldpos = do getCurrentTicker :: (ParamsHasMainTicker c, MonadRobot m c s) => m [Bar] getCurrentTicker = do - bars <- seBars <$> getEnvironment - maybeBars <- flip M.lookup bars . mainTicker <$> getConfig + mainTicker' <- mainTicker <$> getConfig + maybeBars <- view (seBars . at mainTicker') <$> getEnvironment case maybeBars of Just b -> return $ bsBars b _ -> return [] getCurrentTickerSeries :: (ParamsHasMainTicker c, MonadRobot m c s) => m (Maybe BarSeries) getCurrentTickerSeries = do - bars <- seBars <$> getEnvironment + bars <- view seBars <$> getEnvironment flip M.lookup bars . mainTicker <$> getConfig getLastActivePosition :: (StateHasPositions s, MonadRobot m c s) => m (Maybe Position) @@ -449,7 +450,7 @@ onActionCompletedEvent event f = case event of enterAtMarket :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Operation -> m Position enterAtMarket signalName operation = do env <- getEnvironment - enterAtMarketWithParams (seAccount env) (seVolume env) (SignalId (seInstanceId env) signalName "") operation + enterAtMarketWithParams (env ^. seAccount) (env ^. seVolume) (SignalId (env ^. seInstanceId) signalName "") operation enterAtMarketWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position enterAtMarketWithParams account quantity signalId operation = do @@ -469,12 +470,12 @@ enterAtMarketWithParams account quantity signalId operation = do enterAtLimit :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Operation -> m Position enterAtLimit timeToCancel signalName price operation = do env <- getEnvironment - enterAtLimitWithParams timeToCancel (seAccount env) (seVolume env) (SignalId (seInstanceId env) signalName "") price operation + enterAtLimitWithParams timeToCancel (env ^. seAccount) (env ^. seVolume) (SignalId (env ^. seInstanceId) signalName "") price operation enterAtLimitWithVolume :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position enterAtLimitWithVolume timeToCancel signalName price vol operation = do - acc <- seAccount <$> getEnvironment - inst <- seInstanceId <$> getEnvironment + acc <- view seAccount <$> getEnvironment + inst <- view seInstanceId <$> getEnvironment enterAtLimitWithParams timeToCancel acc vol (SignalId inst signalName "") price operation enterAtLimitWithParams :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position @@ -484,20 +485,20 @@ enterAtLimitWithParams timeToCancel account quantity signalId price operation = enterAtLimitForTickerWithVolume :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position enterAtLimitForTickerWithVolume tickerId timeToCancel signalName price vol operation = do - acc <- seAccount <$> getEnvironment - inst <- seInstanceId <$> getEnvironment + acc <- view seAccount <$> getEnvironment + inst <- view seInstanceId <$> getEnvironment enterAtLimitForTickerWithParams tickerId timeToCancel acc vol (SignalId inst signalName "") price operation enterAtLimitForTicker :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Operation -> m Position enterAtLimitForTicker tickerId timeToCancel signalName price operation = do - acc <- seAccount <$> getEnvironment - inst <- seInstanceId <$> getEnvironment - vol <- seVolume <$> getEnvironment + acc <- view seAccount <$> getEnvironment + inst <- view seInstanceId <$> getEnvironment + vol <- view seVolume <$> getEnvironment enterAtLimitForTickerWithParams tickerId timeToCancel acc vol (SignalId inst signalName "") price operation enterAtLimitForTickerWithParams :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Int -> SignalId -> Price -> Operation -> m Position enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do - lastTs <- seLastTimestamp <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment submitOrder order appendToLog $ [st|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) newPosition order account tickerId operation quantity 20 >>= @@ -532,8 +533,8 @@ enterShortAtLimitForTicker tickerId timeToCancel price signalName = enterAtLimit exitAtMarket :: (StateHasPositions s, MonadRobot m c s) => Position -> T.Text -> m Position exitAtMarket position signalName = do - inst <- seInstanceId <$> getEnvironment - lastTs <- seLastTimestamp <$> getEnvironment + inst <- view seInstanceId <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment case posCurrentOrder position of Just order -> do cancelOrder (orderId order) @@ -563,8 +564,8 @@ exitAtMarket position signalName = do exitAtLimit :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> Price -> Position -> T.Text -> m Position exitAtLimit timeToCancel price position signalName = do - lastTs <- seLastTimestamp <$> getEnvironment - inst <- seInstanceId <$> getEnvironment + lastTs <- view seLastTimestamp <$> getEnvironment + inst <- view seInstanceId <$> getEnvironment case posCurrentOrder position of Just order -> cancelOrder (orderId order) Nothing -> doNothing