Browse Source

Tests for XML parsing

master
Denis Tereshkin 2 years ago
parent
commit
0e3f83c6f0
  1. 28
      src/TXMLConnector/Internal.hs
  2. 72
      src/Transaq.hs
  3. 9
      test/#Spec.hs#
  4. 4
      test/Spec.hs
  5. 500
      test/Test/Transaq.hs
  6. 8
      transaq-connector.cabal

28
src/TXMLConnector/Internal.hs

@ -377,20 +377,20 @@ handleTransaqData transaqData = do
orderStateFromTransaq :: OrderNotification -> OrderState orderStateFromTransaq :: OrderNotification -> OrderState
orderStateFromTransaq orderUpdate = orderStateFromTransaq orderUpdate =
case oStatus orderUpdate of case oStatus orderUpdate of
OrderActive -> Submitted Just OrderActive -> Submitted
OrderCancelled -> Cancelled Just OrderCancelled -> Cancelled
OrderDenied -> Rejected Just OrderDenied -> Rejected
OrderDisabled -> Rejected Just OrderDisabled -> Rejected
OrderExpired -> Cancelled Just OrderExpired -> Cancelled
OrderFailed -> Rejected Just OrderFailed -> Rejected
OrderForwarding -> Unsubmitted Just OrderForwarding -> Unsubmitted
OrderInactive -> OrderError Just OrderInactive -> OrderError
OrderMatched -> Executed Just OrderMatched -> Executed
OrderRefused -> Rejected Just OrderRefused -> Rejected
OrderRemoved -> Rejected Just OrderRemoved -> Rejected
OrderWait -> Unsubmitted Just OrderWait -> Unsubmitted
OrderWatching -> Unsubmitted Just OrderWatching -> Unsubmitted
_ -> OrderError _ -> OrderError
handleConnected :: (MonadIO m, handleConnected :: (MonadIO m,

72
src/Transaq.hs

@ -66,7 +66,8 @@ module Transaq
Candle, Candle,
CandleB(..), CandleB(..),
UnfilledAction(..), UnfilledAction(..),
TradeDirection(..) TradeDirection(..),
TradingPeriod(..)
) where ) where
import Barbies import Barbies
@ -469,6 +470,9 @@ instance TransaqResponseC Element (ResponseCandlesB Bare f) where
, cOpenInterest = openInterest , cOpenInterest = openInterest
} :: CandleB Bare f) } :: CandleB Bare f)
instance TransaqResponseC T.Text (ResponseCandlesB Bare f) where
fromXml txt = undefined
data ConnectionState = data ConnectionState =
Connected Connected
| Disconnected | Disconnected
@ -690,8 +694,8 @@ data ResponseSecInfoB t f =
, market :: Wear t f Int , market :: Wear t f Int
, pname :: Wear t f T.Text , pname :: Wear t f T.Text
, clearingPrice :: Wear t f Double , clearingPrice :: Wear t f Double
, minprice :: Wear t f Double , minPrice :: Wear t f Double
, maxprice :: Wear t f Double , maxPrice :: Wear t f Double
, pointCost :: Wear t f Double , pointCost :: Wear t f Double
} deriving (Generic) } deriving (Generic)
@ -713,8 +717,8 @@ instance TransaqResponseC Element ResponseSecInfo where
market <- childContent "market" tag >>= readMaybe market <- childContent "market" tag >>= readMaybe
pname <- T.pack <$> childContent "pname" tag pname <- T.pack <$> childContent "pname" tag
clearingPrice <- childContent "clearing_price" tag >>= readMaybe clearingPrice <- childContent "clearing_price" tag >>= readMaybe
minprice <- childContent "minprice" tag >>= readMaybe minPrice <- childContent "minprice" tag >>= readMaybe
maxprice <- childContent "maxprice" tag >>= readMaybe maxPrice <- childContent "maxprice" tag >>= readMaybe
pointCost <- childContent "point_cost" tag >>= readMaybe pointCost <- childContent "point_cost" tag >>= readMaybe
pure ResponseSecInfo {..} pure ResponseSecInfo {..}
@ -782,7 +786,7 @@ instance TransaqResponseC Element ResponseQuotations where
let !qLastPrice = childContent "last" tag >>= readMaybe let !qLastPrice = childContent "last" tag >>= readMaybe
let !qQuantity = childContent "quantity" tag >>= readMaybe let !qQuantity = childContent "quantity" tag >>= readMaybe
!qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack) !qTimestamp <- childContent "time" tag >>= (parseTimestamp . T.pack)
let !qValToday = childContent "valToday" tag >>= readMaybe let !qValToday = childContent "valtoday" tag >>= readMaybe
pure $ Just (Quotation {..} :: Quotation) pure $ Just (Quotation {..} :: Quotation)
data TradingPeriod = data TradingPeriod =
@ -860,10 +864,10 @@ data QuoteB t f =
, board :: Wear t f T.Text , board :: Wear t f T.Text
, secCode :: Wear t f T.Text , secCode :: Wear t f T.Text
, price :: Wear t f Double , price :: Wear t f Double
, source :: Wear t f T.Text , source :: Maybe T.Text
, yield :: Wear t f Int , yield :: Maybe Int
, buy :: Wear t f Int , buy :: Maybe Int
, sell :: Wear t f Int , sell :: Maybe Int
} deriving (Generic) } deriving (Generic)
type Quote = QuoteB Bare Identity type Quote = QuoteB Bare Identity
@ -890,10 +894,10 @@ instance TransaqResponseC Element ResponseQuotes where
!secCode <- T.pack <$> childContent "seccode" tag !secCode <- T.pack <$> childContent "seccode" tag
!board <- T.pack <$> childContent "board" tag !board <- T.pack <$> childContent "board" tag
!price <- childContent "price" tag >>= readMaybe !price <- childContent "price" tag >>= readMaybe
!source <- T.pack <$> childContent "source" tag let !source = T.pack <$> childContent "source" tag
!yield <- childContent "yield" tag >>= readMaybe let !yield = childContent "yield" tag >>= readMaybe
!buy <- childContent "buy" tag >>= readMaybe let !buy = childContent "buy" tag >>= readMaybe
!sell <- childContent "sell" tag >>= readMaybe let !sell = childContent "sell" tag >>= readMaybe
return . Just $ (Quote {..} :: Quote) return . Just $ (Quote {..} :: Quote)
data OrderStatus = data OrderStatus =
@ -921,16 +925,16 @@ data OrderNotificationB t f =
, oSecId :: Wear t f Int , oSecId :: Wear t f Int
, oBoard :: Wear t f T.Text , oBoard :: Wear t f T.Text
, oSecCode :: Wear t f T.Text , oSecCode :: Wear t f T.Text
, oClient :: Wear t f T.Text , oClient :: Maybe T.Text
, oUnion :: Wear t f T.Text , oUnion :: Maybe T.Text
, oStatus :: Wear t f OrderStatus , oStatus :: Maybe OrderStatus
, oBuysell :: Wear t f TradeDirection , oBuysell :: Maybe TradeDirection
, oTimestamp :: Wear t f UTCTime , oTimestamp :: Maybe UTCTime
, oBrokerRef :: Wear t f T.Text , oBrokerRef :: Maybe T.Text
, oBalance :: Wear t f Int , oBalance :: Maybe Int
, oPrice :: Wear t f Double , oPrice :: Maybe Double
, oQuantity :: Wear t f Int , oQuantity :: Maybe Int
, oResult :: Wear t f T.Text , oResult :: Maybe T.Text
} deriving (Generic) } deriving (Generic)
type OrderNotification = OrderNotificationB Bare Identity type OrderNotification = OrderNotificationB Bare Identity
@ -958,16 +962,16 @@ instance TransaqResponseC Element ResponseOrders where
!oSecId <- childContent "secid" tag >>= readMaybe !oSecId <- childContent "secid" tag >>= readMaybe
!oBoard <- T.pack <$> childContent "board" tag !oBoard <- T.pack <$> childContent "board" tag
!oSecCode <- T.pack <$> childContent "seccode" tag !oSecCode <- T.pack <$> childContent "seccode" tag
!oClient <- T.pack <$> childContent "client" tag let !oClient = T.pack <$> childContent "client" tag
!oUnion <- T.pack <$> childContent "union" tag let !oUnion = T.pack <$> childContent "union" tag
!oStatus <- childContent "status" tag >>= parseStatus let !oStatus = childContent "status" tag >>= parseStatus
!oBuysell <- childContent "buysell" tag >>= parseTradeDirection . T.pack let !oBuysell = childContent "buysell" tag >>= parseTradeDirection . T.pack
!oTimestamp <- childContent "time" tag >>= parseTimestamp . T.pack let !oTimestamp = childContent "time" tag >>= parseTimestamp . T.pack
!oBrokerRef <- T.pack <$> childContent "brokerref" tag let !oBrokerRef = T.pack <$> childContent "brokerref" tag
!oBalance <- childContent "balance" tag >>= readMaybe let !oBalance = childContent "balance" tag >>= readMaybe
!oPrice <- childContent "price" tag >>= readMaybe let !oPrice = childContent "price" tag >>= readMaybe
!oQuantity <- childContent "quantity" tag >>= readMaybe let !oQuantity = childContent "quantity" tag >>= readMaybe
!oResult <- T.pack <$> childContent "result" tag let !oResult = T.pack <$> childContent "result" tag
return . Just $ (OrderNotification {..} :: OrderNotification) return . Just $ (OrderNotification {..} :: OrderNotification)
parseStatus "active" = Just OrderActive parseStatus "active" = Just OrderActive
parseStatus "cancelled" = Just OrderCancelled parseStatus "cancelled" = Just OrderCancelled

9
test/#Spec.hs#

@ -1,9 +0,0 @@
import Test.Tasty
main :: IO ()
main = defaultMain $ testGroup "Tests" [unitTests]
unitTests :: TestTree
unitTests = testGroup "Unit Tests"
[ Test.RoboCom.Indicators.unitTests ]

4
test/Spec.hs

@ -4,6 +4,7 @@ import Test.Tasty
import qualified Test.FSM import qualified Test.FSM
import qualified Test.TickTable import qualified Test.TickTable
import qualified Test.Transaq
main :: IO () main :: IO ()
main = do main = do
@ -14,4 +15,5 @@ main = do
unitTests :: TestTree unitTests :: TestTree
unitTests = testGroup "Unit Tests" unitTests = testGroup "Unit Tests"
[ Test.TickTable.unitTests [ Test.TickTable.unitTests
, Test.FSM.unitTests ] , Test.FSM.unitTests
, Test.Transaq.unitTests ]

500
test/Test/Transaq.hs

@ -1,12 +1,510 @@
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.Transaq module Test.Transaq
( (
unitTests unitTests
) where ) 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 :: TestTree
unitTests = testGroup "Parsing" 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|<result success="true />"|] :: T.Text
testParseResultSuccess = testCase "Parse success result" $ do
let (Just (ResponseSuccess Nothing)) = (parseXMLDoc resultSuccess >>= fromXml :: Maybe ResponseResult)
return ()
resultSuccessWithTransactionId = [r|<result success="true" transactionid="12"|] :: T.Text
testParseResultSuccessWithTransactionId = testCase "Parse success result with transaction ID" $ do
let (Just (ResponseSuccess (Just 12))) = (parseXMLDoc resultSuccessWithTransactionId >>= fromXml :: Maybe ResponseResult)
return ()
resultFailure = [r|<result success="false />"|] :: T.Text
testParseResultFailure = testCase "Parse success result" $ do
let (Just (ResponseFailure _)) = (parseXMLDoc resultFailure >>= 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|
<candles secid="12" period="1" status="0" board="foo" seccode="bar">
<candle date="05.01.2024 12:30:00.123" open="41.3" high="42" low="40" close="41.6" volume="1234" oi="78" />
</candles>
|] :: 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|
<client id="FOO">
<type>TYPE</type>
<currency>CURRENCY</currency>
<market>MARKET</market>
<union>UNION</union>
<forts_acc>FORTS_ACC</forts_acc>
</client>
|] :: 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|
<client id="FOO">
<type>TYPE</type>
<currency>CURRENCY</currency>
<market>MARKET</market>
<union>UNION</union>
</client>
|] :: 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|<server_status id="22" connected="true" recover="true" server_tz="TZ" sys_ver="42" build="51" /> |] :: 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|
<markets>
<market id="1">FOO</market>
<market id="2">BAR</market>
</markets>
|] :: 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|
<candlekinds>
<kind>
<id>4</id>
<period>600</period>
<name>M10</name>
</kind>
<kind>
<id>5</id>
<period>900</period>
<name>M15</name>
</kind>
</candlekinds>
|] :: 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|
<securities>
<security secid="1" active="true">
<seccode>SECCODE</seccode>
<instrclass>CLASS</instrclass>
<board>BOARD</board>
<market>15</market>
<currency>CURRENCY</currency>
<shortname>SHORTNAME</shortname>
<decimals>3</decimals>
<minstep>0.1</minstep>
<lotsize>10</lotsize>
<lotdivider>1</lotdivider>
<point_cost>6.28</point_cost>
<optmask usecredit="yes" bymarket="no" nosplit="yes" fok="no" ioc="no" />
<sectype>SECTYPE</sectype>
<sec_tz>SECTZ</sec_tz>
<quotestype>1</quotestype>
<MIC>FOO</MIC>
<currencyid>CURRENCYID</currencyid>
</security>
</securities>
|] :: 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|
<sec_info secid="4">
<secname>SECNAME</secname>
<seccode>SECCODE</seccode>
<market>44</market>
<pname>PNAME</pname>
<clearing_price>12.34</clearing_price>
<minprice>10</minprice>
<maxprice>20</maxprice>
<point_cost>6.28</point_cost>
</sec_info>
|] :: 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|
<quotations>
<quotation secid="1">
<board>BOARD</board>
<seccode>SECCODE</seccode>
<open>12.34</open>
<waprice>13.8</waprice>
<biddepth>40</biddepth>
<biddeptht>140</biddeptht>
<numbids>10</numbids>
<bid>11.01</bid>
<offerdepth>50</offerdepth>
<offerdeptht>150</offerdeptht>
<numoffers>15</numoffers>
<offer>11.05</offer>
<numtrades>1000</numtrades>
<voltoday>50000</voltoday>
<openpositions>1000</openpositions>
<last>11.03</last>
<quantity>8</quantity>
<time>05.01.2024 19:34:18.234</time>
<valtoday>12345678</valtoday>
</quotation>
</quotations>
|] :: 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|
<alltrades>
<trade secid="1">
<seccode>SEC1</seccode>
<tradeno>14</tradeno>
<time>05.01.2024 19:34:18.234</time>
<board>BOARD</board>
<price>12.34</price>
<quantity>10</quantity>
<buysell>B</buysell>
<openinterest>100</openinterest>
<period>N</period>
</trade>
<trade secid="2">
<seccode>SEC2</seccode>
<tradeno>15</tradeno>
<time>05.01.2024 19:34:19.234</time>
<board>BOARD</board>
<price>12.35</price>
<quantity>11</quantity>
<buysell>S</buysell>
<openinterest>200</openinterest>
<period>N</period>
</trade>
</alltrades>
|] :: 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|
<quotes>
<quote secid="1">
<board>BOARD</board>
<seccode>SEC1</seccode>
<price>12.34</price>
<source>SOURCE</source>
<buy>10</buy>
</quote>
<quote secid="2">
<board>BOARD</board>
<seccode>SEC2</seccode>
<price>12.35</price>
<source>SOURCE</source>
<sell>11</sell>
</quote>
</quotes>
|] :: 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|
<orders>
<order transactionid="12">
<orderno>42</orderno>
<secid>1</secid>
<board>BOARD</board>
<seccode>SEC1</seccode>
<client>CLIENT</client>
<union>UNION</union>
<status>active</status>
<buysell>B</buysell>
<time>05.01.2024 19:34:19.234</time>
<price>12.34</price>
<quantity>12</quantity>
</order>
</orders>
|] :: 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|
<trades>
<trade>
<secid>1</secid>
<tradeno>12</tradeno>
<orderno>42</orderno>
<board>BOARD</board>
<seccode>SEC1</seccode>
<client>CLIENT</client>
<union>UNION</union>
<buysell>B</buysell>
<time>05.01.2024 19:34:19.234</time>
<value>123.40</value>
<comission>0.5</comission>
<quantity>10</quantity>
<price>12.34</price>
</trade>
</trades>
|] :: T.Text

8
transaq-connector.cabal

@ -88,10 +88,16 @@ test-suite transaq-connector-test
main-is: Spec.hs main-is: Spec.hs
other-modules: Test.TickTable other-modules: Test.TickTable
, Test.FSM , Test.FSM
, Test.Transaq
, TXMLConnector , TXMLConnector
, TXMLConnector.Internal , TXMLConnector.Internal
, FSM , FSM
, TickTable , TickTable
, Transaq
, Commissions
, Config
, TXML
, TickerInfoServer
build-depends: base build-depends: base
, containers , containers
@ -128,6 +134,8 @@ test-suite transaq-connector-test
, slave-thread , slave-thread
, xeno , xeno
, barbies , barbies
, raw-strings-qq
, ieee754
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
, MultiWayIf , MultiWayIf
, MultiParamTypeClasses , MultiParamTypeClasses

Loading…
Cancel
Save