From 0e3f83c6f013d5259472f078d43a076b6af544c3 Mon Sep 17 00:00:00 2001 From: Denis Tereshkin Date: Sat, 6 Jan 2024 13:02:02 +0700 Subject: [PATCH] Tests for XML parsing --- src/TXMLConnector/Internal.hs | 28 +- src/Transaq.hs | 72 ++--- test/#Spec.hs# | 9 - test/Spec.hs | 4 +- test/Test/Transaq.hs | 500 +++++++++++++++++++++++++++++++++- transaq-connector.cabal | 8 + 6 files changed, 562 insertions(+), 59 deletions(-) delete mode 100644 test/#Spec.hs# diff --git a/src/TXMLConnector/Internal.hs b/src/TXMLConnector/Internal.hs index 8d9da3d..50b51db 100644 --- a/src/TXMLConnector/Internal.hs +++ b/src/TXMLConnector/Internal.hs @@ -377,20 +377,20 @@ handleTransaqData transaqData = do orderStateFromTransaq :: OrderNotification -> OrderState orderStateFromTransaq orderUpdate = case oStatus orderUpdate of - OrderActive -> Submitted - OrderCancelled -> Cancelled - OrderDenied -> Rejected - OrderDisabled -> Rejected - OrderExpired -> Cancelled - OrderFailed -> Rejected - OrderForwarding -> Unsubmitted - OrderInactive -> OrderError - OrderMatched -> Executed - OrderRefused -> Rejected - OrderRemoved -> Rejected - OrderWait -> Unsubmitted - OrderWatching -> Unsubmitted - _ -> OrderError + Just OrderActive -> Submitted + Just OrderCancelled -> Cancelled + Just OrderDenied -> Rejected + Just OrderDisabled -> Rejected + Just OrderExpired -> Cancelled + Just OrderFailed -> Rejected + Just OrderForwarding -> Unsubmitted + Just OrderInactive -> OrderError + Just OrderMatched -> Executed + Just OrderRefused -> Rejected + Just OrderRemoved -> Rejected + Just OrderWait -> Unsubmitted + Just OrderWatching -> Unsubmitted + _ -> OrderError handleConnected :: (MonadIO m, diff --git a/src/Transaq.hs b/src/Transaq.hs index 041758e..ed22a73 100644 --- a/src/Transaq.hs +++ b/src/Transaq.hs @@ -66,7 +66,8 @@ module Transaq Candle, CandleB(..), UnfilledAction(..), - TradeDirection(..) + TradeDirection(..), + TradingPeriod(..) ) where import Barbies @@ -469,6 +470,9 @@ instance TransaqResponseC Element (ResponseCandlesB Bare f) where , cOpenInterest = openInterest } :: CandleB Bare f) +instance TransaqResponseC T.Text (ResponseCandlesB Bare f) where + fromXml txt = undefined + data ConnectionState = Connected | Disconnected @@ -690,8 +694,8 @@ data ResponseSecInfoB t f = , market :: Wear t f Int , pname :: Wear t f T.Text , clearingPrice :: Wear t f Double - , minprice :: Wear t f Double - , maxprice :: Wear t f Double + , minPrice :: Wear t f Double + , maxPrice :: Wear t f Double , pointCost :: Wear t f Double } deriving (Generic) @@ -713,8 +717,8 @@ instance TransaqResponseC Element ResponseSecInfo where market <- childContent "market" tag >>= readMaybe pname <- T.pack <$> childContent "pname" tag clearingPrice <- childContent "clearing_price" tag >>= readMaybe - minprice <- childContent "minprice" tag >>= readMaybe - maxprice <- childContent "maxprice" tag >>= readMaybe + minPrice <- childContent "minprice" tag >>= readMaybe + maxPrice <- childContent "maxprice" tag >>= readMaybe pointCost <- childContent "point_cost" tag >>= readMaybe pure ResponseSecInfo {..} @@ -782,7 +786,7 @@ instance TransaqResponseC Element ResponseQuotations where let !qLastPrice = childContent "last" tag >>= readMaybe let !qQuantity = childContent "quantity" tag >>= readMaybe !qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack) - let !qValToday = childContent "valToday" tag >>= readMaybe + let !qValToday = childContent "valtoday" tag >>= readMaybe pure $ Just (Quotation {..} :: Quotation) data TradingPeriod = @@ -860,10 +864,10 @@ data QuoteB t f = , board :: Wear t f T.Text , secCode :: Wear t f T.Text , price :: Wear t f Double - , source :: Wear t f T.Text - , yield :: Wear t f Int - , buy :: Wear t f Int - , sell :: Wear t f Int + , source :: Maybe T.Text + , yield :: Maybe Int + , buy :: Maybe Int + , sell :: Maybe Int } deriving (Generic) type Quote = QuoteB Bare Identity @@ -890,10 +894,10 @@ instance TransaqResponseC Element ResponseQuotes where !secCode <- T.pack <$> childContent "seccode" tag !board <- T.pack <$> childContent "board" tag !price <- childContent "price" tag >>= readMaybe - !source <- T.pack <$> childContent "source" tag - !yield <- childContent "yield" tag >>= readMaybe - !buy <- childContent "buy" tag >>= readMaybe - !sell <- childContent "sell" tag >>= readMaybe + let !source = T.pack <$> childContent "source" tag + let !yield = childContent "yield" tag >>= readMaybe + let !buy = childContent "buy" tag >>= readMaybe + let !sell = childContent "sell" tag >>= readMaybe return . Just $ (Quote {..} :: Quote) data OrderStatus = @@ -921,16 +925,16 @@ data OrderNotificationB t f = , oSecId :: Wear t f Int , oBoard :: Wear t f T.Text , oSecCode :: Wear t f T.Text - , oClient :: Wear t f T.Text - , oUnion :: Wear t f T.Text - , oStatus :: Wear t f OrderStatus - , oBuysell :: Wear t f TradeDirection - , oTimestamp :: Wear t f UTCTime - , oBrokerRef :: Wear t f T.Text - , oBalance :: Wear t f Int - , oPrice :: Wear t f Double - , oQuantity :: Wear t f Int - , oResult :: Wear t f T.Text + , oClient :: Maybe T.Text + , oUnion :: Maybe T.Text + , oStatus :: Maybe OrderStatus + , oBuysell :: Maybe TradeDirection + , oTimestamp :: Maybe UTCTime + , oBrokerRef :: Maybe T.Text + , oBalance :: Maybe Int + , oPrice :: Maybe Double + , oQuantity :: Maybe Int + , oResult :: Maybe T.Text } deriving (Generic) type OrderNotification = OrderNotificationB Bare Identity @@ -958,16 +962,16 @@ instance TransaqResponseC Element ResponseOrders where !oSecId <- childContent "secid" tag >>= readMaybe !oBoard <- T.pack <$> childContent "board" tag !oSecCode <- T.pack <$> childContent "seccode" tag - !oClient <- T.pack <$> childContent "client" tag - !oUnion <- T.pack <$> childContent "union" tag - !oStatus <- childContent "status" tag >>= parseStatus - !oBuysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack - !oTimestamp <- childContent "time" tag >>= parseTimestamp . T.pack - !oBrokerRef <- T.pack <$> childContent "brokerref" tag - !oBalance <- childContent "balance" tag >>= readMaybe - !oPrice <- childContent "price" tag >>= readMaybe - !oQuantity <- childContent "quantity" tag >>= readMaybe - !oResult <- T.pack <$> childContent "result" tag + let !oClient = T.pack <$> childContent "client" tag + let !oUnion = T.pack <$> childContent "union" tag + let !oStatus = childContent "status" tag >>= parseStatus + let !oBuysell = childContent "buysell" tag >>= parseTradeDirection . T.pack + let !oTimestamp = childContent "time" tag >>= parseTimestamp . T.pack + let !oBrokerRef = T.pack <$> childContent "brokerref" tag + let !oBalance = childContent "balance" tag >>= readMaybe + let !oPrice = childContent "price" tag >>= readMaybe + let !oQuantity = childContent "quantity" tag >>= readMaybe + let !oResult = T.pack <$> childContent "result" tag return . Just $ (OrderNotification {..} :: OrderNotification) parseStatus "active" = Just OrderActive parseStatus "cancelled" = Just OrderCancelled diff --git a/test/#Spec.hs# b/test/#Spec.hs# deleted file mode 100644 index 12529bd..0000000 --- a/test/#Spec.hs# +++ /dev/null @@ -1,9 +0,0 @@ - -import Test.Tasty - -main :: IO () -main = defaultMain $ testGroup "Tests" [unitTests] - -unitTests :: TestTree -unitTests = testGroup "Unit Tests" - [ Test.RoboCom.Indicators.unitTests ] diff --git a/test/Spec.hs b/test/Spec.hs index 6e60c95..1050528 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,6 +4,7 @@ import Test.Tasty import qualified Test.FSM import qualified Test.TickTable +import qualified Test.Transaq main :: IO () main = do @@ -14,4 +15,5 @@ main = do unitTests :: TestTree unitTests = testGroup "Unit Tests" [ Test.TickTable.unitTests - , Test.FSM.unitTests ] + , Test.FSM.unitTests + , Test.Transaq.unitTests ] diff --git a/test/Test/Transaq.hs b/test/Test/Transaq.hs index d0673a4..73be781 100644 --- a/test/Test/Transaq.hs +++ b/test/Test/Transaq.hs @@ -1,12 +1,510 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QuasiQuotes #-} module Test.Transaq ( unitTests ) where +import Data.AEq ((~==)) +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 + unitTests :: TestTree unitTests = testGroup "Parsing" [ - test + testParseResult + , testParseCandles + , testParseClient + , testParseClientWithoutForts + , testParseServerStatus + , testParseMarkets + , testParseCandleKinds + , testParseSecurities + , testParseSecInfo + , testParseQuotations + , testParseAllTrades + , testParseQuotes + , testParseOrders + , testParseTrades + ] + +testParseResult :: TestTree +testParseResult = testGroup "Parsing result" + [ + testParseResultSuccess + , testParseResultSuccessWithTransactionId + , testParseResultFailure ] + where + resultSuccess = [r|>= fromXml :: Maybe ResponseResult) + return () + resultSuccessWithTransactionId = [r|>= fromXml :: Maybe ResponseResult) + return () + resultFailure = [r|>= fromXml :: Maybe ResponseResult) + return () + +testParseCandles :: TestTree +testParseCandles = testCase "Parse ResponseCandles - valid XML" $ do + let (Just responseCandles) = (parseXMLDoc validCandles >>= fromXml :: Maybe ResponseCandles) + 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| + + + + |] :: T.Text + +testParseClient :: TestTree +testParseClient = testCase "Parse ResponseClient - valid XML" $ do + let (Just (ResponseClient clientData)) = (parseXMLDoc validClient >>= fromXml :: Maybe ResponseClient) + "FOO" @=? cClientId clientData + "TYPE" @=? cType clientData + "CURRENCY" @=? cCurrency clientData + "MARKET" @=? cMarket clientData + "UNION" @=? cUnion clientData + Just "FORTS_ACC" @=? cForts clientData + where + validClient = + [r| + + TYPE + CURRENCY + MARKET + UNION + FORTS_ACC + + |] :: T.Text + +testParseClientWithoutForts :: TestTree +testParseClientWithoutForts = testCase "Parse ResponseClient - valid XML (without FORTS account ID)" $ do + let (Just (ResponseClient clientData)) = (parseXMLDoc validClient >>= fromXml :: Maybe ResponseClient) + "FOO" @=? cClientId clientData + "TYPE" @=? cType clientData + "CURRENCY" @=? cCurrency clientData + "MARKET" @=? cMarket clientData + "UNION" @=? cUnion clientData + Nothing @=? cForts clientData + where + validClient = + [r| + + TYPE + CURRENCY + MARKET + UNION + + |] :: T.Text + +testParseServerStatus :: TestTree +testParseServerStatus = testCase "Parse ResponseServerStatus - valid XML (full)" $ do + let (Just serverStatus) = (parseXMLDoc validServerStatus >>= fromXml :: Maybe ResponseServerStatus) + 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| |] :: T.Text + +testParseMarkets :: TestTree +testParseMarkets = testCase "Parse ResponseMarkets - valid XML" $ do + let (Just (ResponseMarkets markets)) = (parseXMLDoc validMarkets >>= fromXml :: Maybe ResponseMarkets) + 2 @=? length markets + + let [foo, bar] = markets + + 1 @=? marketId foo + "FOO" @=? marketName foo + + 2 @=? marketId bar + "BAR" @=? marketName bar + where + validMarkets = + [r| + + FOO + BAR + + |] :: T.Text + +testParseCandleKinds :: TestTree +testParseCandleKinds = testCase "Parse ResponseCandleKinds - valid XML" $ do + let (Just (ResponseCandleKinds candleKinds)) = (parseXMLDoc validCandleKinds >>= fromXml :: Maybe ResponseCandleKinds) + + 2 @=? length candleKinds + + let [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 + + + |] :: T.Text + +testParseSecurities :: TestTree +testParseSecurities = testCase "Parse ResponseSecurities - valid XML" $ do + let (Just (ResponseSecurities securities)) = (parseXMLDoc validSecurities >>= fromXml :: Maybe ResponseSecurities) + 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 + + + |] :: T.Text + +testParseSecInfo :: TestTree +testParseSecInfo = testCase "Parse ResponseSecInfo - valid XML" $ do + let (Just sec) = (parseXMLDoc validSecInfo >>= fromXml :: Maybe ResponseSecInfo) + + "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 + + |] :: T.Text + +testParseQuotations :: TestTree +testParseQuotations = testCase "Parse ResponseQuotations - valid XML (full)" $ do + let (Just (ResponseQuotations quotations)) = (parseXMLDoc validQuotations >>= fromXml :: Maybe ResponseQuotations) + 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 + + + |] :: T.Text + +testParseAllTrades :: TestTree +testParseAllTrades = testCase "Parse ResponseAllTrades - valid XML (full)" $ do + let (Just (ResponseAllTrades trades)) = (parseXMLDoc validAllTrades >>= fromXml :: Maybe ResponseAllTrades) + 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 + + + |] :: T.Text + +testParseQuotes :: TestTree +testParseQuotes = testCase "Parse ResponseQuotes - valid XML (full)" $ do + let (Just (ResponseQuotes quotes)) = (parseXMLDoc validQuotes >>= fromXml :: Maybe ResponseQuotes) + 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 + + + |] :: T.Text + +testParseOrders :: TestTree +testParseOrders = testCase "Parse ResponseOrders - valid XML (full)" $ do + let (Just (ResponseOrders orders)) = (parseXMLDoc validOrders >>= fromXml :: Maybe ResponseOrders) + 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 + + + |] :: T.Text + +testParseTrades :: TestTree +testParseTrades = testCase "Parse ResponseTrades - valid XML (full)" $ do + let (Just (ResponseTrades trades)) = (parseXMLDoc validTrades >>= fromXml :: Maybe ResponseTrades) + 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 + + + |] :: T.Text diff --git a/transaq-connector.cabal b/transaq-connector.cabal index 4495a4f..5f5f7a4 100644 --- a/transaq-connector.cabal +++ b/transaq-connector.cabal @@ -88,10 +88,16 @@ test-suite transaq-connector-test main-is: Spec.hs other-modules: Test.TickTable , Test.FSM + , Test.Transaq , TXMLConnector , TXMLConnector.Internal , FSM , TickTable + , Transaq + , Commissions + , Config + , TXML + , TickerInfoServer build-depends: base , containers @@ -128,6 +134,8 @@ test-suite transaq-connector-test , slave-thread , xeno , barbies + , raw-strings-qq + , ieee754 default-extensions: OverloadedStrings , MultiWayIf , MultiParamTypeClasses