15 changed files with 53 additions and 335 deletions
@ -1,102 +0,0 @@ |
|||||||
{-# LANGUAGE OverloadedStrings #-} |
|
||||||
|
|
||||||
module ATrade.Backtest.Execution ( |
|
||||||
mkExecutionAgent, |
|
||||||
ExecutionAgent(..), |
|
||||||
executePending, |
|
||||||
executeStep |
|
||||||
) where |
|
||||||
|
|
||||||
import qualified Data.Text as T |
|
||||||
import qualified Data.Map as M |
|
||||||
import qualified Data.List as L |
|
||||||
import ATrade.Types |
|
||||||
import ATrade.Strategy.Types |
|
||||||
import ATrade.Strategy |
|
||||||
import Control.Monad.State |
|
||||||
import Control.Monad.Trans.Writer |
|
||||||
import Data.Decimal |
|
||||||
import Data.Time.Clock |
|
||||||
import Data.Time.Calendar |
|
||||||
|
|
||||||
data Position = Position { |
|
||||||
ticker :: T.Text, |
|
||||||
balance :: Int } |
|
||||||
|
|
||||||
data ExecutionAgent = ExecutionAgent { |
|
||||||
pendingOrders :: [Order], |
|
||||||
cash :: Decimal, |
|
||||||
currentTime :: UTCTime, |
|
||||||
orderIdCounter :: Integer |
|
||||||
} |
|
||||||
|
|
||||||
mkExecutionAgent startCash = ExecutionAgent { pendingOrders = [], |
|
||||||
cash = startCash, |
|
||||||
currentTime = UTCTime (fromGregorian 1970 1 1) 0, |
|
||||||
orderIdCounter = 1 } |
|
||||||
|
|
||||||
executeAtPrice :: Order -> Decimal -> WriterT [Event] (State ExecutionAgent) () |
|
||||||
executeAtPrice order price = do |
|
||||||
when (orderState order == Unsubmitted) $ tell [OrderSubmitted order] |
|
||||||
tell [OrderUpdate (orderId order) Executed] |
|
||||||
timestamp <- gets currentTime |
|
||||||
tell [NewTrade (mkTradeForOrder timestamp order price)] |
|
||||||
|
|
||||||
case orderOperation order of |
|
||||||
Buy -> modify' (\agent -> agent { cash = cash agent - price * realFracToDecimal 10 (toRational $ orderQuantity order) }) |
|
||||||
Sell -> modify' (\agent -> agent { cash = cash agent + price * realFracToDecimal 10 (toRational $ orderQuantity order) }) |
|
||||||
|
|
||||||
mkTradeForOrder timestamp order price = Trade { tradeOrderId = orderId order, |
|
||||||
tradePrice = price, |
|
||||||
tradeQuantity = orderQuantity order, |
|
||||||
tradeVolume = price * realFracToDecimal 10 (toRational $ orderQuantity order), |
|
||||||
tradeVolumeCurrency = "TEST_CURRENCY", |
|
||||||
tradeOperation = orderOperation order, |
|
||||||
tradeAccount = orderAccountId order, |
|
||||||
tradeSecurity = orderSecurity order, |
|
||||||
tradeTimestamp = timestamp, |
|
||||||
tradeSignalId = orderSignalId order } |
|
||||||
|
|
||||||
|
|
||||||
executePending :: Bars -> WriterT [Event] (State ExecutionAgent) () |
|
||||||
executePending bars = do |
|
||||||
orders <- gets pendingOrders |
|
||||||
let (executedOrders, leftover) = L.partition shouldExecute orders |
|
||||||
|
|
||||||
mapM_ executeAtOrdersPrice executedOrders |
|
||||||
modify' (\s -> s { pendingOrders = leftover } ) |
|
||||||
where |
|
||||||
executeAtOrdersPrice order = case orderPrice order of |
|
||||||
Limit price -> executeAtPrice order price |
|
||||||
_ -> return () -- TODO handle stops |
|
||||||
|
|
||||||
shouldExecute order = case M.lookup (orderSecurity order) bars of |
|
||||||
Just (DataSeries ((ts, bar) : _)) -> case orderPrice order of |
|
||||||
Limit price -> crosses bar price |
|
||||||
_ -> False |
|
||||||
Nothing -> False |
|
||||||
|
|
||||||
crosses bar price = (barClose bar > price && barOpen bar < price) || (barClose bar < price && barOpen bar > price) |
|
||||||
|
|
||||||
executeStep :: Bars -> [Order] -> WriterT [Event] (State ExecutionAgent) () |
|
||||||
executeStep bars orders = do |
|
||||||
-- Assign consecutive IDs |
|
||||||
orders' <- mapM (\o -> do |
|
||||||
id <- gets orderIdCounter |
|
||||||
modify(\s -> s { orderIdCounter = id + 1 }) |
|
||||||
return o { orderId = id }) orders |
|
||||||
|
|
||||||
let (executableNow, pending) = L.partition isExecutableNow orders' |
|
||||||
mapM_ (executeOrderAtLastPrice bars) executableNow |
|
||||||
modify' (\s -> s { pendingOrders = pending ++ pendingOrders s }) |
|
||||||
|
|
||||||
where |
|
||||||
isExecutableNow order = case M.lookup (orderSecurity order) bars of |
|
||||||
Just (DataSeries (x:xs)) -> case orderPrice order of |
|
||||||
Limit price -> (orderOperation order == Buy && price >= (barClose . snd) x) || (orderOperation order == Sell && price <= (barClose . snd) x) |
|
||||||
Market -> True |
|
||||||
_ -> False |
|
||||||
|
|
||||||
executeOrderAtLastPrice bars order = case M.lookup (orderSecurity order) bars of |
|
||||||
Just (DataSeries ((ts, bar) : _)) -> executeAtPrice order (barClose bar) |
|
||||||
_ -> return () |
|
||||||
@ -1,153 +0,0 @@ |
|||||||
{-# OPTIONS_GHC -Wno-type-defaults #-} |
|
||||||
|
|
||||||
module ATrade.Forums.Smartlab ( |
|
||||||
NewsItem(..), |
|
||||||
IndexItem(..), |
|
||||||
getIndex, |
|
||||||
getItem |
|
||||||
) where |
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as BL |
|
||||||
import qualified Data.List as L |
|
||||||
import Data.Maybe |
|
||||||
import qualified Data.Text as T |
|
||||||
import Data.Text.Encoding |
|
||||||
import Data.Time.Calendar |
|
||||||
import Data.Time.Clock |
|
||||||
import Network.HTTP.Simple |
|
||||||
import Safe |
|
||||||
import Text.HTML.TagSoup |
|
||||||
import Text.Parsec |
|
||||||
import Text.Parsec.Text |
|
||||||
import Text.StringLike |
|
||||||
|
|
||||||
import Debug.Trace |
|
||||||
|
|
||||||
data NewsItem = NewsItem { |
|
||||||
niUrl :: !T.Text, |
|
||||||
niHeader :: !T.Text, |
|
||||||
niText :: !T.Text, |
|
||||||
niAuthor :: !T.Text, |
|
||||||
niPubTime :: !UTCTime |
|
||||||
} deriving (Show, Eq) |
|
||||||
|
|
||||||
data IndexItem = IndexItem { |
|
||||||
iiUrl :: !T.Text, |
|
||||||
iiTitle :: !T.Text, |
|
||||||
iiPubTime :: !UTCTime |
|
||||||
} deriving (Show, Eq) |
|
||||||
|
|
||||||
monthNames :: [T.Text] |
|
||||||
monthNames = fmap T.pack ["января", "февраля", "марта", "апреля", "мая", "июня", "июля", "августа", "сентября", "октября", "ноября", "декабря"] |
|
||||||
|
|
||||||
extractBetween :: StringLike str => String -> [Tag str] -> [Tag str] |
|
||||||
extractBetween tagName = takeWhile (~/= closeTag) . dropWhile (~/= openTag) |
|
||||||
where |
|
||||||
openTag = "<" ++ tagName ++ ">" |
|
||||||
closeTag = "</" ++ tagName ++ ">" |
|
||||||
|
|
||||||
matchClass :: T.Text -> T.Text -> Tag T.Text -> Bool |
|
||||||
matchClass _ className (TagOpen _ attrs) = case L.lookup (T.pack "class") attrs of |
|
||||||
Just klass -> className `L.elem` T.words klass |
|
||||||
Nothing -> False |
|
||||||
|
|
||||||
matchClass _ _ _ = False |
|
||||||
|
|
||||||
parseTimestamp :: T.Text -> Maybe UTCTime |
|
||||||
parseTimestamp text = case parse timestampParser "" text of |
|
||||||
Left _ -> Nothing |
|
||||||
Right val -> Just val |
|
||||||
where |
|
||||||
timestampParser :: Parser UTCTime |
|
||||||
timestampParser = do |
|
||||||
spaces |
|
||||||
day <- read <$> many1 digit |
|
||||||
spaces |
|
||||||
monthName <- T.pack <$> many1 letter |
|
||||||
case L.elemIndex monthName monthNames of |
|
||||||
Nothing -> fail "Can't parse month" |
|
||||||
Just month -> do |
|
||||||
spaces |
|
||||||
year <- fromIntegral . read <$> many1 digit |
|
||||||
_ <- char ',' |
|
||||||
spaces |
|
||||||
hour <- fromIntegral . read <$> many1 digit |
|
||||||
_ <- char ':' |
|
||||||
minute <- fromIntegral . read <$> many1 digit |
|
||||||
return $ UTCTime (fromGregorian year (month + 1) day) (hour * 3600 + minute * 60) |
|
||||||
|
|
||||||
getItem :: IndexItem -> IO (Maybe NewsItem) |
|
||||||
getItem indexItem = do |
|
||||||
rq <- parseRequest $ T.unpack (iiUrl indexItem) |
|
||||||
resp <- httpLBS rq |
|
||||||
if getResponseStatusCode resp == 200 |
|
||||||
then return . parseItem . decodeUtf8 . BL.toStrict . getResponseBody $ resp |
|
||||||
else return Nothing |
|
||||||
where |
|
||||||
parseItem rawHtml = case parseTimestamp timestamp of |
|
||||||
Just itemPubtime -> Just NewsItem { |
|
||||||
niUrl = iiUrl indexItem, |
|
||||||
niHeader = itemHeader, |
|
||||||
niText = itemText, |
|
||||||
niAuthor = itemAuthor, |
|
||||||
niPubTime = itemPubtime |
|
||||||
} |
|
||||||
Nothing -> Nothing |
|
||||||
where |
|
||||||
itemHeader = innerText . |
|
||||||
extractBetween "span" . |
|
||||||
extractBetween "h1" . |
|
||||||
dropWhile (not . matchClass (T.pack "div") (T.pack "topic")) $ tags |
|
||||||
|
|
||||||
itemText = innerText . |
|
||||||
extractBetween "div" . |
|
||||||
dropWhile (not . matchClass (T.pack "div") (T.pack "content")) . |
|
||||||
dropWhile (~/= "<div id=content_box>") $ tags |
|
||||||
|
|
||||||
itemAuthor = innerText . |
|
||||||
extractBetween "li" . |
|
||||||
dropWhile (not . matchClass (T.pack "li") (T.pack "author")) $ tags |
|
||||||
|
|
||||||
timestamp = traceShowId $ innerText . |
|
||||||
extractBetween "li" . |
|
||||||
dropWhile (not . matchClass (T.pack "li") (T.pack "date")) $ tags |
|
||||||
|
|
||||||
tags = parseTags rawHtml |
|
||||||
|
|
||||||
|
|
||||||
getIndex :: T.Text -> Int -> IO ([IndexItem], Bool) |
|
||||||
getIndex rootUrl pageNumber = do |
|
||||||
rq <- parseRequest $ T.unpack $ makeUrl rootUrl pageNumber |
|
||||||
resp <- httpLBS rq |
|
||||||
return $ if getResponseStatusCode resp == 200 |
|
||||||
then parseIndex . decodeUtf8 . BL.toStrict . getResponseBody $ resp |
|
||||||
else ([], False) |
|
||||||
where |
|
||||||
parseIndex :: T.Text -> ([IndexItem], Bool) |
|
||||||
parseIndex x = (mapMaybe parseIndexEntry $ partitions (matchClass (T.pack "div") (T.pack "topic")) $ parseTags x, hasNextPage $ parseTags x) |
|
||||||
|
|
||||||
parseIndexEntry :: [Tag T.Text] -> Maybe IndexItem |
|
||||||
parseIndexEntry divTag = do |
|
||||||
a <- headMay . dropWhile (~/= "<a>") $ divTag |
|
||||||
let text = innerText . takeWhile (~/= "</a>") . dropWhile (~/= "<a>") $ divTag |
|
||||||
case a of |
|
||||||
TagOpen _ attr -> do |
|
||||||
href <- L.lookup (T.pack "href") attr |
|
||||||
ts <- parseTimestamp (innerText $ takeWhile (~/= "</li>") . dropWhile (not . matchClass (T.pack "li") (T.pack "date")) $ divTag) |
|
||||||
Just IndexItem { iiUrl = href, |
|
||||||
iiTitle = text, |
|
||||||
iiPubTime = ts } |
|
||||||
_ -> Nothing |
|
||||||
|
|
||||||
|
|
||||||
makeUrl root pagenumber |
|
||||||
| pagenumber == 0 || pagenumber == 1 = root |
|
||||||
| otherwise = root `T.append` (T.pack "/page") `T.append` T.pack (show pagenumber) |
|
||||||
|
|
||||||
hasNextPage tags = if pageNumber <= 1 |
|
||||||
then paginationLinksCount > 0 |
|
||||||
else paginationLinksCount > 1 |
|
||||||
where |
|
||||||
paginationLinksCount = length . filter (~== "<a>") . extractBetween "p" . dropWhile (~/= "<div id=pagination>") $ tags |
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in new issue