You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
510 lines
15 KiB
510 lines
15 KiB
{-# 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" |
|
[ |
|
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
|
|
|