Browse Source

tweak(monad): lenses in StrategyEnvironment accessors

stable
Denis Tereshkin 6 years ago
parent
commit
84da78268a
  1. 9
      src/ATrade/Driver/Backtest.hs
  2. 17
      src/ATrade/Driver/Real.hs
  3. 19
      src/ATrade/RoboCom/Monad.hs
  4. 51
      src/ATrade/RoboCom/Positions.hs

9
src/ATrade/Driver/Backtest.hs

@ -20,7 +20,8 @@ import ATrade.Quotes.Finam as QF
import ATrade.RoboCom.Monad (Event (..), EventCallback, import ATrade.RoboCom.Monad (Event (..), EventCallback,
MonadRobot (..), StrategyAction (..), MonadRobot (..), StrategyAction (..),
StrategyEnvironment (..), StrategyEnvironment (..),
appendToLog, runStrategyElement, st) appendToLog, runStrategyElement,
seBars, seLastTimestamp, st)
import ATrade.RoboCom.Positions import ATrade.RoboCom.Positions
import ATrade.RoboCom.Types (BarSeries (..), Ticker (..), import ATrade.RoboCom.Types (BarSeries (..), Ticker (..),
Timeframe (..)) Timeframe (..))
@ -28,6 +29,7 @@ import ATrade.Types
import Conduit (awaitForever, runConduit, yield, import Conduit (awaitForever, runConduit, yield,
(.|)) (.|))
import Control.Exception.Safe import Control.Exception.Safe
import Control.Lens
import Control.Monad.ST (runST) import Control.Monad.ST (runST)
import Control.Monad.State import Control.Monad.State
import Data.Aeson (FromJSON (..), Result (..), import Data.Aeson (FromJSON (..), Result (..),
@ -162,9 +164,8 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do
backtestLoop = awaitForever (\bar -> do backtestLoop = awaitForever (\bar -> do
env <- gets strategyEnvironment env <- gets strategyEnvironment
let oldTimestamp = seLastTimestamp env
let newTimestamp = barTimestamp bar 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 curState <- gets robotState
modify' (\s -> s { strategyEnvironment = newenv }) modify' (\s -> s { strategyEnvironment = newenv })
handleEvents [NewBar bar]) handleEvents [NewBar bar])
@ -232,7 +233,7 @@ backtestMain dataDownloadDelta defaultState initCallback callback = do
order `executeAtPrice` barOpen bar order `executeAtPrice` barOpen bar
executeAtPrice order price = do executeAtPrice order price = do
ts <- seLastTimestamp <$> gets strategyEnvironment ts <- view seLastTimestamp <$> gets strategyEnvironment
modify' (\s -> s { tradesLog = mkTrade order price ts : tradesLog s }) modify' (\s -> s { tradesLog = mkTrade order price ts : tradesLog s })
return $ OrderUpdate (orderId order) Executed return $ OrderUpdate (orderId order) Executed

17
src/ATrade/Driver/Real.hs

@ -31,6 +31,7 @@ import Control.Monad.Reader
import Control.Concurrent hiding (writeChan, readChan, writeList2Chan, yield) import Control.Concurrent hiding (writeChan, readChan, writeList2Chan, yield)
import Control.Concurrent.BoundedChan as BC import Control.Concurrent.BoundedChan as BC
import Control.Exception.Safe import Control.Exception.Safe
import Control.Lens hiding (Context, (.=))
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.List as L import qualified Data.List as L
@ -46,7 +47,7 @@ import Data.Maybe
import Data.Monoid import Data.Monoid
import Database.Redis hiding (info, decode) import Database.Redis hiding (info, decode)
import ATrade.Types 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.BarAggregator
import ATrade.Driver.Real.BrokerClientThread import ATrade.Driver.Real.BrokerClientThread
import ATrade.Driver.Real.QuoteSourceThread import ATrade.Driver.Real.QuoteSourceThread
@ -159,7 +160,7 @@ instance MonadRobot (App c s) c s where
env <- lift $ readIORef envRef env <- lift $ readIORef envRef
nowRef <- asks envLastTimestamp nowRef <- asks envLastTimestamp
now <- lift $ readIORef nowRef now <- lift $ readIORef nowRef
return $ env { seBars = bars agg, seLastTimestamp = now } return $ env & seBars .~ bars agg & seLastTimestamp .~ now
data BigConfig c = BigConfig { data BigConfig c = BigConfig {
confTickers :: [Ticker], confTickers :: [Ticker],
@ -244,11 +245,11 @@ robotMain dataDownloadDelta defaultState initCallback callback = do
storeState params stateRef timersRef storeState params stateRef timersRef
straEnv <- newIORef StrategyEnvironment { straEnv <- newIORef StrategyEnvironment {
seInstanceId = strategyInstanceId . strategyInstanceParams $ strategy, _seInstanceId = strategyInstanceId . strategyInstanceParams $ strategy,
seAccount = strategyAccount . strategyInstanceParams $ strategy, _seAccount = strategyAccount . strategyInstanceParams $ strategy,
seVolume = strategyVolume . strategyInstanceParams $ strategy, _seVolume = strategyVolume . strategyInstanceParams $ strategy,
seBars = M.empty, _seBars = M.empty,
seLastTimestamp = UTCTime (fromGregorian 1970 1 1) 0 _seLastTimestamp = UTCTime (fromGregorian 1970 1 1) 0
} }
-- Event channel is for strategy events, like new tick arrival, or order execution notification -- Event channel is for strategy events, like new tick arrival, or order execution notification
eventChan <- BC.newBoundedChan 1000 eventChan <- BC.newBoundedChan 1000
@ -515,7 +516,7 @@ barStrategyDriver ctx mbSourceTimeframe tickFilter strategy configRef stateRef t
env <- getEnvironment env <- getEnvironment
let newTimestamp = case event of let newTimestamp = case event of
NewTick tick -> timestamp tick NewTick tick -> timestamp tick
_ -> seLastTimestamp env _ -> env ^. seLastTimestamp
nowRef <- asks envLastTimestamp nowRef <- asks envLastTimestamp
lift $ writeIORef nowRef newTimestamp lift $ writeIORef nowRef newTimestamp

19
src/ATrade/RoboCom/Monad.hs

@ -14,6 +14,11 @@ module ATrade.RoboCom.Monad (
RActions, RActions,
REnv, REnv,
StrategyEnvironment(..), StrategyEnvironment(..),
seInstanceId,
seAccount,
seVolume,
seBars,
seLastTimestamp,
StrategyElement, StrategyElement,
runStrategyElement, runStrategyElement,
EventCallback, EventCallback,
@ -31,12 +36,12 @@ import ATrade.Types
import Ether import Ether
import Control.Lens
import Data.Aeson.Types import Data.Aeson.Types
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock import Data.Time.Clock
import Text.Printf.TH import Text.Printf.TH
class (Monad m) => MonadRobot m c s | m -> c, m -> s where class (Monad m) => MonadRobot m c s | m -> c, m -> s where
submitOrder :: Order -> m () submitOrder :: Order -> m ()
cancelOrder :: OrderId -> m () cancelOrder :: OrderId -> m ()
@ -84,12 +89,14 @@ data StrategyAction = ActionOrder Order
| ActionIO Int (IO Value) | ActionIO Int (IO Value)
data StrategyEnvironment = StrategyEnvironment { data StrategyEnvironment = StrategyEnvironment {
seInstanceId :: !T.Text, -- ^ Strategy instance identifier. Should be unique among all strategies (very desirable) _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 _seAccount :: !T.Text, -- ^ Account string to use for this strategy instance. Broker-dependent
seVolume :: !Int, -- ^ Volume to use for this instance (in lots/contracts) _seVolume :: !Int, -- ^ Volume to use for this instance (in lots/contracts)
seBars :: !Bars, -- ^ List of tickers which is used by this strategy _seBars :: !Bars, -- ^ List of tickers which is used by this strategy
seLastTimestamp :: !UTCTime _seLastTimestamp :: !UTCTime
} deriving (Eq) } deriving (Eq)
makeLenses ''StrategyEnvironment
instance Show StrategyAction where instance Show StrategyAction where
show (ActionOrder order) = "ActionOrder " ++ show order show (ActionOrder order) = "ActionOrder " ++ show order

51
src/ATrade/RoboCom/Positions.hs

@ -73,6 +73,7 @@ import ATrade.RoboCom.Monad
import ATrade.RoboCom.Types import ATrade.RoboCom.Types
import ATrade.Types import ATrade.Types
import Control.Lens
import Control.Monad import Control.Monad
import Ether import Ether
@ -186,7 +187,7 @@ dispatchPosition event pos = case posState pos of
PositionCancelled -> handlePositionCancelled pos PositionCancelled -> handlePositionCancelled pos
where where
handlePositionWaitingOpenSubmission pendingOrder = do handlePositionWaitingOpenSubmission pendingOrder = do
lastTs <- 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 return $ pos { posState = PositionCancelled } -- TODO call TimeoutHandler if present
else case event of else case event of
@ -199,7 +200,7 @@ dispatchPosition event pos = case posState pos of
_ -> return pos _ -> return pos
handlePositionWaitingOpen = do handlePositionWaitingOpen = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
case posCurrentOrder pos of case posCurrentOrder pos of
Just order -> if orderDeadline (posExecutionDeadline pos) lastTs Just order -> if orderDeadline (posExecutionDeadline pos) lastTs
then do -- TODO call TimeoutHandler then do -- TODO call TimeoutHandler
@ -238,7 +239,7 @@ dispatchPosition event pos = case posState pos of
return pos return pos
handlePositionOpen = do handlePositionOpen = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
if if
| orderDeadline (posSubmissionDeadline pos) lastTs -> do | orderDeadline (posSubmissionDeadline pos) lastTs -> do
appendToLog $ [st|PositionId: %? : Missed submission deadline: %?, remaining in PositionOpen state|] (posId pos) (posSubmissionDeadline pos) 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 _ -> return pos
handlePositionWaitingPendingCancellation = do handlePositionWaitingPendingCancellation = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
if not $ orderDeadline (posSubmissionDeadline pos) lastTs if not $ orderDeadline (posSubmissionDeadline pos) lastTs
then case (event, posCurrentOrder pos, posNextState pos) of then case (event, posCurrentOrder pos, posNextState pos) of
(OrderUpdate _ newstate, Just _, Just (PositionWaitingCloseSubmission nextOrder)) -> (OrderUpdate _ newstate, Just _, Just (PositionWaitingCloseSubmission nextOrder)) ->
@ -280,7 +281,7 @@ dispatchPosition event pos = case posState pos of
return pos { posState = PositionCancelled } return pos { posState = PositionCancelled }
handlePositionWaitingCloseSubmission pendingOrder = do handlePositionWaitingCloseSubmission pendingOrder = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
if orderDeadline (posSubmissionDeadline pos) lastTs if orderDeadline (posSubmissionDeadline pos) lastTs
then do then do
case posCurrentOrder pos of case posCurrentOrder pos of
@ -297,7 +298,7 @@ dispatchPosition event pos = case posState pos of
_ -> return pos _ -> return pos
handlePositionWaitingClose = do handlePositionWaitingClose = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
if orderDeadline (posExecutionDeadline pos) lastTs if orderDeadline (posExecutionDeadline pos) lastTs
then do then do
case posCurrentOrder pos of 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 :: (StateHasPositions s, MonadRobot m c s) => Order -> T.Text -> TickerId -> Operation -> Int -> NominalDiffTime -> m Position
newPosition order account tickerId operation quantity submissionDeadline = do newPosition order account tickerId operation quantity submissionDeadline = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
let position = Position { let position = Position {
posId = [st|%?/%?/%?/%?/%?|] account tickerId operation quantity lastTs, posId = [st|%?/%?/%?/%?/%?|] account tickerId operation quantity lastTs,
posAccount = account, posAccount = account,
@ -359,7 +360,7 @@ newPosition order account tickerId operation quantity submissionDeadline = do
reapDeadPositions :: (StateHasPositions s) => EventCallback c s reapDeadPositions :: (StateHasPositions s) => EventCallback c s
reapDeadPositions _ = do reapDeadPositions _ = do
ts <- seLastTimestamp <$> getEnvironment ts <- view seLastTimestamp <$> getEnvironment
when (floor (utctDayTime ts) `mod` 300 == 0) $ modifyPositions (L.filter (not . posIsDead)) when (floor (utctDayTime ts) `mod` 300 == 0) $ modifyPositions (L.filter (not . posIsDead))
defaultHandler :: (StateHasPositions s) => EventCallback c s defaultHandler :: (StateHasPositions s) => EventCallback c s
@ -377,15 +378,15 @@ modifyPosition f oldpos = do
getCurrentTicker :: (ParamsHasMainTicker c, MonadRobot m c s) => m [Bar] getCurrentTicker :: (ParamsHasMainTicker c, MonadRobot m c s) => m [Bar]
getCurrentTicker = do getCurrentTicker = do
bars <- seBars <$> getEnvironment mainTicker' <- mainTicker <$> getConfig
maybeBars <- flip M.lookup bars . mainTicker <$> getConfig maybeBars <- view (seBars . at mainTicker') <$> getEnvironment
case maybeBars of case maybeBars of
Just b -> return $ bsBars b Just b -> return $ bsBars b
_ -> return [] _ -> return []
getCurrentTickerSeries :: (ParamsHasMainTicker c, MonadRobot m c s) => m (Maybe BarSeries) getCurrentTickerSeries :: (ParamsHasMainTicker c, MonadRobot m c s) => m (Maybe BarSeries)
getCurrentTickerSeries = do getCurrentTickerSeries = do
bars <- seBars <$> getEnvironment bars <- view seBars <$> getEnvironment
flip M.lookup bars . mainTicker <$> getConfig flip M.lookup bars . mainTicker <$> getConfig
getLastActivePosition :: (StateHasPositions s, MonadRobot m c s) => m (Maybe Position) 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 :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Operation -> m Position
enterAtMarket signalName operation = do enterAtMarket signalName operation = do
env <- getEnvironment 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 :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => T.Text -> Int -> SignalId -> Operation -> m Position
enterAtMarketWithParams account quantity signalId operation = do 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 :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Operation -> m Position
enterAtLimit timeToCancel signalName price operation = do enterAtLimit timeToCancel signalName price operation = do
env <- getEnvironment 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 :: (StateHasPositions s, ParamsHasMainTicker c, MonadRobot m c s) => NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position
enterAtLimitWithVolume timeToCancel signalName price vol operation = do enterAtLimitWithVolume timeToCancel signalName price vol operation = do
acc <- seAccount <$> getEnvironment acc <- view seAccount <$> getEnvironment
inst <- seInstanceId <$> getEnvironment inst <- view seInstanceId <$> getEnvironment
enterAtLimitWithParams timeToCancel acc vol (SignalId inst signalName "") price operation 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 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 :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Int -> Operation -> m Position
enterAtLimitForTickerWithVolume tickerId timeToCancel signalName price vol operation = do enterAtLimitForTickerWithVolume tickerId timeToCancel signalName price vol operation = do
acc <- seAccount <$> getEnvironment acc <- view seAccount <$> getEnvironment
inst <- seInstanceId <$> getEnvironment inst <- view seInstanceId <$> getEnvironment
enterAtLimitForTickerWithParams tickerId timeToCancel acc vol (SignalId inst signalName "") price operation 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 :: (StateHasPositions s, MonadRobot m c s) => TickerId -> NominalDiffTime -> T.Text -> Price -> Operation -> m Position
enterAtLimitForTicker tickerId timeToCancel signalName price operation = do enterAtLimitForTicker tickerId timeToCancel signalName price operation = do
acc <- seAccount <$> getEnvironment acc <- view seAccount <$> getEnvironment
inst <- seInstanceId <$> getEnvironment inst <- view seInstanceId <$> getEnvironment
vol <- seVolume <$> getEnvironment vol <- view seVolume <$> getEnvironment
enterAtLimitForTickerWithParams tickerId timeToCancel acc vol (SignalId inst signalName "") price operation 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 :: (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 enterAtLimitForTickerWithParams tickerId timeToCancel account quantity signalId price operation = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
submitOrder order submitOrder order
appendToLog $ [st|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs) appendToLog $ [st|enterAtLimit: %?, deadline: %?|] tickerId (timeToCancel `addUTCTime` lastTs)
newPosition order account tickerId operation quantity 20 >>= 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 :: (StateHasPositions s, MonadRobot m c s) => Position -> T.Text -> m Position
exitAtMarket position signalName = do exitAtMarket position signalName = do
inst <- seInstanceId <$> getEnvironment inst <- view seInstanceId <$> getEnvironment
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
case posCurrentOrder position of case posCurrentOrder position of
Just order -> do Just order -> do
cancelOrder (orderId order) 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 :: (StateHasPositions s, MonadRobot m c s) => NominalDiffTime -> Price -> Position -> T.Text -> m Position
exitAtLimit timeToCancel price position signalName = do exitAtLimit timeToCancel price position signalName = do
lastTs <- seLastTimestamp <$> getEnvironment lastTs <- view seLastTimestamp <$> getEnvironment
inst <- seInstanceId <$> getEnvironment inst <- view seInstanceId <$> getEnvironment
case posCurrentOrder position of case posCurrentOrder position of
Just order -> cancelOrder (orderId order) Just order -> cancelOrder (orderId order)
Nothing -> doNothing Nothing -> doNothing

Loading…
Cancel
Save