From dd1cdd1f71051c99a18013de8b759f8361be08ef Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Thu, 20 Jun 2019 15:12:12 +0700 Subject: [PATCH] time parsing --- src/ATrade/MDS/HistoryServer.hs | 42 +++++----- src/ATrade/MDS/Protocol.hs | 80 ++++++++++++------ src/ATrade/Quotes/Finam.hs | 144 ++++++++++++++++---------------- stack.yaml | 4 +- 4 files changed, 148 insertions(+), 122 deletions(-) diff --git a/src/ATrade/MDS/HistoryServer.hs b/src/ATrade/MDS/HistoryServer.hs index e1d06b3..6997aec 100644 --- a/src/ATrade/MDS/HistoryServer.hs +++ b/src/ATrade/MDS/HistoryServer.hs @@ -5,22 +5,22 @@ module ATrade.MDS.HistoryServer ( startHistoryServer ) where -import System.ZMQ4 -import ATrade.Types -import ATrade.MDS.Database -import ATrade.MDS.Protocol -import Control.Concurrent -import Control.Monad -import Data.Aeson -import Data.List.NonEmpty -import Data.Time.Clock.POSIX -import qualified Data.Vector as V -import Safe -import qualified Data.Text as T -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Binary.Get -import Data.Binary.Put +import ATrade.MDS.Database +import ATrade.MDS.Protocol +import ATrade.Types +import Control.Concurrent +import Control.Monad +import Data.Aeson +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.List.NonEmpty +import qualified Data.Text as T +import Data.Time.Clock.POSIX +import qualified Data.Vector as V +import Safe +import System.ZMQ4 data HistoryServer = HistoryServer ThreadId ThreadId @@ -47,7 +47,7 @@ serveQHP db sock = forever $ do let maybeCmd = (BL.fromStrict <$> rq `atMay` 2) >>= decode case (headMay rq, maybeCmd) of (Just peerId, Just cmd) -> handleCmd peerId cmd - _ -> return () + _ -> return () where handleCmd :: B.ByteString -> QHPRequest -> IO () handleCmd peerId cmd = case cmd of @@ -56,8 +56,8 @@ serveQHP db sock = forever $ do let bytes = serializeBars $ V.concat $ fmap snd qdata sendMulti sock $ peerId :| B.empty : [BL.toStrict bytes] serializeBars :: V.Vector Bar -> BL.ByteString - serializeBars bars = runPut $ V.forM_ bars serializeBar - serializeBar bar = do + serializeBars bars = runPut $ V.forM_ bars serializeBar' + serializeBar' bar = do putWord64le (truncate . utcTimeToPOSIXSeconds . barTimestamp $ bar) putDoublele (toDouble . barOpen $ bar) putDoublele (toDouble . barHigh $ bar) @@ -82,9 +82,9 @@ serveHAP db sock = forever $ do putData db (hapTicker rq) (TimeInterval (hapStartTime rq) (hapEndTime rq)) (Timeframe $ hapTimeframeSec rq) (V.fromList bars) sendMulti sock $ peerId :| B.empty : ["OK"] - deserializeBars tickerId input = + deserializeBars tickerId input = case runGetOrFail parseBar input of - Left _ -> [] + Left _ -> [] Right (rest, _, bar) -> bar : deserializeBars tickerId rest where parseBar = do diff --git a/src/ATrade/MDS/Protocol.hs b/src/ATrade/MDS/Protocol.hs index 0723f9c..b3626de 100644 --- a/src/ATrade/MDS/Protocol.hs +++ b/src/ATrade/MDS/Protocol.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} module ATrade.MDS.Protocol ( QHPRequest(..), @@ -9,10 +10,13 @@ module ATrade.MDS.Protocol ( -- import ATrade.Types -import Data.Aeson -import Data.Aeson.Types -import Data.Time.Clock -import qualified Data.Text as T +import Control.Monad +import Data.Aeson +import Data.Aeson.Types as Aeson +import Data.Attoparsec.Text as Attoparsec +import qualified Data.Text as T +import Data.Time.Calendar +import Data.Time.Clock data Period = Period1Min | @@ -26,41 +30,41 @@ data Period = deriving (Eq) instance Show Period where - show Period1Min = "M1" - show Period5Min = "M5" + show Period1Min = "M1" + show Period5Min = "M5" show Period15Min = "M15" show Period30Min = "M30" - show PeriodHour = "H1" - show PeriodDay = "D" - show PeriodWeek = "W" + show PeriodHour = "H1" + show PeriodDay = "D" + show PeriodWeek = "W" show PeriodMonth = "MN" periodSeconds :: Period -> Int -periodSeconds Period1Min = 60 -periodSeconds Period5Min = 60 * 5 +periodSeconds Period1Min = 60 +periodSeconds Period5Min = 60 * 5 periodSeconds Period15Min = 60 * 15 periodSeconds Period30Min = 60 * 30 -periodSeconds PeriodHour = 3600 -periodSeconds PeriodDay = 86400 -periodSeconds PeriodWeek = 86400 * 7 +periodSeconds PeriodHour = 3600 +periodSeconds PeriodDay = 86400 +periodSeconds PeriodWeek = 86400 * 7 periodSeconds PeriodMonth = 86400 * 7 * 4 data QHPRequest = QHPRequest { - rqTicker :: T.Text, + rqTicker :: T.Text, rqStartTime :: UTCTime, - rqEndTime :: UTCTime, - rqPeriod :: Period + rqEndTime :: UTCTime, + rqPeriod :: Period } deriving (Show, Eq) - + instance FromJSON QHPRequest where parseJSON = withObject "Request" $ \v -> QHPRequest <$> v .: "ticker" <*> - v .: "from" <*> - v .: "to" <*> + (v .: "from" >>= parseTime) <*> + (v .: "to" >>= parseTime) <*> (v .: "timeframe" >>= parseTf) where - parseTf :: T.Text -> Parser Period + parseTf :: T.Text -> Aeson.Parser Period parseTf t = if | t == "M1" -> return Period1Min | t == "M5" -> return Period5Min @@ -72,17 +76,39 @@ instance FromJSON QHPRequest where | t == "MN" -> return PeriodMonth | otherwise -> fail "Invalid period specified" + data HAPRequest = HAPRequest { - hapTicker :: T.Text, - hapStartTime :: UTCTime, - hapEndTime :: UTCTime, + hapTicker :: T.Text, + hapStartTime :: UTCTime, + hapEndTime :: UTCTime, hapTimeframeSec :: Int } deriving (Show, Eq) instance FromJSON HAPRequest where parseJSON = withObject "Request" $ \v -> HAPRequest <$> v .: "ticker" <*> - v .: "start_time" <*> - v .: "end_time" <*> + (v .: "start_time" >>= parseTime) <*> + (v .: "end_time" >>= parseTime) <*> v .: "timeframe_sec" + +parseTime :: T.Text -> Aeson.Parser UTCTime +parseTime text = case Attoparsec.parse timeParse text of + Done _ r -> return r + _ -> fail $ "Can't parse time: " ++ T.unpack text +timeParse :: Attoparsec.Parser UTCTime +timeParse = do + year <- decimal + void $ char '-' + month <- decimal + void $ char '-' + day <- decimal + void $ char 'T' + hour <- decimal + void $ char '-' + minute <- decimal + void $ char '-' + sec <- decimal + case fromGregorianValid year month day of + Just gregorianDay -> return $ UTCTime gregorianDay (secondsToDiffTime $ hour * 3600 + minute * 60 + sec) + _ -> fail "Can't parse date: invalid values" diff --git a/src/ATrade/Quotes/Finam.hs b/src/ATrade/Quotes/Finam.hs index c750ffa..23a5c5a 100644 --- a/src/ATrade/Quotes/Finam.hs +++ b/src/ATrade/Quotes/Finam.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} module ATrade.Quotes.Finam ( downloadFinamSymbols, @@ -17,32 +17,32 @@ module ATrade.Quotes.Finam ( Row(..) ) where -import qualified Data.Text as T -import qualified Data.Text.ICU.Convert as TC -import Data.Time.Calendar -import Network.Wreq -import Control.Lens -import Data.Either.Combinators -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString as B -import Safe -import qualified Data.Map as M -import Text.Parsec -import Text.ParserCombinators.Parsec.Char -import Text.ParserCombinators.Parsec.Number -import Data.List -import Data.Maybe -import Control.Error.Util -import Data.Text.Format -import Data.Csv -import Data.Time.Format -import qualified Data.ByteString.Char8 as B8 -import Data.Time.Clock -import Data.Decimal -import Control.Monad -import Control.Exception -import qualified Data.Vector as V -import System.Log.Logger +import Control.Error.Util +import Control.Exception +import Control.Lens +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import Data.Csv +import Data.Decimal +import Data.Either.Combinators +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Data.Text.Format +import qualified Data.Text.ICU.Convert as TC +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Format +import qualified Data.Vector as V +import Network.Wreq +import Safe +import System.Log.Logger +import Text.Parsec +import Text.ParserCombinators.Parsec.Char +import Text.ParserCombinators.Parsec.Number data Period = PeriodTick | @@ -58,28 +58,28 @@ data Period = deriving (Show, Eq) instance Enum Period where - fromEnum PeriodTick = 1 - fromEnum Period1Min = 2 - fromEnum Period5Min = 3 + fromEnum PeriodTick = 1 + fromEnum Period1Min = 2 + fromEnum Period5Min = 3 fromEnum Period10Min = 4 fromEnum Period15Min = 5 fromEnum Period30Min = 6 - fromEnum PeriodHour = 7 - fromEnum PeriodDay = 8 - fromEnum PeriodWeek = 9 + fromEnum PeriodHour = 7 + fromEnum PeriodDay = 8 + fromEnum PeriodWeek = 9 fromEnum PeriodMonth = 10 - toEnum 1 = PeriodTick - toEnum 2 = Period1Min - toEnum 3 = Period5Min - toEnum 4 = Period10Min - toEnum 5 = Period15Min - toEnum 6 = Period30Min - toEnum 7 = PeriodHour - toEnum 8 = PeriodDay - toEnum 9 = PeriodWeek + toEnum 1 = PeriodTick + toEnum 2 = Period1Min + toEnum 3 = Period5Min + toEnum 4 = Period10Min + toEnum 5 = Period15Min + toEnum 6 = Period30Min + toEnum 7 = PeriodHour + toEnum 8 = PeriodDay + toEnum 9 = PeriodWeek toEnum 10 = PeriodMonth - toEnum _ = PeriodDay + toEnum _ = PeriodDay data DateFormat = FormatYYYYMMDD | @@ -91,8 +91,8 @@ data DateFormat = instance Enum DateFormat where fromEnum FormatYYYYMMDD = 1 - fromEnum FormatYYMMDD = 2 - fromEnum FormatDDMMYY = 3 + fromEnum FormatYYMMDD = 2 + fromEnum FormatDDMMYY = 3 fromEnum FormatDD_MM_YY = 4 fromEnum FormatMM_DD_YY = 5 @@ -112,10 +112,10 @@ data TimeFormat = deriving (Show, Eq) instance Enum TimeFormat where - fromEnum FormatHHMMSS = 1 - fromEnum FormatHHMM = 2 + fromEnum FormatHHMMSS = 1 + fromEnum FormatHHMM = 2 fromEnum FormatHH_MM_SS = 3 - fromEnum FormatHH_MM = 4 + fromEnum FormatHH_MM = 4 toEnum 1 = FormatHHMMSS toEnum 2 = FormatHHMM @@ -132,11 +132,11 @@ data FieldSeparator = deriving (Show, Eq) instance Enum FieldSeparator where - fromEnum SeparatorComma = 1 - fromEnum SeparatorPeriod = 2 + fromEnum SeparatorComma = 1 + fromEnum SeparatorPeriod = 2 fromEnum SeparatorSemicolon = 3 - fromEnum SeparatorTab = 4 - fromEnum SeparatorSpace = 5 + fromEnum SeparatorTab = 4 + fromEnum SeparatorSpace = 5 toEnum 1 = SeparatorComma toEnum 2 = SeparatorPeriod @@ -146,15 +146,15 @@ instance Enum FieldSeparator where toEnum _ = SeparatorComma data RequestParams = RequestParams { - ticker :: T.Text, - startDate :: Day, - endDate :: Day, - period :: Period, - dateFormat :: DateFormat, - timeFormat :: TimeFormat, + ticker :: T.Text, + startDate :: Day, + endDate :: Day, + period :: Period, + dateFormat :: DateFormat, + timeFormat :: TimeFormat, fieldSeparator :: FieldSeparator, - includeHeader :: Bool, - fillEmpty :: Bool + includeHeader :: Bool, + fillEmpty :: Bool } defaultParams = RequestParams { @@ -170,9 +170,9 @@ defaultParams = RequestParams { } data Symbol = Symbol { - symCode :: T.Text, - symName :: T.Text, - symId :: Integer, + symCode :: T.Text, + symName :: T.Text, + symId :: Integer, symMarketCode :: Integer, symMarketName :: T.Text } @@ -180,11 +180,11 @@ data Symbol = Symbol { data Row = Row { rowTicker :: T.Text, - rowTime :: UTCTime, - rowOpen :: Decimal, - rowHigh :: Decimal, - rowLow :: Decimal, - rowClose :: Decimal, + rowTime :: UTCTime, + rowOpen :: Decimal, + rowHigh :: Decimal, + rowLow :: Decimal, + rowClose :: Decimal, rowVolume :: Integer } deriving (Show, Eq) @@ -223,7 +223,7 @@ downloadAndParseQuotes params = downloadAndParseQuotes' params 3 parseQuotes :: B.ByteString -> Maybe [Row] parseQuotes csvData = case decode HasHeader $ BL.fromStrict csvData of - Left _ -> Nothing + Left _ -> Nothing Right d -> Just $ V.toList d downloadQuotes :: RequestParams -> IO (Maybe B.ByteString) @@ -231,7 +231,7 @@ downloadQuotes params = do symbols <- downloadFinamSymbols case requestUrl symbols params of Just (url, options) -> do - resp <- getWith options url + resp <- getWith options url return $ Just $ BL.toStrict $ resp ^. responseBody Nothing -> return Nothing @@ -269,7 +269,7 @@ requestUrl symbols params = case getFinamCode symbols (ticker params) of getFinamCode :: [Symbol] -> T.Text -> Maybe (Integer, Integer) getFinamCode symbols ticker = case find (\x -> symCode x == ticker && symMarketCode x `notElem` archives) symbols of Just sym -> Just (symId sym, symMarketCode sym) - Nothing -> Nothing + Nothing -> Nothing downloadFinamSymbols :: IO [Symbol] downloadFinamSymbols = do diff --git a/stack.yaml b/stack.yaml index 4b6c3b3..d6e3b0e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-11.9 +resolver: lts-12.9 # User packages to be built. # Various formats can be used as shown in the example below. @@ -41,7 +41,7 @@ packages: - '../zeromq4-haskell-zap' # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: ["HDBC-sqlite3-2.3.3.1", "datetime-0.3.1", "th-printf-0.5.1"] +extra-deps: ["HDBC-sqlite3-2.3.3.1", "datetime-0.3.1", "th-printf-0.5.1", "text-format-0.3.2"] # Override default flag values for local packages and extra-deps flags: {}