diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 index 0000000..93e9ab1 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QuasiQuotes #-} + +import Criterion.Main +import qualified Data.ByteString as BS +import Data.Text.Encoding +import Data.Text.Encoding.Error +import Safe +import Text.RawString.QQ +import Text.XML.Light.Input (parseXMLDoc) +import Transaq +import Transaq.Parsing + +validClient = + [r| + + TYPE + CURRENCY + MARKET + UNION + FORTS_ACC + + |] :: BS.ByteString + +validCandleKinds = + [r| + + + 4 + 600 + M10 + + + 5 + 900 + M15 + + + |] :: BS.ByteString + +validCandles = + [r| + + + + + + + |] :: BS.ByteString + +validServerStatus = + [r| |] :: BS.ByteString + +validMarkets = + [r| + + FOO + BAR + + |] :: BS.ByteString + +validSecurities = + [r| + + + SECCODE + CLASS + BOARD + 15 + CURRENCY + SHORTNAME + 3 + 0.1 + 10 + 1 + 6.28 + + SECTYPE + SECTZ + 1 + FOO + CURRENCYID + + + |] :: BS.ByteString + +validAllTrades = + [r| + + + SEC1 + 14 + + BOARD + 12.34 + 10 + B + 100 + N + + + SEC2 + 15 + + BOARD + 12.35 + 11 + S + 200 + N + + + |] :: BS.ByteString + +parseDom :: BS.ByteString -> Maybe TransaqResponse +parseDom d = parseXMLDoc (decodeUtf8With lenientDecode d) >>= fromXml + +parseSax :: BS.ByteString -> Maybe TransaqResponse +parseSax = headMay . parseTransaqResponses + +main = defaultMain + [ + bgroup "DOM" + [ + bench "" $ whnf parseDom validClient + , bench "" $ whnf parseDom validCandleKinds + , bench "" $ whnf parseDom validCandles + , bench "" $ whnf parseDom validServerStatus + , bench "" $ whnf parseDom validMarkets + , bench "" $ whnf parseDom validSecurities + , bench "" $ whnf parseDom validAllTrades + ] + , bgroup "SAX" + [ + bench "" $ whnf parseSax validClient + , bench "" $ whnf parseSax validCandleKinds + , bench "" $ whnf parseSax validCandles + , bench "" $ whnf parseSax validServerStatus + , bench "" $ whnf parseSax validMarkets + , bench "" $ whnf parseSax validSecurities + , bench "" $ whnf parseSax validAllTrades + ] + ] diff --git a/src/Transaq.hs b/src/Transaq.hs index ed22a73..ea1013e 100644 --- a/src/Transaq.hs +++ b/src/Transaq.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + module Transaq ( @@ -72,28 +76,36 @@ module Transaq import Barbies import Barbies.Bare -import Control.Applicative ((<|>)) -import Control.Error.Util (hush) -import Control.Monad (void) -import Data.Attoparsec.Text (Parser, char, decimal, many', - maybeResult, parse, parseOnly, - skipSpace) -import Data.Decimal (DecimalRaw (..)) -import Data.Functor.Identity (Identity (..)) -import Data.Int (Int64) -import Data.Maybe (catMaybes, fromMaybe, mapMaybe, - maybeToList) -import qualified Data.Text as T -import Data.Time (fromGregorian) -import Data.Time.Clock (UTCTime (UTCTime)) +import Control.Applicative ((<|>)) +import Control.Error.Util (hush) +import Control.Monad (void, when) +import Control.Monad.State (State (..), gets, modify) +import Control.Monad.State.Class (MonadState (..)) +import Data.Attoparsec.Text (Parser, char, decimal, many', + maybeResult, parse, parseOnly, + skipSpace) +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (readInteger) +import Data.Decimal (DecimalRaw (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Int (Int64) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, + maybeToList) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (fromGregorian) +import Data.Time.Clock (UTCTime (UTCTime)) import GHC.Generics -import Text.Read (readMaybe) -import Text.XML.Light (Attr (..), CData (cdData), - Element (elName), Node (..), QName (..), - elChildren, findAttr, findChild, - onlyText, strContent, unode) -import Text.XML.Light.Output (showElement) -import Text.XML.Light.Types (Element (elContent), blank_name) +import Text.Read (readMaybe) +import Text.XML.Light (Attr (..), CData (cdData), + Element (elName), Node (..), + QName (..), elChildren, findAttr, + findChild, onlyText, strContent, + unode) +import Text.XML.Light.Output (showElement) +import Text.XML.Light.Types (Element (elContent), blank_name) +import Xeno.SAX (Process (..)) data Language = LanguageRu | LanguageEn deriving (Show, Eq, Ord) @@ -558,7 +570,7 @@ data ClientDataB t f = , cCurrency :: Wear t f T.Text , cMarket :: Wear t f T.Text , cUnion :: Wear t f T.Text - , cForts :: Wear t f (Maybe T.Text) + , cForts :: Maybe T.Text } deriving (Generic) type ClientData = ClientDataB Bare Identity @@ -743,7 +755,7 @@ data QuotationB t f = , qOpenPositions :: Maybe Int , qLastPrice :: Maybe Double , qQuantity :: Maybe Int - , qTimestamp :: Wear t f UTCTime + , qTimestamp :: Maybe UTCTime , qValToday :: Maybe Double } deriving (Generic) @@ -785,7 +797,7 @@ instance TransaqResponseC Element ResponseQuotations where let !qOpenPositions = childContent "openpositions" tag >>= readMaybe let !qLastPrice = childContent "last" tag >>= readMaybe let !qQuantity = childContent "quantity" tag >>= readMaybe - !qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack) + let !qTimestamp = childContent "time" tag >>= (parseTimestamp . T.pack) let !qValToday = childContent "valtoday" tag >>= readMaybe pure $ Just (Quotation {..} :: Quotation) @@ -1105,3 +1117,4 @@ instance TransaqResponseC Element TransaqResponse where "orders" -> TransaqResponseOrders <$> fromXml root "trades" -> TransaqResponseTrades <$> fromXml root _ -> Nothing + diff --git a/src/Transaq/Parsing.hs b/src/Transaq/Parsing.hs new file mode 100644 index 0000000..4b1aadc --- /dev/null +++ b/src/Transaq/Parsing.hs @@ -0,0 +1,1056 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Transaq.Parsing + ( + ParsingProcess(..), + ParsingContext(..), + defaultProcess, + parseTransaqResponses + ) where + +import Barbies.Bare (Bare, Covered) +import Control.Applicative (many) +import Control.Error.Util (hush) +import Control.Monad (void, when) +import Control.Monad.ST (ST, runST) +import Control.Monad.State (MonadState, State, execState, + modify') +import Control.Monad.Trans (MonadTrans (..)) +import Data.Attoparsec.Text (Parser, char, decimal, many', + maybeResult, parse, parseOnly, + skipSpace) +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (readInteger) +import Data.Char (isSpace) +import Data.Functor.Identity (Identity) +import Data.Int (Int64) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (catMaybes, fromMaybe) +import Data.STRef.Strict (STRef, modifySTRef', newSTRef, + readSTRef, writeSTRef) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (fromGregorian) +import Data.Time.Clock (UTCTime (UTCTime)) +import Data.Void (Void) +import Debug.Trace +import GHC.Generics (Generic) +import Text.Megaparsec (MonadParsec (takeWhileP), + Parsec (..), ParsecT, anySingle, + customFailure, lookAhead, oneOf, + parse, runParserT, satisfy, single, + unexpected, (<|>)) +import Text.Megaparsec (optional) +import qualified Text.Megaparsec.Error as ME +import Text.Megaparsec.Stream (Stream (..)) +import Text.Read (readMaybe) +import Transaq (AllTradesTrade, AllTradesTradeB (..), + CandleB (..), CandleKind, + CandleKindB (..), ClientData, + ClientDataB (..), + ConnectionState (..), + MarketInfoB (..), OrderNotification, + OrderNotificationB (..), + OrderStatus (..), Quotation, + QuotationB (..), + ResponseAllTrades (..), + ResponseCandleKinds (..), + ResponseCandlesB (..), + ResponseCandlesStatus (..), + ResponseClient (..), + ResponseMarkets (..), + ResponseOrders (..), + ResponseQuotations (..), + ResponseQuotes (..), + ResponseResult (..), + ResponseSecInfoB (..), + ResponseSecurities (..), + ResponseServerStatusB (..), + ResponseTrades (..), Security, + SecurityB (..), SecurityId (..), + TradeDirection (..), + TradeNotification, + TradeNotificationB (..), + TradingPeriod (..), + TransaqResponse (..), sSecId) +import qualified Transaq as Quote (Quote, QuoteB (..)) +import Xeno.SAX (Process (..), process) + +class EmptyPartial b where + emptyPartial :: b Covered Maybe + +class FromPartial b where + fromPartial :: b Covered Maybe -> Maybe (b Bare Identity) + +data XmlStreamEvent = + XmlOpen T.Text + | XmlAttr T.Text T.Text + | XmlOpenEnd T.Text + | XmlText T.Text + | XmlClose T.Text + deriving (Show, Eq, Ord) + +isOpenTag (XmlOpen _) = True +isOpenTag _ = False + + +isAttr (XmlAttr _ _) = True +isAttr _ = False + +isText (XmlText _ ) = True +isText _ = False + +isWhitespaceText (XmlText txt) = T.all isSpace txt +isWhitespaceText _ = False + +defaultProcess :: ParsingProcess +defaultProcess = + Process {..} + where + openF bs = + let tag = decodeUtf8With lenientDecode bs in + modify' $ \s -> XmlOpen tag : s + attrF key val = + let attrName = decodeUtf8With lenientDecode key + attrValue = decodeUtf8With lenientDecode val in + modify' $ \s -> XmlAttr attrName attrValue : s + endOpenF bs = + let tag = decodeUtf8With lenientDecode bs in + modify' $ \s -> XmlOpenEnd tag : s + textF bs = + let tag = decodeUtf8With lenientDecode bs in + modify' $ \s -> XmlText tag : s + closeF bs = + let tag = decodeUtf8With lenientDecode bs in + modify' $ \s -> XmlClose tag : s + cdataF _ = return () + +type ClientDataPartial = ClientDataB Covered Maybe +deriving instance Show ClientDataPartial +deriving instance Eq ClientDataPartial +deriving instance Ord ClientDataPartial + +instance EmptyPartial ClientDataB where + emptyPartial = ClientData Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial ClientDataB where + fromPartial partial = + ClientData <$> + cClientId partial <*> + cType partial <*> + cCurrency partial <*> + cMarket partial <*> + cUnion partial <*> + (pure . cForts) partial + +type CandleKindPartial = CandleKindB Covered Maybe +deriving instance Eq CandleKindPartial +deriving instance Show CandleKindPartial +deriving instance Ord CandleKindPartial + +instance EmptyPartial CandleKindB where + emptyPartial = CandleKind Nothing Nothing Nothing + +instance FromPartial CandleKindB where + fromPartial partial = + CandleKind <$> + kCandleKindId partial <*> + kPeriod partial <*> + kName partial + +type ResponseCandlesPartial = ResponseCandlesB Covered Maybe + +deriving instance Eq ResponseCandlesPartial +deriving instance Show ResponseCandlesPartial +deriving instance Ord ResponseCandlesPartial + +instance EmptyPartial ResponseCandlesB where + emptyPartial = ResponseCandles Nothing Nothing Nothing Nothing + +instance FromPartial ResponseCandlesB where + fromPartial partial = + ResponseCandles <$> + cPeriodId partial <*> + cStatus partial <*> + cSecurity partial <*> + cCandles partial + +type CandlePartial = CandleB Covered Maybe + +deriving instance Eq CandlePartial +deriving instance Show CandlePartial +deriving instance Ord CandlePartial + +instance EmptyPartial CandleB where + emptyPartial = Candle Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial CandleB where + fromPartial partial = + Candle <$> + cTimestamp partial <*> + cOpen partial <*> + cHigh partial <*> + cLow partial <*> + cClose partial <*> + cVolume partial <*> + (pure . fromMaybe 0 . cOpenInterest) partial + +type ResponseServerStatusPartial = ResponseServerStatusB Covered Maybe +deriving instance Eq ResponseServerStatusPartial +deriving instance Show ResponseServerStatusPartial +deriving instance Ord ResponseServerStatusPartial + +instance EmptyPartial ResponseServerStatusB where + emptyPartial = ResponseServerStatus Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial ResponseServerStatusB where + fromPartial partial = case state partial of + Just s -> Just $ ResponseServerStatus + (flatten $ serverId partial) + s + (flatten $ recover $ partial) + (flatten $ serverTimezone partial) + (flatten $ systemVersion partial) + (flatten $ build partial) + _ -> Nothing + where + flatten (Just (Just x)) = Just x + flatten (Just Nothing) = Nothing + flatten Nothing = Nothing + +type MarketInfoPartial = MarketInfoB Covered Maybe +deriving instance Eq MarketInfoPartial +deriving instance Show MarketInfoPartial +deriving instance Ord MarketInfoPartial + +instance EmptyPartial MarketInfoB where + emptyPartial = MarketInfo Nothing Nothing + +instance FromPartial MarketInfoB where + fromPartial partial = + MarketInfo <$> + marketId partial <*> + marketName partial + +type SecurityPartial = SecurityB Covered Maybe +deriving instance Eq SecurityPartial +deriving instance Show SecurityPartial +deriving instance Ord SecurityPartial + +instance EmptyPartial SecurityB where + -- :( + emptyPartial = + Security Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial SecurityB where + fromPartial partial = + Security <$> + sSecId partial <*> + sActive partial <*> + sSeccode partial <*> + sInstrClass partial <*> + sBoard partial <*> + sMarket partial <*> + sCurrency partial <*> + sShortName partial <*> + sDecimals partial <*> + sMinStep partial <*> + sLotSize partial <*> + sLotDivider partial <*> + sPointCost partial <*> + sSecType partial + +type ResponseSecInfoPartial = ResponseSecInfoB Covered Maybe +deriving instance Eq ResponseSecInfoPartial +deriving instance Show ResponseSecInfoPartial +deriving instance Ord ResponseSecInfoPartial + +instance EmptyPartial ResponseSecInfoB where + -- :( + emptyPartial = ResponseSecInfo Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial ResponseSecInfoB where + fromPartial partial = + ResponseSecInfo <$> + partial.secId <*> + secName partial <*> + partial.secCode <*> + market partial <*> + pname partial <*> + clearingPrice partial <*> + minPrice partial <*> + maxPrice partial <*> + pointCost partial + +type QuotationPartial = QuotationB Covered Maybe +deriving instance Eq QuotationPartial +deriving instance Show QuotationPartial +deriving instance Ord QuotationPartial + +instance EmptyPartial QuotationB where + -- :(((( + emptyPartial = Quotation Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial QuotationB where + fromPartial partial = + Quotation <$> + qSecId partial <*> + qBoard partial <*> + qSeccode partial <*> + pure (qOpen partial) <*> + pure (qWaprice partial) <*> + pure (qBidDepth partial) <*> + pure (qBidDepthT partial) <*> + pure (qNumBids partial) <*> + pure (qOfferDepth partial) <*> + pure (qOfferDepthT partial) <*> + pure (qBid partial) <*> + pure (qOffer partial) <*> + pure (qNumOffers partial) <*> + pure (qNumTrades partial) <*> + pure (qVolToday partial) <*> + pure (qOpenPositions partial) <*> + pure (qLastPrice partial) <*> + pure (qQuantity partial) <*> + pure (qTimestamp partial) <*> + pure (qValToday partial) + +type AllTradesTradePartial = AllTradesTradeB Covered Maybe +deriving instance Eq AllTradesTradePartial +deriving instance Show AllTradesTradePartial +deriving instance Ord AllTradesTradePartial + +instance EmptyPartial AllTradesTradeB where + emptyPartial = AllTradesTrade Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial AllTradesTradeB where + fromPartial partial = + AllTradesTrade <$> + attSecId partial <*> + attSecCode partial <*> + attTradeNo partial <*> + attTimestamp partial <*> + attBoard partial <*> + attPrice partial <*> + attQuantity partial <*> + attBuysell partial <*> + pure (fromMaybe 0 (attOpenInterest partial)) <*> + attPeriod partial + +type QuotePartial = Quote.QuoteB Covered Maybe +deriving instance Eq QuotePartial +deriving instance Show QuotePartial +deriving instance Ord QuotePartial + +instance EmptyPartial Quote.QuoteB where + emptyPartial = Quote.Quote Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance FromPartial Quote.QuoteB where + fromPartial partial = + Quote.Quote <$> + Quote.secId partial <*> + Quote.board partial <*> + Quote.secCode partial <*> + Quote.price partial <*> + pure (Quote.source partial) <*> + pure (Quote.yield partial) <*> + pure (Quote.buy partial) <*> + pure (Quote.sell partial) + +type OrderNotificationPartial = OrderNotificationB Covered Maybe +deriving instance Eq OrderNotificationPartial +deriving instance Show OrderNotificationPartial +deriving instance Ord OrderNotificationPartial + +instance EmptyPartial OrderNotificationB where + emptyPartial = OrderNotification Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + +instance FromPartial OrderNotificationB where + fromPartial partial = + OrderNotification <$> + oTransactionId partial <*> + oOrderNo partial <*> + oSecId partial <*> + oBoard partial <*> + oSecCode partial <*> + pure (oClient partial) <*> + pure (oUnion partial) <*> + pure (oStatus partial) <*> + pure (oBuysell partial) <*> + pure (oTimestamp partial) <*> + pure (oBrokerRef partial) <*> + pure (oBalance partial) <*> + pure (oPrice partial) <*> + pure (oQuantity partial) <*> + pure (oResult partial) + +type TradeNotificationPartial = TradeNotificationB Covered Maybe +deriving instance Eq TradeNotificationPartial +deriving instance Show TradeNotificationPartial +deriving instance Ord TradeNotificationPartial + +instance EmptyPartial TradeNotificationB where + emptyPartial = TradeNotification Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing + +instance FromPartial TradeNotificationB where + fromPartial partial = + TradeNotification <$> + tSecId partial <*> + tTradeNo partial <*> + tOrderNo partial <*> + tBoard partial <*> + tSecCode partial <*> + tClient partial <*> + tUnion partial <*> + tBuysell partial <*> + tTimestamp partial <*> + tValue partial <*> + tComission partial <*> + tQuantity partial <*> + tPrice partial + +newtype ParsingContext a = ParsingContext { unParsingContext :: State [XmlStreamEvent] a } + deriving (Generic) + deriving newtype (Functor, Applicative, Monad, MonadState [XmlStreamEvent]) + +type ParsingProcess = Process (ParsingContext ()) + +parseTransaqResponses :: BS.ByteString -> [TransaqResponse] +parseTransaqResponses bs = + let stream = filter (not . isWhitespaceText) . reverse $ execState (unParsingContext $ process defaultProcess bs) [] in + case runST $ runParserT (many txmlParser) "" stream of + Left err -> [] + Right result -> result + +txmlParser :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +txmlParser = do + tagOpen <- oneOf (XmlOpen <$> [ + "result" + , "client" + , "candlekinds" + , "candles" + , "server_status" + , "markets" + , "securities" + , "sec_info" + , "quotations" + , "alltrades" + , "quotes" + , "orders" + , "trades"]) + case tagOpen of + XmlOpen "result" -> do + ref <- lift (newSTRef Nothing) + parseResult ref + XmlOpen "client" -> lift (newSTRef emptyPartial) >>= parseClient + XmlOpen "candlekinds" -> parseCandleKind + XmlOpen "candles" -> parseCandles + XmlOpen "server_status" -> parseServerStatus + XmlOpen "markets" -> parseMarkets + XmlOpen "securities" -> parseSecurities + XmlOpen "sec_info" -> parseSecInfo + XmlOpen "quotations" -> parseQuotations + XmlOpen "alltrades" -> parseAllTrades + XmlOpen "quotes" -> parseQuotes + XmlOpen "orders" -> parseOrders + XmlOpen "trades" -> parseTrades + _ -> unexpected $ ME.Tokens $ NE.singleton tagOpen + + where + parseResult :: STRef s (Maybe ResponseResult) -> ParsecT String [XmlStreamEvent] (ST s) TransaqResponse + parseResult refResult = do + attr <- takeWhileP Nothing isAttr + mapM_ (parseResultAttr refResult) attr + void . single $ (XmlOpenEnd "result") + t <- anySingle + case t of + XmlOpen "message" -> do + _ <- takeWhileP Nothing isAttr + void . single $ (XmlOpenEnd "message") + (XmlText txt) <- satisfy isText + void . single $ (XmlClose "message") + void . single $ (XmlClose "result") + return . TransaqResponseResult $ ResponseFailure txt + XmlClose "result" -> do + maybeRes <- lift $ readSTRef refResult + case maybeRes of + Just r -> return $ TransaqResponseResult r + Nothing -> customFailure "Unable to parse result" + _ -> customFailure "Expected open message or close result" + + parseResultAttr refResult (XmlAttr "success" "true") = lift $ writeSTRef refResult (Just $ ResponseSuccess Nothing) + parseResultAttr refResult (XmlAttr "success" "false") = lift $ writeSTRef refResult (Just $ ResponseFailure "") + parseResultAttr refResult attr@(XmlAttr "transactionid" trIdStr) = do + case (readMaybe (T.unpack trIdStr)) :: Maybe Int64 of + t@(Just trId) -> lift $ writeSTRef refResult (Just $ ResponseSuccess t) + Nothing -> unexpected $ ME.Tokens $ NE.singleton attr + parseResultAttr _ _ = return () + +parseClient :: STRef s ClientDataPartial -> ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseClient refClientData = do + attr <- takeWhileP Nothing isAttr + mapM_ (parseClientAttr refClientData) attr + void . single $ XmlOpenEnd "client" + many parseClientData + void . single $ XmlClose "client" + d <- lift $ readSTRef refClientData + case fromPartial d of + Just clientData -> return . TransaqResponseClient . ResponseClient $ clientData + Nothing -> customFailure "Unable to parse " + where + parseClientData = + parseType + <|> parseCurrency + <|> parseMarket + <|> parseUnion + <|> parseFortsAcc + + parseType = do + void . single $ XmlOpen "type" + void . single $ XmlOpenEnd "type" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refClientData (\d -> d { cType = Just txt}) + void . single $ XmlClose "type" + + parseCurrency = do + void . single $ XmlOpen "currency" + void . single $ XmlOpenEnd "currency" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refClientData (\d -> d { cCurrency = Just txt}) + void . single $ XmlClose "currency" + + parseMarket = do + void . single $ XmlOpen "market" + void . single $ XmlOpenEnd "market" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refClientData (\d -> d { cMarket = Just txt}) + void . single $ XmlClose "market" + + parseUnion = do + void . single $ XmlOpen "union" + void . single $ XmlOpenEnd "union" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refClientData (\d -> d { cUnion = Just txt}) + void . single $ XmlClose "union" + + parseFortsAcc = do + void . single $ XmlOpen "forts_acc" + void . single $ XmlOpenEnd "forts_acc" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refClientData (\d -> d { cForts = Just txt}) + void . single $ XmlClose "forts_acc" + + parseClientAttr refClientData (XmlAttr "id" idStr) = lift $ modifySTRef' refClientData (\d -> d { cClientId = Just idStr}) + parseClientAttr refClientData _ = return () + + +parseCandleKind :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseCandleKind = do + void . single $ XmlOpenEnd "candlekinds" + kinds <- many parseKind + void . single $ XmlClose "candlekinds" + return . TransaqResponseCandleKinds . ResponseCandleKinds . catMaybes $ kinds + where + parseKind :: ParsecT String [XmlStreamEvent] (ST s) (Maybe CandleKind) + parseKind = do + refKind <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "kind" + void . single $ XmlOpenEnd "kind" + many $ parseKindField refKind + void . single $ XmlClose "kind" + k <- lift $ readSTRef $ refKind + pure . fromPartial $ k + + parseKindField refKind = + parseId refKind + <|> parsePeriod refKind + <|> parseName refKind + + parseId refKind = do + void . single $ XmlOpen "id" + void . single $ XmlOpenEnd "id" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refKind (\d -> d { kCandleKindId = readMaybe . T.unpack $ txt}) + void . single $ XmlClose "id" + + parsePeriod refKind = do + void . single $ XmlOpen "period" + void . single $ XmlOpenEnd "period" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refKind (\d -> d { kPeriod = readMaybe . T.unpack $ txt}) + void . single $ XmlClose "period" + + parseName refKind = do + void . single $ XmlOpen "name" + void . single $ XmlOpenEnd "name" + (XmlText txt) <- satisfy isText + lift $ modifySTRef' refKind (\d -> d { kName = Just txt}) + void . single $ XmlClose "name" + +parseCandles :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseCandles = do + candlesRef <- lift $ newSTRef emptyPartial + attr <- takeWhileP Nothing isAttr + mapM_ (lift . parseAttrs candlesRef) attr + void . single $ XmlOpenEnd "candles" + candles <- catMaybes <$> many parseCandle + void . single $ XmlClose "candles" + lift $ modifySTRef' candlesRef $ \d -> d {cCandles = Just candles} + result <- lift $ readSTRef candlesRef + case fromPartial result of + Just c -> return . TransaqResponseCandles $ c + Nothing -> customFailure "Unable to parse " + where + parseAttrs candlesRef (XmlAttr "period" value) = modifySTRef' candlesRef $ \d -> d { cPeriodId = readMaybe . T.unpack $ value } + parseAttrs candlesRef (XmlAttr "status" value) = modifySTRef' candlesRef $ \d -> d { cStatus = parseStatus value } + parseAttrs candlesRef (XmlAttr "board" value) = modifySTRef' candlesRef $ \d -> d { cSecurity = updateSecurityIdBoard value (cSecurity d) } + parseAttrs candlesRef (XmlAttr "seccode" value) = modifySTRef' candlesRef $ \d -> d { cSecurity = updateSecurityIdSeccode value (cSecurity d) } + parseAttrs candlesRef _ = return () + + parseCandle = do + void . single $ XmlOpen "candle" + candleRef <- lift $ newSTRef emptyPartial + attr <- takeWhileP Nothing isAttr + void . single $ XmlOpenEnd "candle" + void . single $ XmlClose "candle" + mapM_ (lift . parseCandleAttrs candleRef) attr + fromPartial <$> lift (readSTRef candleRef) + + parseStatus :: T.Text -> Maybe ResponseCandlesStatus + parseStatus strStatus = + case strStatus of + "0" -> Just StatusEndOfHistory + "1" -> Just StatusDone + "2" -> Just StatusPending + "3" -> Just StatusUnavaliable + _ -> Nothing + + + updateSecurityIdBoard value Nothing = Just $ SecurityId value "" + updateSecurityIdBoard value (Just (SecurityId _ s)) = Just $ SecurityId value s + + updateSecurityIdSeccode value Nothing = Just $ SecurityId "" value + updateSecurityIdSeccode value (Just (SecurityId s _)) = Just $ SecurityId s value + + parseCandleAttrs candleRef (XmlAttr "date" dateval) = modifySTRef' candleRef $ \c -> c { cTimestamp = parseTimestamp dateval } + parseCandleAttrs candleRef (XmlAttr "open" value) = modifySTRef' candleRef $ \c -> c { cOpen = readMaybe . T.unpack $ value } + parseCandleAttrs candleRef (XmlAttr "high" value) = modifySTRef' candleRef $ \c -> c { cHigh = readMaybe . T.unpack $ value } + parseCandleAttrs candleRef (XmlAttr "low" value) = modifySTRef' candleRef $ \c -> c { cLow = readMaybe . T.unpack $ value } + parseCandleAttrs candleRef (XmlAttr "close" value) = modifySTRef' candleRef $ \c -> c { cClose = readMaybe . T.unpack $ value } + parseCandleAttrs candleRef (XmlAttr "volume" value) = modifySTRef' candleRef $ \c -> c { cVolume = readMaybe . T.unpack $ value } + parseCandleAttrs candleRef (XmlAttr "oi" value) = modifySTRef' candleRef $ \c -> c { cOpenInterest = readMaybe . T.unpack $ value } + parseCandleAttrs _ _ = return () + +parseServerStatus :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseServerStatus = do + attr <- takeWhileP Nothing isAttr + refServerStatus <- lift $ newSTRef emptyPartial + mapM_ (lift . parseAttr refServerStatus) attr + void . single $ XmlOpenEnd "server_status" + s <- anySingle + case s of + XmlText txt -> do + lift $ modifySTRef' refServerStatus $ \s -> s { state = Just $ Error txt} + void . single $ XmlClose "server_status" + XmlClose "server_status" -> return () + d <- lift $ readSTRef refServerStatus + case fromPartial d of + Just status -> return . TransaqResponseServerStatus $ status + Nothing -> customFailure "Unable to parse " + where + parseAttr refServerStatus (XmlAttr "id" value) = modifySTRef' refServerStatus $ \s -> s { serverId = Just $ readMaybe . T.unpack $ value } + parseAttr refServerStatus (XmlAttr "connected" value) = modifySTRef' refServerStatus $ \s -> s { state = Just $ parseState value } + parseAttr refServerStatus (XmlAttr "recover" value) = modifySTRef' refServerStatus $ \s -> s { recover = Just . Just $ value == "true" } + parseAttr refServerStatus (XmlAttr "server_tz" value) = modifySTRef' refServerStatus $ \s -> s { serverTimezone = Just . Just $ value } + parseAttr refServerStatus (XmlAttr "sys_ver" value) = modifySTRef' refServerStatus $ \s -> s { systemVersion = Just $ readMaybe . T.unpack $ value } + parseAttr refServerStatus (XmlAttr "build" value) = modifySTRef' refServerStatus $ \s -> s { build = Just $ readMaybe . T.unpack $ value } + parseAttr refServerStatus _ = return () + + parseState connectedStr = + case connectedStr of + "true" -> Connected + "false" -> Disconnected + "error" -> Error "" + _ -> Disconnected + +parseMarkets :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseMarkets = do + void . single $ XmlOpenEnd "markets" + markets <- catMaybes <$> many parseMarket + void . single $ XmlClose "markets" + pure . TransaqResponseMarkets . ResponseMarkets $ markets + where + parseMarket = do + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "market" + marketIdAttr <- satisfy isAttr + void . single $ XmlOpenEnd "market" + case marketIdAttr of + XmlAttr "id" value -> lift $ modifySTRef' ref $ \s -> s { marketId = readMaybe . T.unpack $ value } + _ -> customFailure "Expected market id" + maybeName <- satisfy isText + case maybeName of + XmlText txt -> lift $ modifySTRef' ref $ \s -> s { marketName = Just txt } + _ -> customFailure "Expected market name" + void . single $ XmlClose "market" + result <- lift $ readSTRef ref + pure . fromPartial $ result + +parseSecurities :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseSecurities = do + void . single $ XmlOpenEnd "securities" + securities <- catMaybes <$> many parseSecurity + void . single $ XmlClose "securities" + pure . TransaqResponseSecurities . ResponseSecurities $ securities + where + parseSecurity :: ParsecT String [XmlStreamEvent] (ST s) (Maybe Security) + parseSecurity = do + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "security" + secIdAttr <- satisfy isAttr + activeAttr <- satisfy isAttr + void . single $ XmlOpenEnd "security" + case secIdAttr of + XmlAttr "secid" value -> lift $ modifySTRef' ref $ \s -> s { sSecId = readMaybe . T.unpack $ value } + _ -> customFailure "Expected secid" + case activeAttr of + XmlAttr "active" value -> lift $ modifySTRef' ref $ \s -> s { sActive = Just $ value == "true" } + _ -> customFailure "Expected active" + many (parseSecurityField ref) + void . single $ XmlClose "security" + result <- lift $ readSTRef ref + pure . fromPartial $ result + + parseSecurityField ref = do + openTag <- satisfy isOpenTag + case openTag of + XmlOpen "seccode" -> parseTextTag "seccode" ref $ \value s -> s { sSeccode = Just value } + XmlOpen "instrclass" -> parseTextTag "instrclass" ref $ \value s -> s { sInstrClass = Just value } + XmlOpen "board" -> parseTextTag "board" ref $ \value s -> s { sBoard = Just value } + XmlOpen "market" -> parseTextTag "market" ref $ \value s -> s { sMarket = Just value } + XmlOpen "currency" -> parseTextTag "currency" ref $ \value s -> s { sCurrency = Just value } + XmlOpen "shortname" -> parseTextTag "shortname" ref $ \value s -> s { sShortName = Just value } + XmlOpen "decimals" -> parseTextTag "decimals" ref $ \value s -> s { sDecimals = readMaybe . T.unpack $ value } + XmlOpen "minstep" -> parseTextTag "minstep" ref $ \value s -> s { sMinStep = readMaybe . T.unpack $ value } + XmlOpen "lotsize" -> parseTextTag "lotsize" ref $ \value s -> s { sLotSize = readMaybe . T.unpack $ value } + XmlOpen "lotdivider" -> parseTextTag "lotdivider" ref $ \value s -> s { sLotDivider = readMaybe . T.unpack $ value } + XmlOpen "point_cost" -> parseTextTag "point_cost" ref $ \value s -> s { sPointCost = readMaybe . T.unpack $ value } + XmlOpen "sectype" -> parseTextTag "sectype" ref $ \value s -> s { sSecType = Just value } + XmlOpen tagname -> ignoreTag tagname + _ -> customFailure "Expected tag open" + +parseSecInfo :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseSecInfo = do + secIdAttr <- satisfy isAttr + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpenEnd "sec_info" + case secIdAttr of + XmlAttr "secid" value -> lift . modifySTRef' ref $ \s -> s { secId = readMaybe . T.unpack $ value} + _ -> customFailure "Expected secid attr" + many (parseSecInfoField ref) + void . single $ XmlClose "sec_info" + result <- lift . readSTRef $ ref + case fromPartial result of + Just res -> pure . TransaqResponseSecInfo $ res + _ -> customFailure "Unable to parse " + where + parseSecInfoField :: STRef s ResponseSecInfoPartial -> ParsecT String [XmlStreamEvent] (ST s) () + parseSecInfoField ref = do + openTag <- satisfy isOpenTag + case openTag of + XmlOpen "secname" -> parseTextTag "secname" ref $ \value s -> s { secName = Just value } + XmlOpen "seccode" -> parseTextTag "seccode" ref $ \value s -> s { secCode = Just value } + XmlOpen "market" -> parseTextTag "market" ref $ \value s -> s { market = readMaybe . T.unpack $ value } + XmlOpen "pname" -> parseTextTag "pname" ref $ \value s -> s { pname = Just value } + XmlOpen "clearing_price" -> parseTextTag "clearing_price" ref $ \value s -> s { clearingPrice = readMaybe . T.unpack $ value } + XmlOpen "minprice" -> parseTextTag "minprice" ref $ \value s -> s { minPrice = readMaybe . T.unpack $ value } + XmlOpen "maxprice" -> parseTextTag "maxprice" ref $ \value s -> s { maxPrice = readMaybe . T.unpack $ value } + XmlOpen "point_cost" -> parseTextTag "point_cost" ref $ \value s -> s { pointCost = readMaybe . T.unpack $ value } + XmlOpen tagname -> ignoreTag tagname + _ -> customFailure "Expected tag open" + +parseQuotations :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseQuotations = do + void . single $ XmlOpenEnd "quotations" + quotations <- catMaybes <$> many parseQuotation + void . single $ XmlClose "quotations" + pure . TransaqResponseQuotations . ResponseQuotations $ quotations + where + parseQuotation :: ParsecT String [XmlStreamEvent] (ST s) (Maybe Quotation) + parseQuotation = do + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "quotation" + secIdAttr <- satisfy isAttr + void . single $ XmlOpenEnd "quotation" + case secIdAttr of + XmlAttr "secid" value -> lift $ modifySTRef' ref $ \s -> s { qSecId = readMaybe . T.unpack $ value } + _ -> customFailure "Expected secid" + many (parseQuotationField ref) + void . single $ XmlClose "quotation" + result <- lift $ readSTRef ref + pure . fromPartial $ result + + parseQuotationField ref = do + openTag <- satisfy isOpenTag + case openTag of + XmlOpen "board" -> parseTextTag "board" ref $ \value s -> s { qBoard = Just value } + XmlOpen "seccode" -> parseTextTag "seccode" ref $ \value s -> s { qSeccode = Just value } + XmlOpen "open" -> parseTextTag "open" ref $ \value s -> s { qOpen = readMaybe . T.unpack $ value } + XmlOpen "waprice" -> parseTextTag "waprice" ref $ \value s -> s { qWaprice = readMaybe . T.unpack $ value } + XmlOpen "biddepth" -> parseTextTag "biddepth" ref $ \value s -> s { qBidDepth = readMaybe . T.unpack $ value } + XmlOpen "biddeptht" -> parseTextTag "biddeptht" ref $ \value s -> s { qBidDepthT = readMaybe . T.unpack $ value } + XmlOpen "numbids" -> parseTextTag "numbids" ref $ \value s -> s { qNumBids = readMaybe . T.unpack $ value } + XmlOpen "bid" -> parseTextTag "bid" ref $ \value s -> s { qBid = readMaybe . T.unpack $ value } + XmlOpen "offerdepth" -> parseTextTag "offerdepth" ref $ \value s -> s { qOfferDepth = readMaybe . T.unpack $ value } + XmlOpen "offerdeptht" -> parseTextTag "offerdeptht" ref $ \value s -> s { qOfferDepthT = readMaybe . T.unpack $ value } + XmlOpen "numoffers" -> parseTextTag "numoffers" ref $ \value s -> s { qNumOffers = readMaybe . T.unpack $ value } + XmlOpen "offer" -> parseTextTag "offer" ref $ \value s -> s { qOffer = readMaybe . T.unpack $ value } + XmlOpen "numtrades" -> parseTextTag "numtrades" ref $ \value s -> s { qNumTrades = readMaybe . T.unpack $ value } + XmlOpen "voltoday" -> parseTextTag "voltoday" ref $ \value s -> s { qVolToday = readMaybe . T.unpack $ value } + XmlOpen "openpositions" -> parseTextTag "openpositions" ref $ \value s -> s { qOpenPositions = readMaybe . T.unpack $ value } + XmlOpen "last" -> parseTextTag "last" ref $ \value s -> s { qLastPrice = readMaybe . T.unpack $ value } + XmlOpen "quantity" -> parseTextTag "quantity" ref $ \value s -> s { qQuantity = readMaybe . T.unpack $ value } + XmlOpen "time" -> parseTextTag "time" ref $ \value s -> s { qTimestamp = parseTimestamp value } + XmlOpen "valtoday" -> parseTextTag "valtoday" ref $ \value s -> s { qValToday = readMaybe . T.unpack $ value } + XmlOpen tagname -> ignoreTag tagname + _ -> customFailure "Expected tag open" + +parseAllTrades :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseAllTrades = do + void . single $ XmlOpenEnd "alltrades" + trades <- catMaybes <$> many parseTrade + void . single $ XmlClose "alltrades" + pure . TransaqResponseAllTrades . ResponseAllTrades $ trades + where + parseTrade :: ParsecT String [XmlStreamEvent] (ST s) (Maybe AllTradesTrade) + parseTrade = do + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "trade" + secIdAttr <- satisfy isAttr + void . single $ XmlOpenEnd "trade" + case secIdAttr of + XmlAttr "secid" value -> lift $ modifySTRef' ref $ \s -> s { attSecId = readMaybe . T.unpack $ value } + _ -> customFailure "Expected secid" + many (parseTradeField ref) + void . single $ XmlClose "trade" + result <- lift $ readSTRef ref + pure . fromPartial $ result + + parseTradeField ref = do + openTag <- satisfy isOpenTag + case openTag of + XmlOpen "seccode" -> parseTextTag "seccode" ref $ \value s -> s { attSecCode = Just value } + XmlOpen "tradeno" -> parseTextTag "tradeno" ref $ \value s -> s { attTradeNo = readMaybe . T.unpack $ value } + XmlOpen "time" -> parseTextTag "time" ref $ \value s -> s { attTimestamp = parseTimestamp value} + XmlOpen "board" -> parseTextTag "board" ref $ \value s -> s { attBoard = Just value } + XmlOpen "price" -> parseTextTag "price" ref $ \value s -> s { attPrice = readMaybe . T.unpack $ value } + XmlOpen "quantity" -> parseTextTag "quantity" ref $ \value s -> s { attQuantity = readMaybe . T.unpack $ value } + XmlOpen "buysell" -> parseTextTag "buysell" ref $ \value s -> s { attBuysell = parseBuySell value } + XmlOpen "openinterest" -> parseTextTag "openinterest" ref $ \value s -> s { attOpenInterest = readMaybe . T.unpack $ value } + XmlOpen "period" -> parseTextTag "period" ref $ \value s -> s { attPeriod = parsePeriod value } + XmlOpen tagname -> ignoreTag tagname + _ -> customFailure "Expected tag open" + + parseBuySell "B" = Just Buy + parseBuySell "S" = Just Sell + parseBuySell _ = Nothing + + + parsePeriod "O" = Just PeriodOpen + parsePeriod "N" = Just PeriodNormal + parsePeriod "C" = Just PeriodClose + parsePeriod _ = Nothing + +parseQuotes :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseQuotes = do + void . single $ XmlOpenEnd "quotes" + quotes <- catMaybes <$> many parseQuote + void . single $ XmlClose "quotes" + pure . TransaqResponseQuotes . ResponseQuotes $ quotes + where + parseQuote :: ParsecT String [XmlStreamEvent] (ST s) (Maybe Quote.Quote) + parseQuote = do + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "quote" + secIdAttr <- satisfy isAttr + void . single $ XmlOpenEnd "quote" + case secIdAttr of + XmlAttr "secid" value -> lift $ modifySTRef' ref $ \s -> s { Quote.secId = readMaybe . T.unpack $ value } + _ -> customFailure "Expected secid" + many (parseQuoteField ref) + void . single $ XmlClose "quote" + result <- lift $ readSTRef ref + pure . fromPartial $ result + + parseQuoteField ref = do + openTag <- satisfy isOpenTag + case openTag of + XmlOpen "board" -> parseTextTag "board" ref $ \value s -> s { Quote.board = Just value } + XmlOpen "seccode" -> parseTextTag "seccode" ref $ \value s -> s { Quote.secCode = Just value } + XmlOpen "price" -> parseTextTag "price" ref $ \value s -> s { Quote.price = readMaybe . T.unpack $ value } + XmlOpen "source" -> parseTextTag "source" ref $ \value s -> s { Quote.source = Just value } + XmlOpen "yield" -> parseTextTag "yield" ref $ \value s -> s { Quote.yield = readMaybe . T.unpack $ value } + XmlOpen "buy" -> parseTextTag "buy" ref $ \value s -> s { Quote.buy = readMaybe . T.unpack $ value } + XmlOpen "sell" -> parseTextTag "sell" ref $ \value s -> s { Quote.sell = readMaybe . T.unpack $ value } + XmlOpen tagname -> ignoreTag tagname + _ -> customFailure "Expected tag open" + +parseOrders :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseOrders = do + void . single $ XmlOpenEnd "orders" + orders <- catMaybes <$> many parseOrder + void . single $ XmlClose "orders" + pure . TransaqResponseOrders . ResponseOrders $ orders + where + parseOrder :: ParsecT String [XmlStreamEvent] (ST s) (Maybe OrderNotification) + parseOrder = do + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "order" + trIdAttr <- satisfy isAttr + void . single $ XmlOpenEnd "order" + case trIdAttr of + XmlAttr "transactionid" value -> lift $ modifySTRef' ref $ \s -> s { oTransactionId = readMaybe . T.unpack $ value } + _ -> customFailure "Expected transactionid" + many (parseOrderField ref) + void . single $ XmlClose "order" + result <- lift $ readSTRef ref + pure . fromPartial $ result + + parseOrderField ref = do + openTag <- satisfy isOpenTag + case openTag of + XmlOpen "orderno" -> parseTextTag "orderno" ref $ \value s -> s { oOrderNo = readMaybe . T.unpack $ value } + XmlOpen "secid" -> parseTextTag "secid" ref $ \value s -> s { oSecId = readMaybe . T.unpack $ value } + XmlOpen "board" -> parseTextTag "board" ref $ \value s -> s { oBoard = Just value } + XmlOpen "seccode" -> parseTextTag "seccode" ref $ \value s -> s { oSecCode = Just value } + XmlOpen "client" -> parseTextTag "client" ref $ \value s -> s { oClient = Just value } + XmlOpen "union" -> parseTextTag "union" ref $ \value s -> s { oUnion = Just value } + XmlOpen "status" -> parseTextTag "status" ref $ \value s -> s { oStatus = parseStatus value } + XmlOpen "buysell" -> parseTextTag "buysell" ref $ \value s -> s { oBuysell = parseBuySell value } + XmlOpen "time" -> parseTextTag "time" ref $ \value s -> s { oTimestamp = parseTimestamp value } + XmlOpen "brokerref" -> parseTextTag "brokerref" ref $ \value s -> s { oBrokerRef = Just value } + XmlOpen "balance" -> parseTextTag "balance" ref $ \value s -> s { oBalance = readMaybe . T.unpack $ value} + XmlOpen "price" -> parseTextTag "price" ref $ \value s -> s { oPrice = readMaybe . T.unpack $ value} + XmlOpen "quantity" -> parseTextTag "quantity" ref $ \value s -> s { oQuantity = readMaybe . T.unpack $ value} + XmlOpen "result" -> parseTextTag "result" ref $ \value s -> s { oResult = Just value } + XmlOpen tagname -> ignoreTag tagname + _ -> customFailure "Expected tag open" + + parseBuySell "B" = Just Buy + parseBuySell "S" = Just Sell + parseBuySell _ = Nothing + + parseStatus "active" = Just OrderActive + parseStatus "cancelled" = Just OrderCancelled + parseStatus "denied" = Just OrderDenied + parseStatus "disabled" = Just OrderDisabled + parseStatus "expired" = Just OrderExpired + parseStatus "failed" = Just OrderFailed + parseStatus "forwarding" = Just OrderForwarding + parseStatus "inactive" = Just OrderInactive + parseStatus "matched" = Just OrderMatched + parseStatus "refused" = Just OrderRefused + parseStatus "rejected" = Just OrderRejected + parseStatus "removed" = Just OrderRemoved + parseStatus "wait" = Just OrderWait + parseStatus "watching" = Just OrderWatching + parseStatus _ = Nothing + +parseTrades :: ParsecT String [XmlStreamEvent] (ST s) TransaqResponse +parseTrades = do + void . single $ XmlOpenEnd "trades" + trades <- catMaybes <$> many parseTrade + void . single $ XmlClose "trades" + pure . TransaqResponseTrades . ResponseTrades $ trades + where + parseTrade :: ParsecT String [XmlStreamEvent] (ST s) (Maybe TradeNotification) + parseTrade = do + ref <- lift $ newSTRef emptyPartial + void . single $ XmlOpen "trade" + void . single $ XmlOpenEnd "trade" + many (parseTradeField ref) + void . single $ XmlClose "trade" + result <- lift $ readSTRef ref + pure . fromPartial $ result + + parseTradeField ref = do + openTag <- satisfy isOpenTag + case openTag of + XmlOpen "secid" -> parseTextTag "secid" ref $ \value s -> s { tSecId = readMaybe . T.unpack $ value } + XmlOpen "tradeno" -> parseTextTag "tradeno" ref $ \value s -> s { tTradeNo = readMaybe . T.unpack $ value } + XmlOpen "orderno" -> parseTextTag "orderno" ref $ \value s -> s { tOrderNo = readMaybe . T.unpack $ value } + XmlOpen "board" -> parseTextTag "board" ref $ \value s -> s { tBoard = Just value } + XmlOpen "seccode" -> parseTextTag "seccode" ref $ \value s -> s { tSecCode = Just value } + XmlOpen "client" -> parseTextTag "client" ref $ \value s -> s { tClient = Just value } + XmlOpen "union" -> parseTextTag "union" ref $ \value s -> s { tUnion = Just value } + XmlOpen "buysell" -> parseTextTag "buysell" ref $ \value s -> s { tBuysell = parseBuySell value } + XmlOpen "time" -> parseTextTag "time" ref $ \value s -> s { tTimestamp = parseTimestamp value } + XmlOpen "value" -> parseTextTag "value" ref $ \value s -> s { tValue = readMaybe . T.unpack $ value } + XmlOpen "comission" -> parseTextTag "comission" ref $ \value s -> s { tComission = readMaybe . T.unpack $ value } + XmlOpen "quantity" -> parseTextTag "quantity" ref $ \value s -> s { tQuantity = readMaybe . T.unpack $ value } + XmlOpen "price" -> parseTextTag "price" ref $ \value s -> s { tPrice = readMaybe . T.unpack $ value } + XmlOpen tagname -> ignoreTag tagname + _ -> customFailure "Expected tag open" + + parseBuySell "B" = Just Buy + parseBuySell "S" = Just Sell + parseBuySell _ = Nothing + + +parseTimestamp :: T.Text -> Maybe UTCTime +parseTimestamp = hush . parseOnly parser + where + parser = parseWithDate <|> (UTCTime epoch <$> parseTime) + parseWithDate = do + !date <- parseDate + skipSpace + !time <- parseTime + pure $ UTCTime date time + parseDate = do + !day <- decimal + void $ char '.' + !month <- decimal + void $ char '.' + !year <- decimal + pure $ fromGregorian year month day + + parseTime = do + !hour <- (decimal :: Parser Int) + void $ char ':' + !minute <- decimal + void $ char ':' + !second <- decimal + msecs <- many' $ do + void $ char '.' + (decimal :: Parser Int) + let !secofday = hour * 3600 + minute * 60 + second + case msecs of + [!ms] -> pure $ fromIntegral secofday + fromIntegral ms / 1000.0 + _ -> pure $ fromIntegral secofday + epoch = fromGregorian 1970 1 1 + +parseTextTag tagname ref f = do + void . single $ XmlOpenEnd tagname + (XmlText txt) <- satisfy isText + lift $ modifySTRef' ref (f txt) + void . single $ XmlClose tagname + +ignoreTag tagname = do + x <- takeWhileP Nothing (/= XmlClose tagname) + void . single $ XmlClose tagname diff --git a/stack.yaml b/stack.yaml index 1aea1e9..7e53746 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-20.18 +resolver: lts-20.26 # User packages to be built. # Various formats can be used as shown in the example below. @@ -51,6 +51,7 @@ extra-deps: - typerep-map-0.5.0.0@sha256:34f1ba9b268a6d52e26ae460011a5571e8099b50a3f4a7c8db25dd8efe3be8ee,4667 + # Override default flag values for local packages and extra-deps # flags: {} flags: @@ -61,8 +62,8 @@ flags: # extra-package-dbs: [] # Control whether we use the GHC we find on the path -# system-ghc: true -# +system-ghc: true + # Require a specific version of stack, using version ranges # require-stack-version: -any # Default # require-stack-version: ">=2.7" @@ -73,7 +74,8 @@ flags: # # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] +extra-lib-dirs: +- lib # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock index 57a186b..a1e073d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -7,34 +7,34 @@ packages: - completed: hackage: datetime-0.3.1@sha256:7e275bd0ce7a2f66445bedfa0006abaf4d41af4c2204c3f8004c17eab5480e74,1534 pantry-tree: - size: 334 sha256: d41d182c143676464cb1774f0b7777e870ddeaf8b6cd5fee6ff0114997a1f504 + size: 334 original: hackage: datetime-0.3.1 - completed: hackage: co-log-0.5.0.0@sha256:a7e84650eaef7eba2d59ee7664309e79317a7ca67011abedf971f0e6bd6475bb,5448 pantry-tree: - size: 1043 sha256: 33b838c07c8b7e70b2e82bddc889bb1e6386d7e12a9d1593c0b4b263b1fcb925 + size: 1043 original: hackage: co-log-0.5.0.0 - completed: hackage: chronos-1.1.5@sha256:ca35be5fdbbb384414226b4467c6d1c8b44defe59a9c8a3af32c1c5fb250c781,3830 pantry-tree: - size: 581 sha256: 329bf39a05362a9c1f507a4a529725c757208843b562c55e0b7c88538dc3160f + size: 581 original: hackage: chronos-1.1.5@sha256:ca35be5fdbbb384414226b4467c6d1c8b44defe59a9c8a3af32c1c5fb250c781,3830 - completed: hackage: typerep-map-0.5.0.0@sha256:34f1ba9b268a6d52e26ae460011a5571e8099b50a3f4a7c8db25dd8efe3be8ee,4667 pantry-tree: - size: 1487 sha256: ca5565de307d260dc67f6dae0d4d33eee42a3238183461569b5142ceb909c91d + size: 1487 original: hackage: typerep-map-0.5.0.0@sha256:34f1ba9b268a6d52e26ae460011a5571e8099b50a3f4a7c8db25dd8efe3be8ee,4667 snapshots: - completed: - size: 649606 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/18.yaml - sha256: 9fa4bece7acfac1fc7930c5d6e24606004b09e80aa0e52e9f68b148201008db9 - original: lts-20.18 + sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 + size: 650475 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml + original: lts-20.26 diff --git a/test/Spec.hs b/test/Spec.hs index 1050528..1d5b469 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,11 @@ -import Debug.EventCounters (initEventCounters) -import System.Metrics (newStore) +import Debug.EventCounters (initEventCounters) +import System.Metrics (newStore) import Test.Tasty import qualified Test.FSM import qualified Test.TickTable import qualified Test.Transaq +import qualified Test.Transaq.Parsing main :: IO () main = do @@ -16,4 +17,5 @@ unitTests :: TestTree unitTests = testGroup "Unit Tests" [ Test.TickTable.unitTests , Test.FSM.unitTests - , Test.Transaq.unitTests ] + , Test.Transaq.unitTests + , Test.Transaq.Parsing.unitTests ] diff --git a/test/Test/Transaq.hs b/test/Test/Transaq.hs index 73be781..99b7fa9 100644 --- a/test/Test/Transaq.hs +++ b/test/Test/Transaq.hs @@ -6,16 +6,25 @@ module Test.Transaq unitTests ) where +import Control.Monad.State (execState) import Data.AEq ((~==)) +import qualified Data.ByteString as BS import qualified Data.Text as T import Test.Tasty import Test.Tasty.HUnit (assertBool, testCase, (@=?)) import Text.RawString.QQ import Text.XML.Light.Input (parseXMLDoc) import Transaq +import Xeno.SAX (process) unitTests :: TestTree unitTests = testGroup "Parsing" + [ + unitTestsXml + ] + +unitTestsXml :: TestTree +unitTestsXml = testGroup "Parsing via haskell-xml" [ testParseResult , testParseCandles @@ -41,18 +50,17 @@ testParseResult = testGroup "Parsing result" , testParseResultFailure ] where - resultSuccess = [r||] :: T.Text testParseResultSuccess = testCase "Parse success result" $ do - let (Just (ResponseSuccess Nothing)) = (parseXMLDoc resultSuccess >>= fromXml :: Maybe ResponseResult) - return () - resultSuccessWithTransactionId = [r|>= fromXml :: Maybe ResponseResult) + + resultSuccessWithTransactionId = [r||] :: T.Text testParseResultSuccessWithTransactionId = testCase "Parse success result with transaction ID" $ do - let (Just (ResponseSuccess (Just 12))) = (parseXMLDoc resultSuccessWithTransactionId >>= fromXml :: Maybe ResponseResult) - return () - resultFailure = [r|>= fromXml :: Maybe ResponseResult) - return () + (Just (ResponseSuccess (Just 12))) @=? (parseXMLDoc resultSuccessWithTransactionId >>= fromXml :: Maybe ResponseResult) + + resultFailure = [r||] :: T.Text + testParseResultFailure = testCase "Parse failure result" $ do + (Just (ResponseFailure "")) @=? (parseXMLDoc resultFailure >>= fromXml :: Maybe ResponseResult) testParseCandles :: TestTree testParseCandles = testCase "Parse ResponseCandles - valid XML" $ do @@ -508,3 +516,4 @@ testParseTrades = testCase "Parse ResponseTrades - valid XML (full)" $ do |] :: T.Text + diff --git a/test/Test/Transaq/Parsing.hs b/test/Test/Transaq/Parsing.hs new file mode 100644 index 0000000..2074d61 --- /dev/null +++ b/test/Test/Transaq/Parsing.hs @@ -0,0 +1,520 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.Transaq.Parsing + ( + unitTests + ) where + +import Control.Monad.State (execState) +import Data.AEq ((~==)) +import qualified Data.ByteString as BS +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, + (@=?)) +import Text.RawString.QQ +import Transaq (AllTradesTradeB (..), CandleB (..), + CandleKind, CandleKindB (..), + ClientDataB (..), ConnectionState (..), + MarketInfoB (..), OrderNotificationB (..), + OrderStatus (..), QuotationB (..), + QuoteB (..), ResponseAllTrades (..), + ResponseCandleKinds (..), + ResponseCandlesB (..), + ResponseCandlesStatus (..), + ResponseClient (..), ResponseMarkets (..), + ResponseOrders (..), + ResponseQuotations (..), + ResponseQuotes (..), ResponseResult (..), + ResponseSecInfoB (..), + ResponseSecurities (..), + ResponseServerStatusB (..), + ResponseTrades (..), SecurityB (..), + SecurityId (..), TradeDirection (..), + TradeNotificationB (..), + TradingPeriod (..), TransaqResponse (..)) +import Transaq.Parsing +import Xeno.SAX (process) + +unitTests :: TestTree +unitTests = testGroup "Parsing" + [ + unitTestsStreaming + ] + +unitTestsStreaming :: TestTree +unitTestsStreaming = testGroup "Parsing via xeno-sax" + [ + testParseResultStreaming + , testParseClientStreaming + , testParseCandleKindsStreaming + , testParseCandlesStreaming + , testParseServerStatusStreaming + , testParseMarketsStreaming + , testParseSecuritiesStreaming + , testParseSecInfoStreaming + , testParseQuotationsStreaming + , testParseAllTradesStreaming + , testParseQuotesStreaming + , testParseOrdersStreaming + , testParseTradesStreaming + ] + +testParseResultStreaming :: TestTree +testParseResultStreaming = testGroup "Parsing result" + [ + testParseResultSuccess + , testParseResultSuccessWithTransactionId + , testParseResultFailure + ] + where + resultSuccess = [r||] :: BS.ByteString + testParseResultSuccess = testCase "Parse success result" $ do + [TransaqResponseResult (ResponseSuccess Nothing)] @=? + parseTransaqResponses resultSuccess + + resultSuccessWithTransactionId = [r||] :: BS.ByteString + testParseResultSuccessWithTransactionId = testCase "Parse success result with transaction ID" $ do + [TransaqResponseResult (ResponseSuccess (Just 12))] @=? + parseTransaqResponses resultSuccessWithTransactionId + + resultFailure = [r||] :: BS.ByteString + testParseResultFailure = testCase "Parse failure result" $ do + [TransaqResponseResult (ResponseFailure "")] @=? + parseTransaqResponses resultFailure + +testParseClientStreaming :: TestTree +testParseClientStreaming = testCase "Parse ResponseClient - valid XML" $ do + case parseTransaqResponses validClient of + [TransaqResponseClient (ResponseClient clientData)] -> do + "FOO" @=? cClientId clientData + "TYPE" @=? cType clientData + "CURRENCY" @=? cCurrency clientData + "MARKET" @=? cMarket clientData + "UNION" @=? cUnion clientData + Just "FORTS_ACC" @=? cForts clientData + _ -> assertFailure "Invalid parse" + where + validClient = + [r| + + TYPE + CURRENCY + MARKET + UNION + FORTS_ACC + + |] :: BS.ByteString + +testParseCandleKindsStreaming :: TestTree +testParseCandleKindsStreaming = testCase "Parse CandleKind - valid XML" $ do + let candleKinds = parseTransaqResponses validCandleKinds + + let [TransaqResponseCandleKinds (ResponseCandleKinds [m10, m15])] = candleKinds + + 4 @=? kCandleKindId m10 + 600 @=? kPeriod m10 + "M10" @=? kName m10 + + 5 @=? kCandleKindId m15 + 900 @=? kPeriod m15 + "M15" @=? kName m15 + where + validCandleKinds = + [r| + + + 4 + 600 + M10 + + + 5 + 900 + M15 + + + |] :: BS.ByteString + +testParseCandlesStreaming :: TestTree +testParseCandlesStreaming = testCase "Parse Candles - valid XML" $ do + let [TransaqResponseCandles responseCandles] = parseTransaqResponses validCandles + SecurityId "foo" "bar" @=? cSecurity responseCandles + 1 @=? cPeriodId responseCandles + StatusEndOfHistory @=? cStatus responseCandles + 1 @=? (length . cCandles) responseCandles + let candle = head . cCandles $ responseCandles + assertBool "Candle open mismatch" (41.3 ~== cOpen candle) + assertBool "Candle high mismatch" (42 ~== cHigh candle) + assertBool "Candle low mismatch" (40 ~== cLow candle) + assertBool "Candle close mismatch" (41.6 ~== cClose candle) + 1234 @=? cVolume candle + 78 @=? cOpenInterest candle + where + validCandles = + [r| + + + + |] :: BS.ByteString + +testParseServerStatusStreaming :: TestTree +testParseServerStatusStreaming = testCase "Parse ServerStatus - valid XML" $ do + let [TransaqResponseServerStatus serverStatus] = parseTransaqResponses validServerStatus + Just 22 @=? serverId serverStatus + Connected @=? state serverStatus + Just True @=? recover serverStatus + Just "TZ" @=? serverTimezone serverStatus + Just 42 @=? systemVersion serverStatus + Just 51 @=? build serverStatus + where + validServerStatus = + [r| |] :: BS.ByteString + + +testParseMarketsStreaming :: TestTree +testParseMarketsStreaming = testCase "Parse ResponseMarkets - valid XML" $ do + let markets = parseTransaqResponses validMarkets + + let [TransaqResponseMarkets (ResponseMarkets [foo, bar])] = markets + + 1 @=? marketId foo + "FOO" @=? marketName foo + + 2 @=? marketId bar + "BAR" @=? marketName bar + where + validMarkets = + [r| + + FOO + BAR + + |] :: BS.ByteString + + +testParseSecuritiesStreaming :: TestTree +testParseSecuritiesStreaming = testCase "Parse ResponseSecurities - valid XML" $ do + let [TransaqResponseSecurities (ResponseSecurities securities)] = parseTransaqResponses validSecurities + 1 @=? length securities + + let sec = head securities + "SECCODE" @=? sSeccode sec + "CLASS" @=? sInstrClass sec + "BOARD" @=? sBoard sec + "15" @=? sMarket sec + "CURRENCY" @=? sCurrency sec + "SHORTNAME" @=? sShortName sec + 3 @=? sDecimals sec + assertBool "Minstep is not valid" (0.1 ~== sMinStep sec) + 10 @=? sLotSize sec + 1 @=? sLotDivider sec + assertBool "Point cost is not valid" (6.28 ~== sPointCost sec) + "SECTYPE" @=? sSecType sec + where + validSecurities = + [r| + + + SECCODE + CLASS + BOARD + 15 + CURRENCY + SHORTNAME + 3 + 0.1 + 10 + 1 + 6.28 + + SECTYPE + SECTZ + 1 + FOO + CURRENCYID + + + |] :: BS.ByteString + +testParseSecInfoStreaming :: TestTree +testParseSecInfoStreaming = testCase "Parse ResponseSecInfo - valid XML" $ do + let [TransaqResponseSecInfo sec] = parseTransaqResponses validSecInfo + + "SECNAME" @=? secName sec + "SECCODE" @=? sec.secCode + 44 @=? market sec + "PNAME" @=? pname sec + assertBool "Clearing price is not valid" (12.34 ~== clearingPrice sec) + assertBool "Min price is not valid" (10 ~== minPrice sec) + assertBool "Max price is not valid" (20 ~== maxPrice sec) + assertBool "Point cost is not valid" (6.28 ~== pointCost sec) + where + validSecInfo = + [r| + + SECNAME + SECCODE + 44 + PNAME + 12.34 + 10 + 20 + 6.28 + + |] :: BS.ByteString + +testParseQuotationsStreaming :: TestTree +testParseQuotationsStreaming = testCase "Parse ResponseQuotations - valid XML (full)" $ do + let [TransaqResponseQuotations (ResponseQuotations quotations)] = parseTransaqResponses validQuotations + 1 @=? length quotations + + let q = head quotations + + 1 @=? qSecId q + "BOARD" @=? qBoard q + "SECCODE" @=? qSeccode q + + let (Just open') = qOpen q + assertBool "Open is not valid" (12.34 ~== open') + + let (Just waprice') = qWaprice q + assertBool "WA price is not valid" (13.8 ~== waprice') + + Just 40 @=? qBidDepth q + Just 140 @=? qBidDepthT q + Just 10 @=? qNumBids q + + let (Just bid') = qBid q + assertBool "Bid is not valid" (11.01 ~== bid') + + Just 50 @=? qOfferDepth q + Just 150 @=? qOfferDepthT q + Just 15 @=? qNumOffers q + + let (Just offer') = qOffer q + assertBool "Offer is not valid" (11.05 ~== offer') + + Just 1000 @=? qNumTrades q + Just 50000 @=? qVolToday q + Just 1000 @=? qOpenPositions q + + let (Just last') = qLastPrice q + assertBool "Last price is not valid" (11.03 ~== last') + + Just 8 @=? qQuantity q + + -- TODO check time + + let (Just valtoday') = qValToday q + assertBool "Val today is not valid" (12345678 ~== valtoday') + where + validQuotations = + [r| + + + BOARD + SECCODE + 12.34 + 13.8 + 40 + 140 + 10 + 11.01 + 50 + 150 + 15 + 11.05 + 1000 + 50000 + 1000 + 11.03 + 8 + + 12345678 + + + |] :: BS.ByteString + +testParseAllTradesStreaming :: TestTree +testParseAllTradesStreaming = testCase "Parse ResponseAllTrades - valid XML (full)" $ do + let [TransaqResponseAllTrades (ResponseAllTrades trades)] = parseTransaqResponses validAllTrades + 2 @=? length trades + + let [t1, t2] = trades + + 1 @=? attSecId t1 + "SEC1" @=? attSecCode t1 + 14 @=? attTradeNo t1 + -- TODO check time + "BOARD" @=? attBoard t1 + assertBool "Price is not valid" (12.34 ~== attPrice t1) + 10 @=? attQuantity t1 + Buy @=? attBuysell t1 + 100 @=? attOpenInterest t1 + PeriodNormal @=? attPeriod t1 + + 2 @=? attSecId t2 + "SEC2" @=? attSecCode t2 + 15 @=? attTradeNo t2 + -- TODO check time + "BOARD" @=? attBoard t2 + assertBool "Price is not valid" (12.35 ~== attPrice t2) + 11 @=? attQuantity t2 + Sell @=? attBuysell t2 + 200 @=? attOpenInterest t2 + PeriodNormal @=? attPeriod t2 + where + validAllTrades = + [r| + + + SEC1 + 14 + + BOARD + 12.34 + 10 + B + 100 + N + + + SEC2 + 15 + + BOARD + 12.35 + 11 + S + 200 + N + + + |] :: BS.ByteString + +testParseQuotesStreaming :: TestTree +testParseQuotesStreaming = testCase "Parse ResponseQuotes - valid XML (full)" $ do + let [TransaqResponseQuotes (ResponseQuotes quotes)] = parseTransaqResponses validQuotes + 2 @=? length quotes + + let [q1, q2] = quotes + + 1 @=? q1.secId + "BOARD" @=? q1.board + assertBool "Price is not valid" (12.34 ~== q1.price) + Just "SOURCE" @=? q1.source + Just 10 @=? q1.buy + Nothing @=? q1.sell + + 2 @=? q2.secId + "BOARD" @=? q2.board + assertBool "Price is not valid" (12.35 ~== q2.price) + Just "SOURCE" @=? q2.source + Nothing @=? q2.buy + Just 11 @=? q2.sell + where + validQuotes = + [r| + + + BOARD + SEC1 + 12.34 + SOURCE + 10 + + + BOARD + SEC2 + 12.35 + SOURCE + 11 + + + |] :: BS.ByteString + +testParseOrdersStreaming :: TestTree +testParseOrdersStreaming = testCase "Parse ResponseOrders - valid XML (full)" $ do + let [TransaqResponseOrders (ResponseOrders orders)] = parseTransaqResponses validOrders + 1 @=? length orders + + let order = head orders + + 12 @=? oTransactionId order + 42 @=? oOrderNo order + 1 @=? oSecId order + "BOARD" @=? oBoard order + "SEC1" @=? oSecCode order + Just "CLIENT" @=? oClient order + Just "UNION" @=? oUnion order + Just OrderActive @=? oStatus order + Just Buy @=? oBuysell order + + let Just price' = oPrice order + assertBool "Price is not valid" (12.34 ~== price') + + Just 12 @=? oQuantity order + + where + validOrders = + [r| + + + 42 + 1 + BOARD + SEC1 + CLIENT + UNION + active + B + + 12.34 + 12 + + + |] :: BS.ByteString + +testParseTradesStreaming :: TestTree +testParseTradesStreaming = testCase "Parse ResponseTrades - valid XML (full)" $ do + let [TransaqResponseTrades (ResponseTrades trades)] = parseTransaqResponses validTrades + 1 @=? length trades + + let trade = head trades + + 1 @=? tSecId trade + 12 @=? tTradeNo trade + 42 @=? tOrderNo trade + "BOARD" @=? tBoard trade + "SEC1" @=? tSecCode trade + "CLIENT" @=? tClient trade + "UNION" @=? tUnion trade + Buy @=? tBuysell trade + -- TODO check time + + True @=? (123.4 ~== tValue trade) + True @=? (0.5 ~== tComission trade) + 10 @=? tQuantity trade + True @=? (12.34 ~== tPrice trade) + where + validTrades = + [r| + + + 1 + 12 + 42 + BOARD + SEC1 + CLIENT + UNION + B + + 123.40 + 0.5 + 10 + 12.34 + + + |] :: BS.ByteString diff --git a/transaq-connector.cabal b/transaq-connector.cabal index 5f5f7a4..e144a69 100644 --- a/transaq-connector.cabal +++ b/transaq-connector.cabal @@ -20,6 +20,7 @@ executable transaq-connector other-modules: Paths_transaq_connector , Config , Transaq + , Transaq.Parsing , TickerInfoServer , HistoryProviderServer , Version @@ -65,6 +66,7 @@ executable transaq-connector , th-printf , barbies , xeno + , megaparsec extra-lib-dirs: lib ghc-options: -Wall -Wcompat @@ -77,6 +79,7 @@ executable transaq-connector -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N if os(windows) + extra-lib-dirs: lib extra-libraries: txmlconnector64 other-modules: Win32.TXML else @@ -89,11 +92,13 @@ test-suite transaq-connector-test other-modules: Test.TickTable , Test.FSM , Test.Transaq + , Test.Transaq.Parsing , TXMLConnector , TXMLConnector.Internal , FSM , TickTable , Transaq + , Transaq.Parsing , Commissions , Config , TXML @@ -136,6 +141,56 @@ test-suite transaq-connector-test , barbies , raw-strings-qq , ieee754 + , megaparsec + default-extensions: OverloadedStrings + , MultiWayIf + , MultiParamTypeClasses + +benchmark parsing-benchmark + type: exitcode-stdio-1.0 + hs-source-dirs: bench src + main-is: Bench.hs + other-modules: Transaq + , Transaq.Parsing + + build-depends: base + , containers + , libatrade + , stm + , criterion + , dhall + , eventcounters + , libatrade == 0.15.0.0 + , text + , transformers + , co-log + , zeromq4-haskell + , aeson + , bytestring + , BoundedChan + , containers + , xml + , Decimal + , time + , attoparsec + , stm + , extra + , errors + , mtl + , vector + , binary + , bimap + , deque + , network-uri + , ekg-statsd + , ekg-core + , slave-thread + , xeno + , barbies + , raw-strings-qq + , ieee754 + , megaparsec + , safe default-extensions: OverloadedStrings , MultiWayIf , MultiParamTypeClasses